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 bool 64 Perl_do_openn(pTHX_ GV *gv, const char *oname, I32 len, int as_raw, 65 int rawmode, int rawperm, PerlIO *supplied_fp, SV **svp, 66 I32 num_svs) 67 { 68 dVAR; 69 IO * const io = GvIOn(gv); 70 PerlIO *saveifp = NULL; 71 PerlIO *saveofp = NULL; 72 int savefd = -1; 73 char savetype = IoTYPE_CLOSED; 74 int writing = 0; 75 PerlIO *fp; 76 int fd; 77 int result; 78 bool was_fdopen = FALSE; 79 bool in_raw = 0, in_crlf = 0, out_raw = 0, out_crlf = 0; 80 char *type = NULL; 81 char mode[PERL_MODE_MAX]; /* file mode ("r\0", "rb\0", "ab\0" etc.) */ 82 SV *namesv; 83 84 PERL_ARGS_ASSERT_DO_OPENN; 85 86 Zero(mode,sizeof(mode),char); 87 PL_forkprocess = 1; /* assume true if no fork */ 88 89 /* Collect default raw/crlf info from the op */ 90 if (PL_op && PL_op->op_type == OP_OPEN) { 91 /* set up IO layers */ 92 const U8 flags = PL_op->op_private; 93 in_raw = (flags & OPpOPEN_IN_RAW); 94 in_crlf = (flags & OPpOPEN_IN_CRLF); 95 out_raw = (flags & OPpOPEN_OUT_RAW); 96 out_crlf = (flags & OPpOPEN_OUT_CRLF); 97 } 98 99 /* If currently open - close before we re-open */ 100 if (IoIFP(io)) { 101 fd = PerlIO_fileno(IoIFP(io)); 102 if (IoTYPE(io) == IoTYPE_STD) { 103 /* This is a clone of one of STD* handles */ 104 result = 0; 105 } 106 else if (fd >= 0 && fd <= PL_maxsysfd) { 107 /* This is one of the original STD* handles */ 108 saveifp = IoIFP(io); 109 saveofp = IoOFP(io); 110 savetype = IoTYPE(io); 111 savefd = fd; 112 result = 0; 113 } 114 else if (IoTYPE(io) == IoTYPE_PIPE) 115 result = PerlProc_pclose(IoIFP(io)); 116 else if (IoIFP(io) != IoOFP(io)) { 117 if (IoOFP(io)) { 118 result = PerlIO_close(IoOFP(io)); 119 PerlIO_close(IoIFP(io)); /* clear stdio, fd already closed */ 120 } 121 else 122 result = PerlIO_close(IoIFP(io)); 123 } 124 else 125 result = PerlIO_close(IoIFP(io)); 126 if (result == EOF && fd > PL_maxsysfd) { 127 /* Why is this not Perl_warn*() call ? */ 128 PerlIO_printf(Perl_error_log, 129 "Warning: unable to close filehandle %"HEKf" properly.\n", 130 HEKfARG(GvENAME_HEK(gv)) 131 ); 132 } 133 IoOFP(io) = IoIFP(io) = NULL; 134 } 135 136 if (as_raw) { 137 /* sysopen style args, i.e. integer mode and permissions */ 138 STRLEN ix = 0; 139 const int appendtrunc = 140 0 141 #ifdef O_APPEND /* Not fully portable. */ 142 |O_APPEND 143 #endif 144 #ifdef O_TRUNC /* Not fully portable. */ 145 |O_TRUNC 146 #endif 147 ; 148 const int modifyingmode = O_WRONLY|O_RDWR|O_CREAT|appendtrunc; 149 int ismodifying; 150 151 if (num_svs != 0) { 152 Perl_croak(aTHX_ "panic: sysopen with multiple args, num_svs=%ld", 153 (long) num_svs); 154 } 155 /* It's not always 156 157 O_RDONLY 0 158 O_WRONLY 1 159 O_RDWR 2 160 161 It might be (in OS/390 and Mac OS Classic it is) 162 163 O_WRONLY 1 164 O_RDONLY 2 165 O_RDWR 3 166 167 This means that simple & with O_RDWR would look 168 like O_RDONLY is present. Therefore we have to 169 be more careful. 170 */ 171 if ((ismodifying = (rawmode & modifyingmode))) { 172 if ((ismodifying & O_WRONLY) == O_WRONLY || 173 (ismodifying & O_RDWR) == O_RDWR || 174 (ismodifying & (O_CREAT|appendtrunc))) 175 TAINT_PROPER("sysopen"); 176 } 177 mode[ix++] = IoTYPE_NUMERIC; /* Marker to openn to use numeric "sysopen" */ 178 179 #if defined(USE_64_BIT_RAWIO) && defined(O_LARGEFILE) 180 rawmode |= O_LARGEFILE; /* Transparently largefiley. */ 181 #endif 182 183 IoTYPE(io) = PerlIO_intmode2str(rawmode, &mode[ix], &writing); 184 185 namesv = newSVpvn_flags(oname, len, SVs_TEMP); 186 num_svs = 1; 187 svp = &namesv; 188 type = NULL; 189 fp = PerlIO_openn(aTHX_ type, mode, -1, rawmode, rawperm, NULL, num_svs, svp); 190 } 191 else { 192 /* Regular (non-sys) open */ 193 char *name; 194 STRLEN olen = len; 195 char *tend; 196 int dodup = 0; 197 198 type = savepvn(oname, len); 199 tend = type+len; 200 SAVEFREEPV(type); 201 202 /* Lose leading and trailing white space */ 203 while (isSPACE(*type)) 204 type++; 205 while (tend > type && isSPACE(tend[-1])) 206 *--tend = '\0'; 207 208 if (num_svs) { 209 /* New style explicit name, type is just mode and layer info */ 210 #ifdef USE_STDIO 211 if (SvROK(*svp) && !strchr(oname,'&')) { 212 if (ckWARN(WARN_IO)) 213 Perl_warner(aTHX_ packWARN(WARN_IO), 214 "Can't open a reference"); 215 SETERRNO(EINVAL, LIB_INVARG); 216 goto say_false; 217 } 218 #endif /* USE_STDIO */ 219 name = (SvOK(*svp) || SvGMAGICAL(*svp)) ? 220 savesvpv (*svp) : savepvs (""); 221 SAVEFREEPV(name); 222 } 223 else { 224 name = type; 225 len = tend-type; 226 } 227 IoTYPE(io) = *type; 228 if ((*type == IoTYPE_RDWR) && /* scary */ 229 (*(type+1) == IoTYPE_RDONLY || *(type+1) == IoTYPE_WRONLY) && 230 ((!num_svs || (tend > type+1 && tend[-1] != IoTYPE_PIPE)))) { 231 TAINT_PROPER("open"); 232 mode[1] = *type++; 233 writing = 1; 234 } 235 236 if (*type == IoTYPE_PIPE) { 237 if (num_svs) { 238 if (type[1] != IoTYPE_STD) { 239 unknown_open_mode: 240 Perl_croak(aTHX_ "Unknown open() mode '%.*s'", (int)olen, oname); 241 } 242 type++; 243 } 244 do { 245 type++; 246 } while (isSPACE(*type)); 247 if (!num_svs) { 248 name = type; 249 len = tend-type; 250 } 251 if (*name == '\0') { 252 /* command is missing 19990114 */ 253 if (ckWARN(WARN_PIPE)) 254 Perl_warner(aTHX_ packWARN(WARN_PIPE), "Missing command in piped open"); 255 errno = EPIPE; 256 goto say_false; 257 } 258 if (!(*name == '-' && name[1] == '\0') || num_svs) 259 TAINT_ENV(); 260 TAINT_PROPER("piped open"); 261 if (!num_svs && name[len-1] == '|') { 262 name[--len] = '\0' ; 263 if (ckWARN(WARN_PIPE)) 264 Perl_warner(aTHX_ packWARN(WARN_PIPE), "Can't open bidirectional pipe"); 265 } 266 mode[0] = 'w'; 267 writing = 1; 268 if (out_raw) 269 mode[1] = 'b'; 270 else if (out_crlf) 271 mode[1] = 't'; 272 if (num_svs > 1) { 273 fp = PerlProc_popen_list(mode, num_svs, svp); 274 } 275 else { 276 fp = PerlProc_popen(name,mode); 277 } 278 if (num_svs) { 279 if (*type) { 280 if (PerlIO_apply_layers(aTHX_ fp, mode, type) != 0) { 281 goto say_false; 282 } 283 } 284 } 285 } /* IoTYPE_PIPE */ 286 else if (*type == IoTYPE_WRONLY) { 287 TAINT_PROPER("open"); 288 type++; 289 if (*type == IoTYPE_WRONLY) { 290 /* Two IoTYPE_WRONLYs in a row make for an IoTYPE_APPEND. */ 291 mode[0] = IoTYPE(io) = IoTYPE_APPEND; 292 type++; 293 } 294 else { 295 mode[0] = 'w'; 296 } 297 writing = 1; 298 299 if (out_raw) 300 mode[1] = 'b'; 301 else if (out_crlf) 302 mode[1] = 't'; 303 if (*type == '&') { 304 duplicity: 305 dodup = PERLIO_DUP_FD; 306 type++; 307 if (*type == '=') { 308 dodup = 0; 309 type++; 310 } 311 if (!num_svs && !*type && supplied_fp) { 312 /* "<+&" etc. is used by typemaps */ 313 fp = supplied_fp; 314 } 315 else { 316 PerlIO *that_fp = NULL; 317 if (num_svs > 1) { 318 /* diag_listed_as: More than one argument to '%s' open */ 319 Perl_croak(aTHX_ "More than one argument to '%c&' open",IoTYPE(io)); 320 } 321 while (isSPACE(*type)) 322 type++; 323 if (num_svs && ( 324 SvIOK(*svp) 325 || (SvPOKp(*svp) && looks_like_number(*svp)) 326 )) { 327 fd = SvUV(*svp); 328 num_svs = 0; 329 } 330 else if (isDIGIT(*type)) { 331 fd = atoi(type); 332 } 333 else { 334 const IO* thatio; 335 if (num_svs) { 336 thatio = sv_2io(*svp); 337 } 338 else { 339 GV * const thatgv = gv_fetchpvn_flags(type, tend - type, 340 0, SVt_PVIO); 341 thatio = GvIO(thatgv); 342 } 343 if (!thatio) { 344 #ifdef EINVAL 345 SETERRNO(EINVAL,SS_IVCHAN); 346 #endif 347 goto say_false; 348 } 349 if ((that_fp = IoIFP(thatio))) { 350 /* Flush stdio buffer before dup. --mjd 351 * Unfortunately SEEK_CURing 0 seems to 352 * be optimized away on most platforms; 353 * only Solaris and Linux seem to flush 354 * on that. --jhi */ 355 #ifdef USE_SFIO 356 /* sfio fails to clear error on next 357 sfwrite, contrary to documentation. 358 -- Nicholas Clark */ 359 if (PerlIO_seek(that_fp, 0, SEEK_CUR) == -1) 360 PerlIO_clearerr(that_fp); 361 #endif 362 /* On the other hand, do all platforms 363 * take gracefully to flushing a read-only 364 * filehandle? Perhaps we should do 365 * fsetpos(src)+fgetpos(dst)? --nik */ 366 PerlIO_flush(that_fp); 367 fd = PerlIO_fileno(that_fp); 368 /* When dup()ing STDIN, STDOUT or STDERR 369 * explicitly set appropriate access mode */ 370 if (that_fp == PerlIO_stdout() 371 || that_fp == PerlIO_stderr()) 372 IoTYPE(io) = IoTYPE_WRONLY; 373 else if (that_fp == PerlIO_stdin()) 374 IoTYPE(io) = IoTYPE_RDONLY; 375 /* When dup()ing a socket, say result is 376 * one as well */ 377 else if (IoTYPE(thatio) == IoTYPE_SOCKET) 378 IoTYPE(io) = IoTYPE_SOCKET; 379 } 380 else 381 fd = -1; 382 } 383 if (!num_svs) 384 type = NULL; 385 if (that_fp) { 386 fp = PerlIO_fdupopen(aTHX_ that_fp, NULL, dodup); 387 } 388 else { 389 if (dodup) 390 fd = PerlLIO_dup(fd); 391 else 392 was_fdopen = TRUE; 393 if (!(fp = PerlIO_openn(aTHX_ type,mode,fd,0,0,NULL,num_svs,svp))) { 394 if (dodup && fd >= 0) 395 PerlLIO_close(fd); 396 } 397 } 398 } 399 } /* & */ 400 else { 401 while (isSPACE(*type)) 402 type++; 403 if (*type == IoTYPE_STD && (!type[1] || isSPACE(type[1]) || type[1] == ':')) { 404 type++; 405 fp = PerlIO_stdout(); 406 IoTYPE(io) = IoTYPE_STD; 407 if (num_svs > 1) { 408 /* diag_listed_as: More than one argument to '%s' open */ 409 Perl_croak(aTHX_ "More than one argument to '>%c' open",IoTYPE_STD); 410 } 411 } 412 else { 413 if (!num_svs) { 414 namesv = newSVpvn_flags(type, tend - type, SVs_TEMP); 415 num_svs = 1; 416 svp = &namesv; 417 type = NULL; 418 } 419 fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,num_svs,svp); 420 } 421 } /* !& */ 422 if (!fp && type && *type && *type != ':' && !isIDFIRST(*type)) 423 goto unknown_open_mode; 424 } /* IoTYPE_WRONLY */ 425 else if (*type == IoTYPE_RDONLY) { 426 do { 427 type++; 428 } while (isSPACE(*type)); 429 mode[0] = 'r'; 430 if (in_raw) 431 mode[1] = 'b'; 432 else if (in_crlf) 433 mode[1] = 't'; 434 if (*type == '&') { 435 goto duplicity; 436 } 437 if (*type == IoTYPE_STD && (!type[1] || isSPACE(type[1]) || type[1] == ':')) { 438 type++; 439 fp = PerlIO_stdin(); 440 IoTYPE(io) = IoTYPE_STD; 441 if (num_svs > 1) { 442 /* diag_listed_as: More than one argument to '%s' open */ 443 Perl_croak(aTHX_ "More than one argument to '<%c' open",IoTYPE_STD); 444 } 445 } 446 else { 447 if (!num_svs) { 448 namesv = newSVpvn_flags(type, tend - type, SVs_TEMP); 449 num_svs = 1; 450 svp = &namesv; 451 type = NULL; 452 } 453 fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,num_svs,svp); 454 } 455 if (!fp && type && *type && *type != ':' && !isIDFIRST(*type)) 456 goto unknown_open_mode; 457 } /* IoTYPE_RDONLY */ 458 else if ((num_svs && /* '-|...' or '...|' */ 459 type[0] == IoTYPE_STD && type[1] == IoTYPE_PIPE) || 460 (!num_svs && tend > type+1 && tend[-1] == IoTYPE_PIPE)) { 461 if (num_svs) { 462 type += 2; /* skip over '-|' */ 463 } 464 else { 465 *--tend = '\0'; 466 while (tend > type && isSPACE(tend[-1])) 467 *--tend = '\0'; 468 for (; isSPACE(*type); type++) 469 ; 470 name = type; 471 len = tend-type; 472 } 473 if (*name == '\0') { 474 /* command is missing 19990114 */ 475 if (ckWARN(WARN_PIPE)) 476 Perl_warner(aTHX_ packWARN(WARN_PIPE), "Missing command in piped open"); 477 errno = EPIPE; 478 goto say_false; 479 } 480 if (!(*name == '-' && name[1] == '\0') || num_svs) 481 TAINT_ENV(); 482 TAINT_PROPER("piped open"); 483 mode[0] = 'r'; 484 485 if (in_raw) 486 mode[1] = 'b'; 487 else if (in_crlf) 488 mode[1] = 't'; 489 490 if (num_svs > 1) { 491 fp = PerlProc_popen_list(mode,num_svs,svp); 492 } 493 else { 494 fp = PerlProc_popen(name,mode); 495 } 496 IoTYPE(io) = IoTYPE_PIPE; 497 if (num_svs) { 498 while (isSPACE(*type)) 499 type++; 500 if (*type) { 501 if (PerlIO_apply_layers(aTHX_ fp, mode, type) != 0) { 502 goto say_false; 503 } 504 } 505 } 506 } 507 else { /* layer(Args) */ 508 if (num_svs) 509 goto unknown_open_mode; 510 name = type; 511 IoTYPE(io) = IoTYPE_RDONLY; 512 for (; isSPACE(*name); name++) 513 ; 514 mode[0] = 'r'; 515 516 if (in_raw) 517 mode[1] = 'b'; 518 else if (in_crlf) 519 mode[1] = 't'; 520 521 if (*name == '-' && name[1] == '\0') { 522 fp = PerlIO_stdin(); 523 IoTYPE(io) = IoTYPE_STD; 524 } 525 else { 526 if (!num_svs) { 527 namesv = newSVpvn_flags(type, tend - type, SVs_TEMP); 528 num_svs = 1; 529 svp = &namesv; 530 type = NULL; 531 } 532 fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,num_svs,svp); 533 } 534 } 535 } 536 if (!fp) { 537 if (IoTYPE(io) == IoTYPE_RDONLY && ckWARN(WARN_NEWLINE) 538 && strchr(oname, '\n') 539 540 ) 541 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open"); 542 goto say_false; 543 } 544 545 if (ckWARN(WARN_IO)) { 546 if ((IoTYPE(io) == IoTYPE_RDONLY) && 547 (fp == PerlIO_stdout() || fp == PerlIO_stderr())) { 548 Perl_warner(aTHX_ packWARN(WARN_IO), 549 "Filehandle STD%s reopened as %"HEKf 550 " only for input", 551 ((fp == PerlIO_stdout()) ? "OUT" : "ERR"), 552 HEKfARG(GvENAME_HEK(gv))); 553 } 554 else if ((IoTYPE(io) == IoTYPE_WRONLY) && fp == PerlIO_stdin()) { 555 Perl_warner(aTHX_ packWARN(WARN_IO), 556 "Filehandle STDIN reopened as %"HEKf" only for output", 557 HEKfARG(GvENAME_HEK(gv)) 558 ); 559 } 560 } 561 562 fd = PerlIO_fileno(fp); 563 /* If there is no fd (e.g. PerlIO::scalar) assume it isn't a 564 * socket - this covers PerlIO::scalar - otherwise unless we "know" the 565 * type probe for socket-ness. 566 */ 567 if (IoTYPE(io) && IoTYPE(io) != IoTYPE_PIPE && IoTYPE(io) != IoTYPE_STD && fd >= 0) { 568 if (PerlLIO_fstat(fd,&PL_statbuf) < 0) { 569 /* If PerlIO claims to have fd we had better be able to fstat() it. */ 570 (void) PerlIO_close(fp); 571 goto say_false; 572 } 573 #ifndef PERL_MICRO 574 if (S_ISSOCK(PL_statbuf.st_mode)) 575 IoTYPE(io) = IoTYPE_SOCKET; /* in case a socket was passed in to us */ 576 #ifdef HAS_SOCKET 577 else if ( 578 #ifdef S_IFMT 579 !(PL_statbuf.st_mode & S_IFMT) 580 #else 581 !PL_statbuf.st_mode 582 #endif 583 && IoTYPE(io) != IoTYPE_WRONLY /* Dups of STD* filehandles already have */ 584 && IoTYPE(io) != IoTYPE_RDONLY /* type so they aren't marked as sockets */ 585 ) { /* on OS's that return 0 on fstat()ed pipe */ 586 char tmpbuf[256]; 587 Sock_size_t buflen = sizeof tmpbuf; 588 if (PerlSock_getsockname(fd, (struct sockaddr *)tmpbuf, &buflen) >= 0 589 || errno != ENOTSOCK) 590 IoTYPE(io) = IoTYPE_SOCKET; /* some OS's return 0 on fstat()ed socket */ 591 /* but some return 0 for streams too, sigh */ 592 } 593 #endif /* HAS_SOCKET */ 594 #endif /* !PERL_MICRO */ 595 } 596 597 /* Eeek - FIXME !!! 598 * If this is a standard handle we discard all the layer stuff 599 * and just dup the fd into whatever was on the handle before ! 600 */ 601 602 if (saveifp) { /* must use old fp? */ 603 /* If fd is less that PL_maxsysfd i.e. STDIN..STDERR 604 then dup the new fileno down 605 */ 606 if (saveofp) { 607 PerlIO_flush(saveofp); /* emulate PerlIO_close() */ 608 if (saveofp != saveifp) { /* was a socket? */ 609 PerlIO_close(saveofp); 610 } 611 } 612 if (savefd != fd) { 613 /* Still a small can-of-worms here if (say) PerlIO::scalar 614 is assigned to (say) STDOUT - for now let dup2() fail 615 and provide the error 616 */ 617 if (PerlLIO_dup2(fd, savefd) < 0) { 618 (void)PerlIO_close(fp); 619 goto say_false; 620 } 621 #ifdef VMS 622 if (savefd != PerlIO_fileno(PerlIO_stdin())) { 623 char newname[FILENAME_MAX+1]; 624 if (PerlIO_getname(fp, newname)) { 625 if (fd == PerlIO_fileno(PerlIO_stdout())) 626 vmssetuserlnm("SYS$OUTPUT", newname); 627 if (fd == PerlIO_fileno(PerlIO_stderr())) 628 vmssetuserlnm("SYS$ERROR", newname); 629 } 630 } 631 #endif 632 633 #if !defined(WIN32) 634 /* PL_fdpid isn't used on Windows, so avoid this useless work. 635 * XXX Probably the same for a lot of other places. */ 636 { 637 Pid_t pid; 638 SV *sv; 639 640 sv = *av_fetch(PL_fdpid,fd,TRUE); 641 SvUPGRADE(sv, SVt_IV); 642 pid = SvIVX(sv); 643 SvIV_set(sv, 0); 644 sv = *av_fetch(PL_fdpid,savefd,TRUE); 645 SvUPGRADE(sv, SVt_IV); 646 SvIV_set(sv, pid); 647 } 648 #endif 649 650 if (was_fdopen) { 651 /* need to close fp without closing underlying fd */ 652 int ofd = PerlIO_fileno(fp); 653 int dupfd = PerlLIO_dup(ofd); 654 #if defined(HAS_FCNTL) && defined(F_SETFD) 655 /* Assume if we have F_SETFD we have F_GETFD */ 656 int coe = fcntl(ofd,F_GETFD); 657 #endif 658 PerlIO_close(fp); 659 PerlLIO_dup2(dupfd,ofd); 660 #if defined(HAS_FCNTL) && defined(F_SETFD) 661 /* The dup trick has lost close-on-exec on ofd */ 662 fcntl(ofd,F_SETFD, coe); 663 #endif 664 PerlLIO_close(dupfd); 665 } 666 else 667 PerlIO_close(fp); 668 } 669 fp = saveifp; 670 PerlIO_clearerr(fp); 671 fd = PerlIO_fileno(fp); 672 } 673 #if defined(HAS_FCNTL) && defined(F_SETFD) 674 if (fd >= 0) { 675 dSAVE_ERRNO; 676 fcntl(fd,F_SETFD,fd > PL_maxsysfd); /* can change errno */ 677 RESTORE_ERRNO; 678 } 679 #endif 680 IoIFP(io) = fp; 681 682 IoFLAGS(io) &= ~IOf_NOLINE; 683 if (writing) { 684 if (IoTYPE(io) == IoTYPE_SOCKET 685 || (IoTYPE(io) == IoTYPE_WRONLY && fd >= 0 && S_ISCHR(PL_statbuf.st_mode)) ) { 686 char *s = mode; 687 if (*s == IoTYPE_IMPLICIT || *s == IoTYPE_NUMERIC) 688 s++; 689 *s = 'w'; 690 if (!(IoOFP(io) = PerlIO_openn(aTHX_ type,s,fd,0,0,NULL,0,svp))) { 691 PerlIO_close(fp); 692 IoIFP(io) = NULL; 693 goto say_false; 694 } 695 } 696 else 697 IoOFP(io) = fp; 698 } 699 return TRUE; 700 701 say_false: 702 IoIFP(io) = saveifp; 703 IoOFP(io) = saveofp; 704 IoTYPE(io) = savetype; 705 return FALSE; 706 } 707 708 PerlIO * 709 Perl_nextargv(pTHX_ GV *gv) 710 { 711 dVAR; 712 SV *sv; 713 #ifndef FLEXFILENAMES 714 int filedev; 715 int fileino; 716 #endif 717 Uid_t fileuid; 718 Gid_t filegid; 719 IO * const io = GvIOp(gv); 720 721 PERL_ARGS_ASSERT_NEXTARGV; 722 723 if (!PL_argvoutgv) 724 PL_argvoutgv = gv_fetchpvs("ARGVOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO); 725 if (io && (IoFLAGS(io) & IOf_ARGV) && (IoFLAGS(io) & IOf_START)) { 726 IoFLAGS(io) &= ~IOf_START; 727 if (PL_inplace) { 728 assert(PL_defoutgv); 729 Perl_av_create_and_push(aTHX_ &PL_argvout_stack, 730 SvREFCNT_inc_simple_NN(PL_defoutgv)); 731 } 732 } 733 if (PL_filemode & (S_ISUID|S_ISGID)) { 734 PerlIO_flush(IoIFP(GvIOn(PL_argvoutgv))); /* chmod must follow last write */ 735 #ifdef HAS_FCHMOD 736 if (PL_lastfd != -1) 737 (void)fchmod(PL_lastfd,PL_filemode); 738 #else 739 (void)PerlLIO_chmod(PL_oldname,PL_filemode); 740 #endif 741 } 742 PL_lastfd = -1; 743 PL_filemode = 0; 744 if (!GvAV(gv)) 745 return NULL; 746 while (av_len(GvAV(gv)) >= 0) { 747 STRLEN oldlen; 748 sv = av_shift(GvAV(gv)); 749 SAVEFREESV(sv); 750 SvTAINTED_off(GvSVn(gv)); /* previous tainting irrelevant */ 751 sv_setsv(GvSVn(gv),sv); 752 SvSETMAGIC(GvSV(gv)); 753 PL_oldname = SvPVx(GvSV(gv), oldlen); 754 if (do_open(gv,PL_oldname,oldlen,PL_inplace!=0,O_RDONLY,0,NULL)) { 755 if (PL_inplace) { 756 TAINT_PROPER("inplace open"); 757 if (oldlen == 1 && *PL_oldname == '-') { 758 setdefout(gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, 759 SVt_PVIO)); 760 return IoIFP(GvIOp(gv)); 761 } 762 #ifndef FLEXFILENAMES 763 filedev = PL_statbuf.st_dev; 764 fileino = PL_statbuf.st_ino; 765 #endif 766 PL_filemode = PL_statbuf.st_mode; 767 fileuid = PL_statbuf.st_uid; 768 filegid = PL_statbuf.st_gid; 769 if (!S_ISREG(PL_filemode)) { 770 Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE), 771 "Can't do inplace edit: %s is not a regular file", 772 PL_oldname ); 773 do_close(gv,FALSE); 774 continue; 775 } 776 if (*PL_inplace && strNE(PL_inplace, "*")) { 777 const char *star = strchr(PL_inplace, '*'); 778 if (star) { 779 const char *begin = PL_inplace; 780 sv_setpvs(sv, ""); 781 do { 782 sv_catpvn(sv, begin, star - begin); 783 sv_catpvn(sv, PL_oldname, oldlen); 784 begin = ++star; 785 } while ((star = strchr(begin, '*'))); 786 if (*begin) 787 sv_catpv(sv,begin); 788 } 789 else { 790 sv_catpv(sv,PL_inplace); 791 } 792 #ifndef FLEXFILENAMES 793 if ((PerlLIO_stat(SvPVX_const(sv),&PL_statbuf) >= 0 794 && PL_statbuf.st_dev == filedev 795 && PL_statbuf.st_ino == fileino) 796 #ifdef DJGPP 797 || ((_djstat_fail_bits & _STFAIL_TRUENAME)!=0) 798 #endif 799 ) 800 { 801 Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE), 802 "Can't do inplace edit: %"SVf" would not be unique", 803 SVfARG(sv)); 804 do_close(gv,FALSE); 805 continue; 806 } 807 #endif 808 #ifdef HAS_RENAME 809 #if !defined(DOSISH) && !defined(__CYGWIN__) 810 if (PerlLIO_rename(PL_oldname,SvPVX_const(sv)) < 0) { 811 Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE), 812 "Can't rename %s to %"SVf": %s, skipping file", 813 PL_oldname, SVfARG(sv), Strerror(errno)); 814 do_close(gv,FALSE); 815 continue; 816 } 817 #else 818 do_close(gv,FALSE); 819 (void)PerlLIO_unlink(SvPVX_const(sv)); 820 (void)PerlLIO_rename(PL_oldname,SvPVX_const(sv)); 821 do_open(gv,(char*)SvPVX_const(sv),SvCUR(sv),TRUE,O_RDONLY,0,NULL); 822 #endif /* DOSISH */ 823 #else 824 (void)UNLINK(SvPVX_const(sv)); 825 if (link(PL_oldname,SvPVX_const(sv)) < 0) { 826 Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE), 827 "Can't rename %s to %"SVf": %s, skipping file", 828 PL_oldname, SVfARG(sv), Strerror(errno) ); 829 do_close(gv,FALSE); 830 continue; 831 } 832 (void)UNLINK(PL_oldname); 833 #endif 834 } 835 else { 836 #if !defined(DOSISH) && !defined(AMIGAOS) 837 # ifndef VMS /* Don't delete; use automatic file versioning */ 838 if (UNLINK(PL_oldname) < 0) { 839 Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE), 840 "Can't remove %s: %s, skipping file", 841 PL_oldname, Strerror(errno) ); 842 do_close(gv,FALSE); 843 continue; 844 } 845 # endif 846 #else 847 Perl_croak(aTHX_ "Can't do inplace edit without backup"); 848 #endif 849 } 850 851 sv_setpvn(sv,PL_oldname,oldlen); 852 SETERRNO(0,0); /* in case sprintf set errno */ 853 if (!Perl_do_openn(aTHX_ PL_argvoutgv, (char*)SvPVX_const(sv), 854 SvCUR(sv), TRUE, 855 #ifdef VMS 856 O_WRONLY|O_CREAT|O_TRUNC,0, 857 #else 858 O_WRONLY|O_CREAT|OPEN_EXCL,0600, 859 #endif 860 NULL, NULL, 0)) { 861 Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE), "Can't do inplace edit on %s: %s", 862 PL_oldname, Strerror(errno) ); 863 do_close(gv,FALSE); 864 continue; 865 } 866 setdefout(PL_argvoutgv); 867 PL_lastfd = PerlIO_fileno(IoIFP(GvIOp(PL_argvoutgv))); 868 (void)PerlLIO_fstat(PL_lastfd,&PL_statbuf); 869 #ifdef HAS_FCHMOD 870 (void)fchmod(PL_lastfd,PL_filemode); 871 #else 872 (void)PerlLIO_chmod(PL_oldname,PL_filemode); 873 #endif 874 if (fileuid != PL_statbuf.st_uid || filegid != PL_statbuf.st_gid) { 875 #ifdef HAS_FCHOWN 876 (void)fchown(PL_lastfd,fileuid,filegid); 877 #else 878 #ifdef HAS_CHOWN 879 (void)PerlLIO_chown(PL_oldname,fileuid,filegid); 880 #endif 881 #endif 882 } 883 } 884 return IoIFP(GvIOp(gv)); 885 } 886 else { 887 if (ckWARN_d(WARN_INPLACE)) { 888 const int eno = errno; 889 if (PerlLIO_stat(PL_oldname, &PL_statbuf) >= 0 890 && !S_ISREG(PL_statbuf.st_mode)) 891 { 892 Perl_warner(aTHX_ packWARN(WARN_INPLACE), 893 "Can't do inplace edit: %s is not a regular file", 894 PL_oldname); 895 } 896 else 897 Perl_warner(aTHX_ packWARN(WARN_INPLACE), "Can't open %s: %s", 898 PL_oldname, Strerror(eno)); 899 } 900 } 901 } 902 if (io && (IoFLAGS(io) & IOf_ARGV)) 903 IoFLAGS(io) |= IOf_START; 904 if (PL_inplace) { 905 (void)do_close(PL_argvoutgv,FALSE); 906 if (io && (IoFLAGS(io) & IOf_ARGV) 907 && PL_argvout_stack && AvFILLp(PL_argvout_stack) >= 0) 908 { 909 GV * const oldout = MUTABLE_GV(av_pop(PL_argvout_stack)); 910 setdefout(oldout); 911 SvREFCNT_dec_NN(oldout); 912 return NULL; 913 } 914 setdefout(gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO)); 915 } 916 return NULL; 917 } 918 919 /* explicit renamed to avoid C++ conflict -- kja */ 920 bool 921 Perl_do_close(pTHX_ GV *gv, bool not_implicit) 922 { 923 dVAR; 924 bool retval; 925 IO *io; 926 927 if (!gv) 928 gv = PL_argvgv; 929 if (!gv || !isGV_with_GP(gv)) { 930 if (not_implicit) 931 SETERRNO(EBADF,SS_IVCHAN); 932 return FALSE; 933 } 934 io = GvIO(gv); 935 if (!io) { /* never opened */ 936 if (not_implicit) { 937 report_evil_fh(gv); 938 SETERRNO(EBADF,SS_IVCHAN); 939 } 940 return FALSE; 941 } 942 retval = io_close(io, not_implicit); 943 if (not_implicit) { 944 IoLINES(io) = 0; 945 IoPAGE(io) = 0; 946 IoLINES_LEFT(io) = IoPAGE_LEN(io); 947 } 948 IoTYPE(io) = IoTYPE_CLOSED; 949 return retval; 950 } 951 952 bool 953 Perl_io_close(pTHX_ IO *io, bool not_implicit) 954 { 955 dVAR; 956 bool retval = FALSE; 957 958 PERL_ARGS_ASSERT_IO_CLOSE; 959 960 if (IoIFP(io)) { 961 if (IoTYPE(io) == IoTYPE_PIPE) { 962 const int status = PerlProc_pclose(IoIFP(io)); 963 if (not_implicit) { 964 STATUS_NATIVE_CHILD_SET(status); 965 retval = (STATUS_UNIX == 0); 966 } 967 else { 968 retval = (status != -1); 969 } 970 } 971 else if (IoTYPE(io) == IoTYPE_STD) 972 retval = TRUE; 973 else { 974 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) { /* a socket */ 975 const bool prev_err = PerlIO_error(IoOFP(io)); 976 retval = (PerlIO_close(IoOFP(io)) != EOF && !prev_err); 977 PerlIO_close(IoIFP(io)); /* clear stdio, fd already closed */ 978 } 979 else { 980 const bool prev_err = PerlIO_error(IoIFP(io)); 981 retval = (PerlIO_close(IoIFP(io)) != EOF && !prev_err); 982 } 983 } 984 IoOFP(io) = IoIFP(io) = NULL; 985 } 986 else if (not_implicit) { 987 SETERRNO(EBADF,SS_IVCHAN); 988 } 989 990 return retval; 991 } 992 993 bool 994 Perl_do_eof(pTHX_ GV *gv) 995 { 996 dVAR; 997 IO * const io = GvIO(gv); 998 999 PERL_ARGS_ASSERT_DO_EOF; 1000 1001 if (!io) 1002 return TRUE; 1003 else if (IoTYPE(io) == IoTYPE_WRONLY) 1004 report_wrongway_fh(gv, '>'); 1005 1006 while (IoIFP(io)) { 1007 if (PerlIO_has_cntptr(IoIFP(io))) { /* (the code works without this) */ 1008 if (PerlIO_get_cnt(IoIFP(io)) > 0) /* cheat a little, since */ 1009 return FALSE; /* this is the most usual case */ 1010 } 1011 1012 { 1013 /* getc and ungetc can stomp on errno */ 1014 dSAVE_ERRNO; 1015 const int ch = PerlIO_getc(IoIFP(io)); 1016 if (ch != EOF) { 1017 (void)PerlIO_ungetc(IoIFP(io),ch); 1018 RESTORE_ERRNO; 1019 return FALSE; 1020 } 1021 RESTORE_ERRNO; 1022 } 1023 1024 if (PerlIO_has_cntptr(IoIFP(io)) && PerlIO_canset_cnt(IoIFP(io))) { 1025 if (PerlIO_get_cnt(IoIFP(io)) < -1) 1026 PerlIO_set_cnt(IoIFP(io),-1); 1027 } 1028 if (PL_op->op_flags & OPf_SPECIAL) { /* not necessarily a real EOF yet? */ 1029 if (gv != PL_argvgv || !nextargv(gv)) /* get another fp handy */ 1030 return TRUE; 1031 } 1032 else 1033 return TRUE; /* normal fp, definitely end of file */ 1034 } 1035 return TRUE; 1036 } 1037 1038 Off_t 1039 Perl_do_tell(pTHX_ GV *gv) 1040 { 1041 dVAR; 1042 IO *const io = GvIO(gv); 1043 PerlIO *fp; 1044 1045 PERL_ARGS_ASSERT_DO_TELL; 1046 1047 if (io && (fp = IoIFP(io))) { 1048 #ifdef ULTRIX_STDIO_BOTCH 1049 if (PerlIO_eof(fp)) 1050 (void)PerlIO_seek(fp, 0L, 2); /* ultrix 1.2 workaround */ 1051 #endif 1052 return PerlIO_tell(fp); 1053 } 1054 report_evil_fh(gv); 1055 SETERRNO(EBADF,RMS_IFI); 1056 return (Off_t)-1; 1057 } 1058 1059 bool 1060 Perl_do_seek(pTHX_ GV *gv, Off_t pos, int whence) 1061 { 1062 dVAR; 1063 IO *const io = GvIO(gv); 1064 PerlIO *fp; 1065 1066 if (io && (fp = IoIFP(io))) { 1067 #ifdef ULTRIX_STDIO_BOTCH 1068 if (PerlIO_eof(fp)) 1069 (void)PerlIO_seek(fp, 0L, 2); /* ultrix 1.2 workaround */ 1070 #endif 1071 return PerlIO_seek(fp, pos, whence) >= 0; 1072 } 1073 report_evil_fh(gv); 1074 SETERRNO(EBADF,RMS_IFI); 1075 return FALSE; 1076 } 1077 1078 Off_t 1079 Perl_do_sysseek(pTHX_ GV *gv, Off_t pos, int whence) 1080 { 1081 dVAR; 1082 IO *const io = GvIO(gv); 1083 PerlIO *fp; 1084 1085 PERL_ARGS_ASSERT_DO_SYSSEEK; 1086 1087 if (io && (fp = IoIFP(io))) 1088 return PerlLIO_lseek(PerlIO_fileno(fp), pos, whence); 1089 report_evil_fh(gv); 1090 SETERRNO(EBADF,RMS_IFI); 1091 return (Off_t)-1; 1092 } 1093 1094 int 1095 Perl_mode_from_discipline(pTHX_ const char *s, STRLEN len) 1096 { 1097 int mode = O_BINARY; 1098 if (s) { 1099 while (*s) { 1100 if (*s == ':') { 1101 switch (s[1]) { 1102 case 'r': 1103 if (s[2] == 'a' && s[3] == 'w' 1104 && (!s[4] || s[4] == ':' || isSPACE(s[4]))) 1105 { 1106 mode = O_BINARY; 1107 s += 4; 1108 len -= 4; 1109 break; 1110 } 1111 /* FALL THROUGH */ 1112 case 'c': 1113 if (s[2] == 'r' && s[3] == 'l' && s[4] == 'f' 1114 && (!s[5] || s[5] == ':' || isSPACE(s[5]))) 1115 { 1116 mode = O_TEXT; 1117 s += 5; 1118 len -= 5; 1119 break; 1120 } 1121 /* FALL THROUGH */ 1122 default: 1123 goto fail_discipline; 1124 } 1125 } 1126 else if (isSPACE(*s)) { 1127 ++s; 1128 --len; 1129 } 1130 else { 1131 const char *end; 1132 fail_discipline: 1133 end = strchr(s+1, ':'); 1134 if (!end) 1135 end = s+len; 1136 #ifndef PERLIO_LAYERS 1137 Perl_croak(aTHX_ "IO layers (like '%.*s') unavailable", end-s, s); 1138 #else 1139 len -= end-s; 1140 s = end; 1141 #endif 1142 } 1143 } 1144 } 1145 return mode; 1146 } 1147 1148 #if !defined(HAS_TRUNCATE) && !defined(HAS_CHSIZE) 1149 I32 1150 my_chsize(int fd, Off_t length) 1151 { 1152 #ifdef F_FREESP 1153 /* code courtesy of William Kucharski */ 1154 #define HAS_CHSIZE 1155 1156 Stat_t filebuf; 1157 1158 if (PerlLIO_fstat(fd, &filebuf) < 0) 1159 return -1; 1160 1161 if (filebuf.st_size < length) { 1162 1163 /* extend file length */ 1164 1165 if ((PerlLIO_lseek(fd, (length - 1), 0)) < 0) 1166 return -1; 1167 1168 /* write a "0" byte */ 1169 1170 if ((PerlLIO_write(fd, "", 1)) != 1) 1171 return -1; 1172 } 1173 else { 1174 /* truncate length */ 1175 struct flock fl; 1176 fl.l_whence = 0; 1177 fl.l_len = 0; 1178 fl.l_start = length; 1179 fl.l_type = F_WRLCK; /* write lock on file space */ 1180 1181 /* 1182 * This relies on the UNDOCUMENTED F_FREESP argument to 1183 * fcntl(2), which truncates the file so that it ends at the 1184 * position indicated by fl.l_start. 1185 * 1186 * Will minor miracles never cease? 1187 */ 1188 1189 if (fcntl(fd, F_FREESP, &fl) < 0) 1190 return -1; 1191 1192 } 1193 return 0; 1194 #else 1195 Perl_croak_nocontext("truncate not implemented"); 1196 #endif /* F_FREESP */ 1197 return -1; 1198 } 1199 #endif /* !HAS_TRUNCATE && !HAS_CHSIZE */ 1200 1201 bool 1202 Perl_do_print(pTHX_ SV *sv, PerlIO *fp) 1203 { 1204 dVAR; 1205 1206 PERL_ARGS_ASSERT_DO_PRINT; 1207 1208 /* assuming fp is checked earlier */ 1209 if (!sv) 1210 return TRUE; 1211 if (SvTYPE(sv) == SVt_IV && SvIOK(sv)) { 1212 assert(!SvGMAGICAL(sv)); 1213 if (SvIsUV(sv)) 1214 PerlIO_printf(fp, "%"UVuf, (UV)SvUVX(sv)); 1215 else 1216 PerlIO_printf(fp, "%"IVdf, (IV)SvIVX(sv)); 1217 return !PerlIO_error(fp); 1218 } 1219 else { 1220 STRLEN len; 1221 /* Do this first to trigger any overloading. */ 1222 const char *tmps = SvPV_const(sv, len); 1223 U8 *tmpbuf = NULL; 1224 bool happy = TRUE; 1225 1226 if (PerlIO_isutf8(fp)) { /* If the stream is utf8 ... */ 1227 if (!SvUTF8(sv)) { /* Convert to utf8 if necessary */ 1228 /* We don't modify the original scalar. */ 1229 tmpbuf = bytes_to_utf8((const U8*) tmps, &len); 1230 tmps = (char *) tmpbuf; 1231 } 1232 else if (ckWARN4_d(WARN_UTF8, WARN_SURROGATE, WARN_NON_UNICODE, WARN_NONCHAR)) { 1233 (void) check_utf8_print((const U8*) tmps, len); 1234 } 1235 } /* else stream isn't utf8 */ 1236 else if (DO_UTF8(sv)) { /* But if is utf8 internally, attempt to 1237 convert to bytes */ 1238 STRLEN tmplen = len; 1239 bool utf8 = TRUE; 1240 U8 * const result = bytes_from_utf8((const U8*) tmps, &tmplen, &utf8); 1241 if (!utf8) { 1242 1243 /* Here, succeeded in downgrading from utf8. Set up to below 1244 * output the converted value */ 1245 tmpbuf = result; 1246 tmps = (char *) tmpbuf; 1247 len = tmplen; 1248 } 1249 else { /* Non-utf8 output stream, but string only representable in 1250 utf8 */ 1251 assert((char *)result == tmps); 1252 Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), 1253 "Wide character in %s", 1254 PL_op ? OP_DESC(PL_op) : "print" 1255 ); 1256 /* Could also check that isn't one of the things to avoid 1257 * in utf8 by using check_utf8_print(), but not doing so, 1258 * since the stream isn't a UTF8 stream */ 1259 } 1260 } 1261 /* To detect whether the process is about to overstep its 1262 * filesize limit we would need getrlimit(). We could then 1263 * also transparently raise the limit with setrlimit() -- 1264 * but only until the system hard limit/the filesystem limit, 1265 * at which we would get EPERM. Note that when using buffered 1266 * io the write failure can be delayed until the flush/close. --jhi */ 1267 if (len && (PerlIO_write(fp,tmps,len) == 0)) 1268 happy = FALSE; 1269 Safefree(tmpbuf); 1270 return happy ? !PerlIO_error(fp) : FALSE; 1271 } 1272 } 1273 1274 I32 1275 Perl_my_stat_flags(pTHX_ const U32 flags) 1276 { 1277 dVAR; 1278 dSP; 1279 IO *io; 1280 GV* gv; 1281 1282 if (PL_op->op_flags & OPf_REF) { 1283 gv = cGVOP_gv; 1284 do_fstat: 1285 if (gv == PL_defgv) 1286 return PL_laststatval; 1287 io = GvIO(gv); 1288 do_fstat_have_io: 1289 PL_laststype = OP_STAT; 1290 PL_statgv = gv ? gv : (GV *)io; 1291 sv_setpvs(PL_statname, ""); 1292 if(io) { 1293 if (IoIFP(io)) { 1294 return (PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache)); 1295 } else if (IoDIRP(io)) { 1296 return (PL_laststatval = PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache)); 1297 } 1298 } 1299 PL_laststatval = -1; 1300 report_evil_fh(gv); 1301 return -1; 1302 } 1303 else if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t)) 1304 == OPpFT_STACKED) 1305 return PL_laststatval; 1306 else { 1307 SV* const sv = TOPs; 1308 const char *s; 1309 STRLEN len; 1310 if ((gv = MAYBE_DEREF_GV_flags(sv,flags))) { 1311 goto do_fstat; 1312 } 1313 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) { 1314 io = MUTABLE_IO(SvRV(sv)); 1315 gv = NULL; 1316 goto do_fstat_have_io; 1317 } 1318 1319 s = SvPV_flags_const(sv, len, flags); 1320 PL_statgv = NULL; 1321 sv_setpvn(PL_statname, s, len); 1322 s = SvPVX_const(PL_statname); /* s now NUL-terminated */ 1323 PL_laststype = OP_STAT; 1324 PL_laststatval = PerlLIO_stat(s, &PL_statcache); 1325 if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && strchr(s, '\n')) 1326 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat"); 1327 return PL_laststatval; 1328 } 1329 } 1330 1331 1332 I32 1333 Perl_my_lstat_flags(pTHX_ const U32 flags) 1334 { 1335 dVAR; 1336 static const char* const no_prev_lstat = "The stat preceding -l _ wasn't an lstat"; 1337 dSP; 1338 const char *file; 1339 SV* const sv = TOPs; 1340 if (PL_op->op_flags & OPf_REF) { 1341 if (cGVOP_gv == PL_defgv) { 1342 if (PL_laststype != OP_LSTAT) 1343 Perl_croak(aTHX_ "%s", no_prev_lstat); 1344 return PL_laststatval; 1345 } 1346 PL_laststatval = -1; 1347 if (ckWARN(WARN_IO)) { 1348 Perl_warner(aTHX_ packWARN(WARN_IO), 1349 "Use of -l on filehandle %"HEKf, 1350 HEKfARG(GvENAME_HEK(cGVOP_gv))); 1351 } 1352 return -1; 1353 } 1354 if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t)) 1355 == OPpFT_STACKED) { 1356 if (PL_laststype != OP_LSTAT) 1357 Perl_croak(aTHX_ "%s", no_prev_lstat); 1358 return PL_laststatval; 1359 } 1360 1361 PL_laststype = OP_LSTAT; 1362 PL_statgv = NULL; 1363 if (SvROK(sv) && isGV_with_GP(SvRV(sv)) && ckWARN(WARN_IO)) { 1364 Perl_warner(aTHX_ packWARN(WARN_IO), "Use of -l on filehandle %s", 1365 GvENAME((const GV *)SvRV(sv))); 1366 } 1367 file = SvPV_flags_const_nolen(sv, flags); 1368 sv_setpv(PL_statname,file); 1369 PL_laststatval = PerlLIO_lstat(file,&PL_statcache); 1370 if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && strchr(file, '\n')) 1371 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "lstat"); 1372 return PL_laststatval; 1373 } 1374 1375 static void 1376 S_exec_failed(pTHX_ const char *cmd, int fd, int do_report) 1377 { 1378 const int e = errno; 1379 PERL_ARGS_ASSERT_EXEC_FAILED; 1380 if (ckWARN(WARN_EXEC)) 1381 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't exec \"%s\": %s", 1382 cmd, Strerror(e)); 1383 if (do_report) { 1384 PerlLIO_write(fd, (void*)&e, sizeof(int)); 1385 PerlLIO_close(fd); 1386 } 1387 } 1388 1389 bool 1390 Perl_do_aexec5(pTHX_ SV *really, SV **mark, SV **sp, 1391 int fd, int do_report) 1392 { 1393 dVAR; 1394 PERL_ARGS_ASSERT_DO_AEXEC5; 1395 #if defined(__SYMBIAN32__) || defined(__LIBCATAMOUNT__) 1396 Perl_croak(aTHX_ "exec? I'm not *that* kind of operating system"); 1397 #else 1398 if (sp > mark) { 1399 const char **a; 1400 const char *tmps = NULL; 1401 Newx(PL_Argv, sp - mark + 1, const char*); 1402 a = PL_Argv; 1403 1404 while (++mark <= sp) { 1405 if (*mark) 1406 *a++ = SvPV_nolen_const(*mark); 1407 else 1408 *a++ = ""; 1409 } 1410 *a = NULL; 1411 if (really) 1412 tmps = SvPV_nolen_const(really); 1413 if ((!really && *PL_Argv[0] != '/') || 1414 (really && *tmps != '/')) /* will execvp use PATH? */ 1415 TAINT_ENV(); /* testing IFS here is overkill, probably */ 1416 PERL_FPU_PRE_EXEC 1417 if (really && *tmps) 1418 PerlProc_execvp(tmps,EXEC_ARGV_CAST(PL_Argv)); 1419 else 1420 PerlProc_execvp(PL_Argv[0],EXEC_ARGV_CAST(PL_Argv)); 1421 PERL_FPU_POST_EXEC 1422 S_exec_failed(aTHX_ (really ? tmps : PL_Argv[0]), fd, do_report); 1423 } 1424 do_execfree(); 1425 #endif 1426 return FALSE; 1427 } 1428 1429 void 1430 Perl_do_execfree(pTHX) 1431 { 1432 dVAR; 1433 Safefree(PL_Argv); 1434 PL_Argv = NULL; 1435 Safefree(PL_Cmd); 1436 PL_Cmd = NULL; 1437 } 1438 1439 #ifdef PERL_DEFAULT_DO_EXEC3_IMPLEMENTATION 1440 1441 bool 1442 Perl_do_exec3(pTHX_ const char *incmd, int fd, int do_report) 1443 { 1444 dVAR; 1445 const char **a; 1446 char *s; 1447 char *buf; 1448 char *cmd; 1449 /* Make a copy so we can change it */ 1450 const Size_t cmdlen = strlen(incmd) + 1; 1451 1452 PERL_ARGS_ASSERT_DO_EXEC3; 1453 1454 Newx(buf, cmdlen, char); 1455 cmd = buf; 1456 memcpy(cmd, incmd, cmdlen); 1457 1458 while (*cmd && isSPACE(*cmd)) 1459 cmd++; 1460 1461 /* save an extra exec if possible */ 1462 1463 #ifdef CSH 1464 { 1465 char flags[PERL_FLAGS_MAX]; 1466 if (strnEQ(cmd,PL_cshname,PL_cshlen) && 1467 strnEQ(cmd+PL_cshlen," -c",3)) { 1468 my_strlcpy(flags, "-c", PERL_FLAGS_MAX); 1469 s = cmd+PL_cshlen+3; 1470 if (*s == 'f') { 1471 s++; 1472 my_strlcat(flags, "f", PERL_FLAGS_MAX - 2); 1473 } 1474 if (*s == ' ') 1475 s++; 1476 if (*s++ == '\'') { 1477 char * const ncmd = s; 1478 1479 while (*s) 1480 s++; 1481 if (s[-1] == '\n') 1482 *--s = '\0'; 1483 if (s[-1] == '\'') { 1484 *--s = '\0'; 1485 PERL_FPU_PRE_EXEC 1486 PerlProc_execl(PL_cshname, "csh", flags, ncmd, (char*)NULL); 1487 PERL_FPU_POST_EXEC 1488 *s = '\''; 1489 S_exec_failed(aTHX_ PL_cshname, fd, do_report); 1490 Safefree(buf); 1491 return FALSE; 1492 } 1493 } 1494 } 1495 } 1496 #endif /* CSH */ 1497 1498 /* see if there are shell metacharacters in it */ 1499 1500 if (*cmd == '.' && isSPACE(cmd[1])) 1501 goto doshell; 1502 1503 if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4])) 1504 goto doshell; 1505 1506 s = cmd; 1507 while (isWORDCHAR(*s)) 1508 s++; /* catch VAR=val gizmo */ 1509 if (*s == '=') 1510 goto doshell; 1511 1512 for (s = cmd; *s; s++) { 1513 if (*s != ' ' && !isALPHA(*s) && 1514 strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) { 1515 if (*s == '\n' && !s[1]) { 1516 *s = '\0'; 1517 break; 1518 } 1519 /* handle the 2>&1 construct at the end */ 1520 if (*s == '>' && s[1] == '&' && s[2] == '1' 1521 && s > cmd + 1 && s[-1] == '2' && isSPACE(s[-2]) 1522 && (!s[3] || isSPACE(s[3]))) 1523 { 1524 const char *t = s + 3; 1525 1526 while (*t && isSPACE(*t)) 1527 ++t; 1528 if (!*t && (PerlLIO_dup2(1,2) != -1)) { 1529 s[-2] = '\0'; 1530 break; 1531 } 1532 } 1533 doshell: 1534 PERL_FPU_PRE_EXEC 1535 PerlProc_execl(PL_sh_path, "sh", "-c", cmd, (char *)NULL); 1536 PERL_FPU_POST_EXEC 1537 S_exec_failed(aTHX_ PL_sh_path, fd, do_report); 1538 Safefree(buf); 1539 return FALSE; 1540 } 1541 } 1542 1543 Newx(PL_Argv, (s - cmd) / 2 + 2, const char*); 1544 PL_Cmd = savepvn(cmd, s-cmd); 1545 a = PL_Argv; 1546 for (s = PL_Cmd; *s;) { 1547 while (isSPACE(*s)) 1548 s++; 1549 if (*s) 1550 *(a++) = s; 1551 while (*s && !isSPACE(*s)) 1552 s++; 1553 if (*s) 1554 *s++ = '\0'; 1555 } 1556 *a = NULL; 1557 if (PL_Argv[0]) { 1558 PERL_FPU_PRE_EXEC 1559 PerlProc_execvp(PL_Argv[0],EXEC_ARGV_CAST(PL_Argv)); 1560 PERL_FPU_POST_EXEC 1561 if (errno == ENOEXEC) { /* for system V NIH syndrome */ 1562 do_execfree(); 1563 goto doshell; 1564 } 1565 S_exec_failed(aTHX_ PL_Argv[0], fd, do_report); 1566 } 1567 do_execfree(); 1568 Safefree(buf); 1569 return FALSE; 1570 } 1571 1572 #endif /* OS2 || WIN32 */ 1573 1574 #ifdef VMS 1575 #include <starlet.h> /* for sys$delprc */ 1576 #endif 1577 1578 I32 1579 Perl_apply(pTHX_ I32 type, SV **mark, SV **sp) 1580 { 1581 dVAR; 1582 I32 val; 1583 I32 tot = 0; 1584 const char *const what = PL_op_name[type]; 1585 const char *s; 1586 STRLEN len; 1587 SV ** const oldmark = mark; 1588 bool killgp = FALSE; 1589 1590 PERL_ARGS_ASSERT_APPLY; 1591 1592 PERL_UNUSED_VAR(what); /* may not be used depending on compile options */ 1593 1594 /* Doing this ahead of the switch statement preserves the old behaviour, 1595 where attempting to use kill as a taint test test would fail on 1596 platforms where kill was not defined. */ 1597 #ifndef HAS_KILL 1598 if (type == OP_KILL) 1599 Perl_die(aTHX_ PL_no_func, what); 1600 #endif 1601 #ifndef HAS_CHOWN 1602 if (type == OP_CHOWN) 1603 Perl_die(aTHX_ PL_no_func, what); 1604 #endif 1605 1606 1607 #define APPLY_TAINT_PROPER() \ 1608 STMT_START { \ 1609 if (TAINT_get) { TAINT_PROPER(what); } \ 1610 } STMT_END 1611 1612 /* This is a first heuristic; it doesn't catch tainting magic. */ 1613 if (TAINTING_get) { 1614 while (++mark <= sp) { 1615 if (SvTAINTED(*mark)) { 1616 TAINT; 1617 break; 1618 } 1619 } 1620 mark = oldmark; 1621 } 1622 switch (type) { 1623 case OP_CHMOD: 1624 APPLY_TAINT_PROPER(); 1625 if (++mark <= sp) { 1626 val = SvIV(*mark); 1627 APPLY_TAINT_PROPER(); 1628 tot = sp - mark; 1629 while (++mark <= sp) { 1630 GV* gv; 1631 if ((gv = MAYBE_DEREF_GV(*mark))) { 1632 if (GvIO(gv) && IoIFP(GvIOp(gv))) { 1633 #ifdef HAS_FCHMOD 1634 APPLY_TAINT_PROPER(); 1635 if (fchmod(PerlIO_fileno(IoIFP(GvIOn(gv))), val)) 1636 tot--; 1637 #else 1638 Perl_die(aTHX_ PL_no_func, "fchmod"); 1639 #endif 1640 } 1641 else { 1642 tot--; 1643 } 1644 } 1645 else { 1646 const char *name = SvPV_nomg_const_nolen(*mark); 1647 APPLY_TAINT_PROPER(); 1648 if (PerlLIO_chmod(name, val)) 1649 tot--; 1650 } 1651 } 1652 } 1653 break; 1654 #ifdef HAS_CHOWN 1655 case OP_CHOWN: 1656 APPLY_TAINT_PROPER(); 1657 if (sp - mark > 2) { 1658 I32 val2; 1659 val = SvIVx(*++mark); 1660 val2 = SvIVx(*++mark); 1661 APPLY_TAINT_PROPER(); 1662 tot = sp - mark; 1663 while (++mark <= sp) { 1664 GV* gv; 1665 if ((gv = MAYBE_DEREF_GV(*mark))) { 1666 if (GvIO(gv) && IoIFP(GvIOp(gv))) { 1667 #ifdef HAS_FCHOWN 1668 APPLY_TAINT_PROPER(); 1669 if (fchown(PerlIO_fileno(IoIFP(GvIOn(gv))), val, val2)) 1670 tot--; 1671 #else 1672 Perl_die(aTHX_ PL_no_func, "fchown"); 1673 #endif 1674 } 1675 else { 1676 tot--; 1677 } 1678 } 1679 else { 1680 const char *name = SvPV_nomg_const_nolen(*mark); 1681 APPLY_TAINT_PROPER(); 1682 if (PerlLIO_chown(name, val, val2)) 1683 tot--; 1684 } 1685 } 1686 } 1687 break; 1688 #endif 1689 /* 1690 XXX Should we make lchown() directly available from perl? 1691 For now, we'll let Configure test for HAS_LCHOWN, but do 1692 nothing in the core. 1693 --AD 5/1998 1694 */ 1695 #ifdef HAS_KILL 1696 case OP_KILL: 1697 APPLY_TAINT_PROPER(); 1698 if (mark == sp) 1699 break; 1700 s = SvPVx_const(*++mark, len); 1701 if (*s == '-' && isALPHA(s[1])) 1702 { 1703 s++; 1704 len--; 1705 killgp = TRUE; 1706 } 1707 if (isALPHA(*s)) { 1708 if (*s == 'S' && s[1] == 'I' && s[2] == 'G') { 1709 s += 3; 1710 len -= 3; 1711 } 1712 if ((val = whichsig_pvn(s, len)) < 0) 1713 Perl_croak(aTHX_ "Unrecognized signal name \"%"SVf"\"", SVfARG(*mark)); 1714 } 1715 else 1716 { 1717 val = SvIV(*mark); 1718 if (val < 0) 1719 { 1720 killgp = TRUE; 1721 val = -val; 1722 } 1723 } 1724 APPLY_TAINT_PROPER(); 1725 tot = sp - mark; 1726 #ifdef VMS 1727 /* kill() doesn't do process groups (job trees?) under VMS */ 1728 if (val == SIGKILL) { 1729 /* Use native sys$delprc() to insure that target process is 1730 * deleted; supervisor-mode images don't pay attention to 1731 * CRTL's emulation of Unix-style signals and kill() 1732 */ 1733 while (++mark <= sp) { 1734 I32 proc; 1735 unsigned long int __vmssts; 1736 SvGETMAGIC(*mark); 1737 if (!(SvIOK(*mark) || SvNOK(*mark) || looks_like_number(*mark))) 1738 Perl_croak(aTHX_ "Can't kill a non-numeric process ID"); 1739 proc = SvIV_nomg(*mark); 1740 APPLY_TAINT_PROPER(); 1741 if (!((__vmssts = sys$delprc(&proc,0)) & 1)) { 1742 tot--; 1743 switch (__vmssts) { 1744 case SS$_NONEXPR: 1745 case SS$_NOSUCHNODE: 1746 SETERRNO(ESRCH,__vmssts); 1747 break; 1748 case SS$_NOPRIV: 1749 SETERRNO(EPERM,__vmssts); 1750 break; 1751 default: 1752 SETERRNO(EVMSERR,__vmssts); 1753 } 1754 } 1755 } 1756 PERL_ASYNC_CHECK(); 1757 break; 1758 } 1759 #endif 1760 while (++mark <= sp) { 1761 Pid_t proc; 1762 SvGETMAGIC(*mark); 1763 if (!(SvNIOK(*mark) || looks_like_number(*mark))) 1764 Perl_croak(aTHX_ "Can't kill a non-numeric process ID"); 1765 proc = SvIV_nomg(*mark); 1766 if (killgp) 1767 { 1768 proc = -proc; 1769 } 1770 APPLY_TAINT_PROPER(); 1771 if (PerlProc_kill(proc, val)) 1772 tot--; 1773 } 1774 PERL_ASYNC_CHECK(); 1775 break; 1776 #endif 1777 case OP_UNLINK: 1778 APPLY_TAINT_PROPER(); 1779 tot = sp - mark; 1780 while (++mark <= sp) { 1781 s = SvPV_nolen_const(*mark); 1782 APPLY_TAINT_PROPER(); 1783 if (PerlProc_geteuid() || PL_unsafe) { 1784 if (UNLINK(s)) 1785 tot--; 1786 } 1787 else { /* don't let root wipe out directories without -U */ 1788 if (PerlLIO_lstat(s,&PL_statbuf) < 0 || S_ISDIR(PL_statbuf.st_mode)) 1789 tot--; 1790 else { 1791 if (UNLINK(s)) 1792 tot--; 1793 } 1794 } 1795 } 1796 break; 1797 #if defined(HAS_UTIME) || defined(HAS_FUTIMES) 1798 case OP_UTIME: 1799 APPLY_TAINT_PROPER(); 1800 if (sp - mark > 2) { 1801 #if defined(HAS_FUTIMES) 1802 struct timeval utbuf[2]; 1803 void *utbufp = utbuf; 1804 #elif defined(I_UTIME) || defined(VMS) 1805 struct utimbuf utbuf; 1806 struct utimbuf *utbufp = &utbuf; 1807 #else 1808 struct { 1809 Time_t actime; 1810 Time_t modtime; 1811 } utbuf; 1812 void *utbufp = &utbuf; 1813 #endif 1814 1815 SV* const accessed = *++mark; 1816 SV* const modified = *++mark; 1817 1818 /* Be like C, and if both times are undefined, let the C 1819 * library figure out what to do. This usually means 1820 * "current time". */ 1821 1822 if ( accessed == &PL_sv_undef && modified == &PL_sv_undef ) 1823 utbufp = NULL; 1824 else { 1825 Zero(&utbuf, sizeof utbuf, char); 1826 #ifdef HAS_FUTIMES 1827 utbuf[0].tv_sec = (long)SvIV(accessed); /* time accessed */ 1828 utbuf[0].tv_usec = 0; 1829 utbuf[1].tv_sec = (long)SvIV(modified); /* time modified */ 1830 utbuf[1].tv_usec = 0; 1831 #elif defined(BIG_TIME) 1832 utbuf.actime = (Time_t)SvNV(accessed); /* time accessed */ 1833 utbuf.modtime = (Time_t)SvNV(modified); /* time modified */ 1834 #else 1835 utbuf.actime = (Time_t)SvIV(accessed); /* time accessed */ 1836 utbuf.modtime = (Time_t)SvIV(modified); /* time modified */ 1837 #endif 1838 } 1839 APPLY_TAINT_PROPER(); 1840 tot = sp - mark; 1841 while (++mark <= sp) { 1842 GV* gv; 1843 if ((gv = MAYBE_DEREF_GV(*mark))) { 1844 if (GvIO(gv) && IoIFP(GvIOp(gv))) { 1845 #ifdef HAS_FUTIMES 1846 APPLY_TAINT_PROPER(); 1847 if (futimes(PerlIO_fileno(IoIFP(GvIOn(gv))), 1848 (struct timeval *) utbufp)) 1849 tot--; 1850 #else 1851 Perl_die(aTHX_ PL_no_func, "futimes"); 1852 #endif 1853 } 1854 else { 1855 tot--; 1856 } 1857 } 1858 else { 1859 const char * const name = SvPV_nomg_const_nolen(*mark); 1860 APPLY_TAINT_PROPER(); 1861 #ifdef HAS_FUTIMES 1862 if (utimes(name, (struct timeval *)utbufp)) 1863 #else 1864 if (PerlLIO_utime(name, utbufp)) 1865 #endif 1866 tot--; 1867 } 1868 1869 } 1870 } 1871 else 1872 tot = 0; 1873 break; 1874 #endif 1875 } 1876 return tot; 1877 1878 #undef APPLY_TAINT_PROPER 1879 } 1880 1881 /* Do the permissions allow some operation? Assumes statcache already set. */ 1882 #ifndef VMS /* VMS' cando is in vms.c */ 1883 bool 1884 Perl_cando(pTHX_ Mode_t mode, bool effective, const Stat_t *statbufp) 1885 /* effective is a flag, true for EUID, or for checking if the effective gid 1886 * is in the list of groups returned from getgroups(). 1887 */ 1888 { 1889 dVAR; 1890 1891 PERL_ARGS_ASSERT_CANDO; 1892 1893 #ifdef DOSISH 1894 /* [Comments and code from Len Reed] 1895 * MS-DOS "user" is similar to UNIX's "superuser," but can't write 1896 * to write-protected files. The execute permission bit is set 1897 * by the Microsoft C library stat() function for the following: 1898 * .exe files 1899 * .com files 1900 * .bat files 1901 * directories 1902 * All files and directories are readable. 1903 * Directories and special files, e.g. "CON", cannot be 1904 * write-protected. 1905 * [Comment by Tom Dinger -- a directory can have the write-protect 1906 * bit set in the file system, but DOS permits changes to 1907 * the directory anyway. In addition, all bets are off 1908 * here for networked software, such as Novell and 1909 * Sun's PC-NFS.] 1910 */ 1911 1912 /* Atari stat() does pretty much the same thing. we set x_bit_set_in_stat 1913 * too so it will actually look into the files for magic numbers 1914 */ 1915 return (mode & statbufp->st_mode) ? TRUE : FALSE; 1916 1917 #else /* ! DOSISH */ 1918 # ifdef __CYGWIN__ 1919 if (ingroup(544,effective)) { /* member of Administrators */ 1920 # else 1921 if ((effective ? PerlProc_geteuid() : PerlProc_getuid()) == 0) { /* root is special */ 1922 # endif 1923 if (mode == S_IXUSR) { 1924 if (statbufp->st_mode & 0111 || S_ISDIR(statbufp->st_mode)) 1925 return TRUE; 1926 } 1927 else 1928 return TRUE; /* root reads and writes anything */ 1929 return FALSE; 1930 } 1931 if (statbufp->st_uid == (effective ? PerlProc_geteuid() : PerlProc_getuid()) ) { 1932 if (statbufp->st_mode & mode) 1933 return TRUE; /* ok as "user" */ 1934 } 1935 else if (ingroup(statbufp->st_gid,effective)) { 1936 if (statbufp->st_mode & mode >> 3) 1937 return TRUE; /* ok as "group" */ 1938 } 1939 else if (statbufp->st_mode & mode >> 6) 1940 return TRUE; /* ok as "other" */ 1941 return FALSE; 1942 #endif /* ! DOSISH */ 1943 } 1944 #endif /* ! VMS */ 1945 1946 static bool 1947 S_ingroup(pTHX_ Gid_t testgid, bool effective) 1948 { 1949 dVAR; 1950 if (testgid == (effective ? PerlProc_getegid() : PerlProc_getgid())) 1951 return TRUE; 1952 #ifdef HAS_GETGROUPS 1953 { 1954 Groups_t *gary = NULL; 1955 I32 anum; 1956 bool rc = FALSE; 1957 1958 anum = getgroups(0, gary); 1959 Newx(gary, anum, Groups_t); 1960 anum = getgroups(anum, gary); 1961 while (--anum >= 0) 1962 if (gary[anum] == testgid) { 1963 rc = TRUE; 1964 break; 1965 } 1966 1967 Safefree(gary); 1968 return rc; 1969 } 1970 #else 1971 return FALSE; 1972 #endif 1973 } 1974 1975 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) 1976 1977 I32 1978 Perl_do_ipcget(pTHX_ I32 optype, SV **mark, SV **sp) 1979 { 1980 dVAR; 1981 const key_t key = (key_t)SvNVx(*++mark); 1982 SV *nsv = optype == OP_MSGGET ? NULL : *++mark; 1983 const I32 flags = SvIVx(*++mark); 1984 1985 PERL_ARGS_ASSERT_DO_IPCGET; 1986 PERL_UNUSED_ARG(sp); 1987 1988 SETERRNO(0,0); 1989 switch (optype) 1990 { 1991 #ifdef HAS_MSG 1992 case OP_MSGGET: 1993 return msgget(key, flags); 1994 #endif 1995 #ifdef HAS_SEM 1996 case OP_SEMGET: 1997 return semget(key, (int) SvIV(nsv), flags); 1998 #endif 1999 #ifdef HAS_SHM 2000 case OP_SHMGET: 2001 return shmget(key, (size_t) SvUV(nsv), flags); 2002 #endif 2003 #if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM) 2004 default: 2005 /* diag_listed_as: msg%s not implemented */ 2006 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]); 2007 #endif 2008 } 2009 return -1; /* should never happen */ 2010 } 2011 2012 I32 2013 Perl_do_ipcctl(pTHX_ I32 optype, SV **mark, SV **sp) 2014 { 2015 dVAR; 2016 char *a; 2017 I32 ret = -1; 2018 const I32 id = SvIVx(*++mark); 2019 #ifdef Semctl 2020 const I32 n = (optype == OP_SEMCTL) ? SvIVx(*++mark) : 0; 2021 #endif 2022 const I32 cmd = SvIVx(*++mark); 2023 SV * const astr = *++mark; 2024 STRLEN infosize = 0; 2025 I32 getinfo = (cmd == IPC_STAT); 2026 2027 PERL_ARGS_ASSERT_DO_IPCCTL; 2028 PERL_UNUSED_ARG(sp); 2029 2030 switch (optype) 2031 { 2032 #ifdef HAS_MSG 2033 case OP_MSGCTL: 2034 if (cmd == IPC_STAT || cmd == IPC_SET) 2035 infosize = sizeof(struct msqid_ds); 2036 break; 2037 #endif 2038 #ifdef HAS_SHM 2039 case OP_SHMCTL: 2040 if (cmd == IPC_STAT || cmd == IPC_SET) 2041 infosize = sizeof(struct shmid_ds); 2042 break; 2043 #endif 2044 #ifdef HAS_SEM 2045 case OP_SEMCTL: 2046 #ifdef Semctl 2047 if (cmd == IPC_STAT || cmd == IPC_SET) 2048 infosize = sizeof(struct semid_ds); 2049 else if (cmd == GETALL || cmd == SETALL) 2050 { 2051 struct semid_ds semds; 2052 union semun semun; 2053 #ifdef EXTRA_F_IN_SEMUN_BUF 2054 semun.buff = &semds; 2055 #else 2056 semun.buf = &semds; 2057 #endif 2058 getinfo = (cmd == GETALL); 2059 if (Semctl(id, 0, IPC_STAT, semun) == -1) 2060 return -1; 2061 infosize = semds.sem_nsems * sizeof(short); 2062 /* "short" is technically wrong but much more portable 2063 than guessing about u_?short(_t)? */ 2064 } 2065 #else 2066 /* diag_listed_as: sem%s not implemented */ 2067 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]); 2068 #endif 2069 break; 2070 #endif 2071 #if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM) 2072 default: 2073 /* diag_listed_as: shm%s not implemented */ 2074 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]); 2075 #endif 2076 } 2077 2078 if (infosize) 2079 { 2080 if (getinfo) 2081 { 2082 SvPV_force_nolen(astr); 2083 a = SvGROW(astr, infosize+1); 2084 } 2085 else 2086 { 2087 STRLEN len; 2088 a = SvPV(astr, len); 2089 if (len != infosize) 2090 Perl_croak(aTHX_ "Bad arg length for %s, is %lu, should be %ld", 2091 PL_op_desc[optype], 2092 (unsigned long)len, 2093 (long)infosize); 2094 } 2095 } 2096 else 2097 { 2098 const IV i = SvIV(astr); 2099 a = INT2PTR(char *,i); /* ouch */ 2100 } 2101 SETERRNO(0,0); 2102 switch (optype) 2103 { 2104 #ifdef HAS_MSG 2105 case OP_MSGCTL: 2106 ret = msgctl(id, cmd, (struct msqid_ds *)a); 2107 break; 2108 #endif 2109 #ifdef HAS_SEM 2110 case OP_SEMCTL: { 2111 #ifdef Semctl 2112 union semun unsemds; 2113 2114 #ifdef EXTRA_F_IN_SEMUN_BUF 2115 unsemds.buff = (struct semid_ds *)a; 2116 #else 2117 unsemds.buf = (struct semid_ds *)a; 2118 #endif 2119 ret = Semctl(id, n, cmd, unsemds); 2120 #else 2121 /* diag_listed_as: sem%s not implemented */ 2122 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]); 2123 #endif 2124 } 2125 break; 2126 #endif 2127 #ifdef HAS_SHM 2128 case OP_SHMCTL: 2129 ret = shmctl(id, cmd, (struct shmid_ds *)a); 2130 break; 2131 #endif 2132 } 2133 if (getinfo && ret >= 0) { 2134 SvCUR_set(astr, infosize); 2135 *SvEND(astr) = '\0'; 2136 SvSETMAGIC(astr); 2137 } 2138 return ret; 2139 } 2140 2141 I32 2142 Perl_do_msgsnd(pTHX_ SV **mark, SV **sp) 2143 { 2144 dVAR; 2145 #ifdef HAS_MSG 2146 STRLEN len; 2147 const I32 id = SvIVx(*++mark); 2148 SV * const mstr = *++mark; 2149 const I32 flags = SvIVx(*++mark); 2150 const char * const mbuf = SvPV_const(mstr, len); 2151 const I32 msize = len - sizeof(long); 2152 2153 PERL_ARGS_ASSERT_DO_MSGSND; 2154 PERL_UNUSED_ARG(sp); 2155 2156 if (msize < 0) 2157 Perl_croak(aTHX_ "Arg too short for msgsnd"); 2158 SETERRNO(0,0); 2159 return msgsnd(id, (struct msgbuf *)mbuf, msize, flags); 2160 #else 2161 PERL_UNUSED_ARG(sp); 2162 PERL_UNUSED_ARG(mark); 2163 /* diag_listed_as: msg%s not implemented */ 2164 Perl_croak(aTHX_ "msgsnd not implemented"); 2165 return -1; 2166 #endif 2167 } 2168 2169 I32 2170 Perl_do_msgrcv(pTHX_ SV **mark, SV **sp) 2171 { 2172 #ifdef HAS_MSG 2173 dVAR; 2174 char *mbuf; 2175 long mtype; 2176 I32 msize, flags, ret; 2177 const I32 id = SvIVx(*++mark); 2178 SV * const mstr = *++mark; 2179 2180 PERL_ARGS_ASSERT_DO_MSGRCV; 2181 PERL_UNUSED_ARG(sp); 2182 2183 /* suppress warning when reading into undef var --jhi */ 2184 if (! SvOK(mstr)) 2185 sv_setpvs(mstr, ""); 2186 msize = SvIVx(*++mark); 2187 mtype = (long)SvIVx(*++mark); 2188 flags = SvIVx(*++mark); 2189 SvPV_force_nolen(mstr); 2190 mbuf = SvGROW(mstr, sizeof(long)+msize+1); 2191 2192 SETERRNO(0,0); 2193 ret = msgrcv(id, (struct msgbuf *)mbuf, msize, mtype, flags); 2194 if (ret >= 0) { 2195 SvCUR_set(mstr, sizeof(long)+ret); 2196 *SvEND(mstr) = '\0'; 2197 #ifndef INCOMPLETE_TAINTS 2198 /* who knows who has been playing with this message? */ 2199 SvTAINTED_on(mstr); 2200 #endif 2201 } 2202 return ret; 2203 #else 2204 PERL_UNUSED_ARG(sp); 2205 PERL_UNUSED_ARG(mark); 2206 /* diag_listed_as: msg%s not implemented */ 2207 Perl_croak(aTHX_ "msgrcv not implemented"); 2208 return -1; 2209 #endif 2210 } 2211 2212 I32 2213 Perl_do_semop(pTHX_ SV **mark, SV **sp) 2214 { 2215 #ifdef HAS_SEM 2216 dVAR; 2217 STRLEN opsize; 2218 const I32 id = SvIVx(*++mark); 2219 SV * const opstr = *++mark; 2220 const char * const opbuf = SvPV_const(opstr, opsize); 2221 2222 PERL_ARGS_ASSERT_DO_SEMOP; 2223 PERL_UNUSED_ARG(sp); 2224 2225 if (opsize < 3 * SHORTSIZE 2226 || (opsize % (3 * SHORTSIZE))) { 2227 SETERRNO(EINVAL,LIB_INVARG); 2228 return -1; 2229 } 2230 SETERRNO(0,0); 2231 /* We can't assume that sizeof(struct sembuf) == 3 * sizeof(short). */ 2232 { 2233 const int nsops = opsize / (3 * sizeof (short)); 2234 int i = nsops; 2235 short * const ops = (short *) opbuf; 2236 short *o = ops; 2237 struct sembuf *temps, *t; 2238 I32 result; 2239 2240 Newx (temps, nsops, struct sembuf); 2241 t = temps; 2242 while (i--) { 2243 t->sem_num = *o++; 2244 t->sem_op = *o++; 2245 t->sem_flg = *o++; 2246 t++; 2247 } 2248 result = semop(id, temps, nsops); 2249 t = temps; 2250 o = ops; 2251 i = nsops; 2252 while (i--) { 2253 *o++ = t->sem_num; 2254 *o++ = t->sem_op; 2255 *o++ = t->sem_flg; 2256 t++; 2257 } 2258 Safefree(temps); 2259 return result; 2260 } 2261 #else 2262 /* diag_listed_as: sem%s not implemented */ 2263 Perl_croak(aTHX_ "semop not implemented"); 2264 #endif 2265 } 2266 2267 I32 2268 Perl_do_shmio(pTHX_ I32 optype, SV **mark, SV **sp) 2269 { 2270 #ifdef HAS_SHM 2271 dVAR; 2272 char *shm; 2273 struct shmid_ds shmds; 2274 const I32 id = SvIVx(*++mark); 2275 SV * const mstr = *++mark; 2276 const I32 mpos = SvIVx(*++mark); 2277 const I32 msize = SvIVx(*++mark); 2278 2279 PERL_ARGS_ASSERT_DO_SHMIO; 2280 PERL_UNUSED_ARG(sp); 2281 2282 SETERRNO(0,0); 2283 if (shmctl(id, IPC_STAT, &shmds) == -1) 2284 return -1; 2285 if (mpos < 0 || msize < 0 2286 || (size_t)mpos + msize > (size_t)shmds.shm_segsz) { 2287 SETERRNO(EFAULT,SS_ACCVIO); /* can't do as caller requested */ 2288 return -1; 2289 } 2290 shm = (char *)shmat(id, NULL, (optype == OP_SHMREAD) ? SHM_RDONLY : 0); 2291 if (shm == (char *)-1) /* I hate System V IPC, I really do */ 2292 return -1; 2293 if (optype == OP_SHMREAD) { 2294 char *mbuf; 2295 /* suppress warning when reading into undef var (tchrist 3/Mar/00) */ 2296 SvGETMAGIC(mstr); 2297 SvUPGRADE(mstr, SVt_PV); 2298 if (! SvOK(mstr)) 2299 sv_setpvs(mstr, ""); 2300 SvPOK_only(mstr); 2301 mbuf = SvGROW(mstr, (STRLEN)msize+1); 2302 2303 Copy(shm + mpos, mbuf, msize, char); 2304 SvCUR_set(mstr, msize); 2305 *SvEND(mstr) = '\0'; 2306 SvSETMAGIC(mstr); 2307 #ifndef INCOMPLETE_TAINTS 2308 /* who knows who has been playing with this shared memory? */ 2309 SvTAINTED_on(mstr); 2310 #endif 2311 } 2312 else { 2313 STRLEN len; 2314 2315 const char *mbuf = SvPV_const(mstr, len); 2316 const I32 n = ((I32)len > msize) ? msize : (I32)len; 2317 Copy(mbuf, shm + mpos, n, char); 2318 if (n < msize) 2319 memzero(shm + mpos + n, msize - n); 2320 } 2321 return shmdt(shm); 2322 #else 2323 /* diag_listed_as: shm%s not implemented */ 2324 Perl_croak(aTHX_ "shm I/O not implemented"); 2325 return -1; 2326 #endif 2327 } 2328 2329 #endif /* SYSV IPC */ 2330 2331 /* 2332 =head1 IO Functions 2333 2334 =for apidoc start_glob 2335 2336 Function called by C<do_readline> to spawn a glob (or do the glob inside 2337 perl on VMS). This code used to be inline, but now perl uses C<File::Glob> 2338 this glob starter is only used by miniperl during the build process. 2339 Moving it away shrinks pp_hot.c; shrinking pp_hot.c helps speed perl up. 2340 2341 =cut 2342 */ 2343 2344 PerlIO * 2345 Perl_start_glob (pTHX_ SV *tmpglob, IO *io) 2346 { 2347 dVAR; 2348 SV * const tmpcmd = newSV(0); 2349 PerlIO *fp; 2350 2351 PERL_ARGS_ASSERT_START_GLOB; 2352 2353 ENTER; 2354 SAVEFREESV(tmpcmd); 2355 #ifdef VMS /* expand the wildcards right here, rather than opening a pipe, */ 2356 /* since spawning off a process is a real performance hit */ 2357 2358 PerlIO * 2359 Perl_vms_start_glob 2360 (pTHX_ SV *tmpglob, 2361 IO *io); 2362 2363 fp = Perl_vms_start_glob(aTHX_ tmpglob, io); 2364 2365 #else /* !VMS */ 2366 #ifdef DOSISH 2367 #ifdef OS2 2368 sv_setpv(tmpcmd, "for a in "); 2369 sv_catsv(tmpcmd, tmpglob); 2370 sv_catpv(tmpcmd, "; do echo \"$a\\0\\c\"; done |"); 2371 #else 2372 #ifdef DJGPP 2373 sv_setpv(tmpcmd, "/dev/dosglob/"); /* File System Extension */ 2374 sv_catsv(tmpcmd, tmpglob); 2375 #else 2376 sv_setpv(tmpcmd, "perlglob "); 2377 sv_catsv(tmpcmd, tmpglob); 2378 sv_catpv(tmpcmd, " |"); 2379 #endif /* !DJGPP */ 2380 #endif /* !OS2 */ 2381 #else /* !DOSISH */ 2382 #if defined(CSH) 2383 sv_setpvn(tmpcmd, PL_cshname, PL_cshlen); 2384 sv_catpv(tmpcmd, " -cf 'set nonomatch; glob "); 2385 sv_catsv(tmpcmd, tmpglob); 2386 sv_catpv(tmpcmd, "' 2>/dev/null |"); 2387 #else 2388 sv_setpv(tmpcmd, "echo "); 2389 sv_catsv(tmpcmd, tmpglob); 2390 #if 'z' - 'a' == 25 2391 sv_catpv(tmpcmd, "|tr -s ' \t\f\r' '\\012\\012\\012\\012'|"); 2392 #else 2393 sv_catpv(tmpcmd, "|tr -s ' \t\f\r' '\\n\\n\\n\\n'|"); 2394 #endif 2395 #endif /* !CSH */ 2396 #endif /* !DOSISH */ 2397 { 2398 GV * const envgv = gv_fetchpvs("ENV", 0, SVt_PVHV); 2399 SV ** const home = hv_fetchs(GvHV(envgv), "HOME", 0); 2400 SV ** const path = hv_fetchs(GvHV(envgv), "PATH", 0); 2401 if (home && *home) SvGETMAGIC(*home); 2402 if (path && *path) SvGETMAGIC(*path); 2403 save_hash(gv_fetchpvs("ENV", 0, SVt_PVHV)); 2404 if (home && *home) SvSETMAGIC(*home); 2405 if (path && *path) SvSETMAGIC(*path); 2406 } 2407 (void)do_open(PL_last_in_gv, (char*)SvPVX_const(tmpcmd), SvCUR(tmpcmd), 2408 FALSE, O_RDONLY, 0, NULL); 2409 fp = IoIFP(io); 2410 #endif /* !VMS */ 2411 LEAVE; 2412 return fp; 2413 } 2414 2415 /* 2416 * Local variables: 2417 * c-indentation-style: bsd 2418 * c-basic-offset: 4 2419 * indent-tabs-mode: nil 2420 * End: 2421 * 2422 * ex: set ts=8 sts=4 sw=4 et: 2423 */ 2424