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