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