1 /* doio.c 2 * 3 * Copyright (c) 1991-2001, Larry Wall 4 * 5 * You may distribute under the terms of either the GNU General Public 6 * License or the Artistic License, as specified in the README file. 7 * 8 */ 9 10 /* 11 * "Far below them they saw the white waters pour into a foaming bowl, and 12 * then swirl darkly about a deep oval basin in the rocks, until they found 13 * their way out again through a narrow gate, and flowed away, fuming and 14 * chattering, into calmer and more level reaches." 15 */ 16 17 #include "EXTERN.h" 18 #define PERL_IN_DOIO_C 19 #include "perl.h" 20 21 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) 22 #ifndef HAS_SEM 23 #include <sys/ipc.h> 24 #endif 25 #ifdef HAS_MSG 26 #include <sys/msg.h> 27 #endif 28 #ifdef HAS_SHM 29 #include <sys/shm.h> 30 # ifndef HAS_SHMAT_PROTOTYPE 31 extern Shmat_t shmat (int, char *, int); 32 # endif 33 #endif 34 #endif 35 36 #ifdef I_UTIME 37 # if defined(_MSC_VER) || defined(__MINGW32__) 38 # include <sys/utime.h> 39 # else 40 # include <utime.h> 41 # endif 42 #endif 43 44 #ifdef O_EXCL 45 # define OPEN_EXCL O_EXCL 46 #else 47 # define OPEN_EXCL 0 48 #endif 49 50 #if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX) 51 #include <signal.h> 52 #endif 53 54 bool 55 Perl_do_open(pTHX_ GV *gv, register char *name, I32 len, int as_raw, 56 int rawmode, int rawperm, PerlIO *supplied_fp) 57 { 58 return do_open9(gv, name, len, as_raw, rawmode, rawperm, 59 supplied_fp, Nullsv, 0); 60 } 61 62 bool 63 Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, 64 int rawmode, int rawperm, PerlIO *supplied_fp, SV *svs, 65 I32 num_svs) 66 { 67 register IO *io = GvIOn(gv); 68 PerlIO *saveifp = Nullfp; 69 PerlIO *saveofp = Nullfp; 70 char savetype = IoTYPE_CLOSED; 71 int writing = 0; 72 PerlIO *fp; 73 int fd; 74 int result; 75 bool was_fdopen = FALSE; 76 bool in_raw = 0, in_crlf = 0, out_raw = 0, out_crlf = 0; 77 78 PL_forkprocess = 1; /* assume true if no fork */ 79 80 if (PL_op && PL_op->op_type == OP_OPEN) { 81 /* set up disciplines */ 82 U8 flags = PL_op->op_private; 83 in_raw = (flags & OPpOPEN_IN_RAW); 84 in_crlf = (flags & OPpOPEN_IN_CRLF); 85 out_raw = (flags & OPpOPEN_OUT_RAW); 86 out_crlf = (flags & OPpOPEN_OUT_CRLF); 87 } 88 89 if (IoIFP(io)) { 90 fd = PerlIO_fileno(IoIFP(io)); 91 if (IoTYPE(io) == IoTYPE_STD) 92 result = 0; 93 else if (fd <= PL_maxsysfd) { 94 saveifp = IoIFP(io); 95 saveofp = IoOFP(io); 96 savetype = IoTYPE(io); 97 result = 0; 98 } 99 else if (IoTYPE(io) == IoTYPE_PIPE) 100 result = PerlProc_pclose(IoIFP(io)); 101 else if (IoIFP(io) != IoOFP(io)) { 102 if (IoOFP(io)) { 103 result = PerlIO_close(IoOFP(io)); 104 PerlIO_close(IoIFP(io)); /* clear stdio, fd already closed */ 105 } 106 else 107 result = PerlIO_close(IoIFP(io)); 108 } 109 else 110 result = PerlIO_close(IoIFP(io)); 111 if (result == EOF && fd > PL_maxsysfd) 112 PerlIO_printf(Perl_error_log, 113 "Warning: unable to close filehandle %s properly.\n", 114 GvENAME(gv)); 115 IoOFP(io) = IoIFP(io) = Nullfp; 116 } 117 118 if (as_raw) { 119 #if defined(USE_64_BIT_RAWIO) && defined(O_LARGEFILE) 120 rawmode |= O_LARGEFILE; 121 #endif 122 123 #ifndef O_ACCMODE 124 #define O_ACCMODE 3 /* Assume traditional implementation */ 125 #endif 126 127 switch (result = rawmode & O_ACCMODE) { 128 case O_RDONLY: 129 IoTYPE(io) = IoTYPE_RDONLY; 130 break; 131 case O_WRONLY: 132 IoTYPE(io) = IoTYPE_WRONLY; 133 break; 134 case O_RDWR: 135 default: 136 IoTYPE(io) = IoTYPE_RDWR; 137 break; 138 } 139 140 writing = (result > 0); 141 fd = PerlLIO_open3(name, rawmode, rawperm); 142 143 if (fd == -1) 144 fp = NULL; 145 else { 146 char fpmode[4]; 147 STRLEN ix = 0; 148 if (result == O_RDONLY) 149 fpmode[ix++] = 'r'; 150 #ifdef O_APPEND 151 else if (rawmode & O_APPEND) { 152 fpmode[ix++] = 'a'; 153 if (result != O_WRONLY) 154 fpmode[ix++] = '+'; 155 } 156 #endif 157 else { 158 if (result == O_WRONLY) 159 fpmode[ix++] = 'w'; 160 else { 161 fpmode[ix++] = 'r'; 162 fpmode[ix++] = '+'; 163 } 164 } 165 if (rawmode & O_BINARY) 166 fpmode[ix++] = 'b'; 167 fpmode[ix] = '\0'; 168 fp = PerlIO_fdopen(fd, fpmode); 169 if (!fp) 170 PerlLIO_close(fd); 171 } 172 } 173 else { 174 char *type; 175 char *oname = name; 176 STRLEN tlen; 177 STRLEN olen = len; 178 char mode[4]; /* stdio file mode ("r\0", "rb\0", "r+b\0" etc.) */ 179 int dodup; 180 181 type = savepvn(name, len); 182 tlen = len; 183 SAVEFREEPV(type); 184 if (num_svs) { 185 STRLEN l; 186 name = SvPV(svs, l) ; 187 len = (I32)l; 188 name = savepvn(name, len); 189 SAVEFREEPV(name); 190 } 191 else { 192 while (tlen && isSPACE(type[tlen-1])) 193 type[--tlen] = '\0'; 194 name = type; 195 len = tlen; 196 } 197 mode[0] = mode[1] = mode[2] = mode[3] = '\0'; 198 IoTYPE(io) = *type; 199 if (*type == IoTYPE_RDWR && tlen > 1 && type[tlen-1] != IoTYPE_PIPE) { /* scary */ 200 mode[1] = *type++; 201 --tlen; 202 writing = 1; 203 } 204 205 if (*type == IoTYPE_PIPE) { 206 if (num_svs && (tlen != 2 || type[1] != IoTYPE_STD)) { 207 unknown_desr: 208 Perl_croak(aTHX_ "Unknown open() mode '%.*s'", (int)olen, oname); 209 } 210 /*SUPPRESS 530*/ 211 for (type++, tlen--; isSPACE(*type); type++, tlen--) ; 212 if (!num_svs) { 213 name = type; 214 len = tlen; 215 } 216 if (*name == '\0') { /* command is missing 19990114 */ 217 if (ckWARN(WARN_PIPE)) 218 Perl_warner(aTHX_ WARN_PIPE, "Missing command in piped open"); 219 errno = EPIPE; 220 goto say_false; 221 } 222 if (strNE(name,"-") || num_svs) 223 TAINT_ENV(); 224 TAINT_PROPER("piped open"); 225 if (name[len-1] == '|') { 226 name[--len] = '\0' ; 227 if (ckWARN(WARN_PIPE)) 228 Perl_warner(aTHX_ WARN_PIPE, "Can't open bidirectional pipe"); 229 } 230 { 231 char *mode; 232 if (out_raw) 233 mode = "wb"; 234 else if (out_crlf) 235 mode = "wt"; 236 else 237 mode = "w"; 238 fp = PerlProc_popen(name,mode); 239 } 240 writing = 1; 241 } 242 else if (*type == IoTYPE_WRONLY) { 243 TAINT_PROPER("open"); 244 type++; 245 if (*type == IoTYPE_WRONLY) { 246 /* Two IoTYPE_WRONLYs in a row make for an IoTYPE_APPEND. */ 247 mode[0] = IoTYPE(io) = IoTYPE_APPEND; 248 type++; 249 tlen--; 250 } 251 else 252 mode[0] = 'w'; 253 writing = 1; 254 255 if (out_raw) 256 strcat(mode, "b"); 257 else if (out_crlf) 258 strcat(mode, "t"); 259 260 if (num_svs && tlen != 1) 261 goto unknown_desr; 262 if (*type == '&') { 263 name = type; 264 duplicity: 265 dodup = 1; 266 name++; 267 if (*name == '=') { 268 dodup = 0; 269 name++; 270 } 271 if (!*name && supplied_fp) 272 fp = supplied_fp; 273 else { 274 /*SUPPRESS 530*/ 275 for (; isSPACE(*name); name++) ; 276 if (isDIGIT(*name)) 277 fd = atoi(name); 278 else { 279 IO* thatio; 280 gv = gv_fetchpv(name,FALSE,SVt_PVIO); 281 thatio = GvIO(gv); 282 if (!thatio) { 283 #ifdef EINVAL 284 SETERRNO(EINVAL,SS$_IVCHAN); 285 #endif 286 goto say_false; 287 } 288 if (IoIFP(thatio)) { 289 PerlIO *fp = IoIFP(thatio); 290 /* Flush stdio buffer before dup. --mjd 291 * Unfortunately SEEK_CURing 0 seems to 292 * be optimized away on most platforms; 293 * only Solaris and Linux seem to flush 294 * on that. --jhi */ 295 #ifdef USE_SFIO 296 /* sfio fails to clear error on next 297 sfwrite, contrary to documentation. 298 -- Nick Clark */ 299 if (PerlIO_seek(fp, 0, SEEK_CUR) == -1) 300 PerlIO_clearerr(fp); 301 #endif 302 /* On the other hand, do all platforms 303 * take gracefully to flushing a read-only 304 * filehandle? Perhaps we should do 305 * fsetpos(src)+fgetpos(dst)? --nik */ 306 PerlIO_flush(fp); 307 fd = PerlIO_fileno(fp); 308 /* When dup()ing STDIN, STDOUT or STDERR 309 * explicitly set appropriate access mode */ 310 if (IoIFP(thatio) == PerlIO_stdout() 311 || IoIFP(thatio) == PerlIO_stderr()) 312 IoTYPE(io) = IoTYPE_WRONLY; 313 else if (IoIFP(thatio) == PerlIO_stdin()) 314 IoTYPE(io) = IoTYPE_RDONLY; 315 /* When dup()ing a socket, say result is 316 * one as well */ 317 else if (IoTYPE(thatio) == IoTYPE_SOCKET) 318 IoTYPE(io) = IoTYPE_SOCKET; 319 } 320 else 321 fd = -1; 322 } 323 if (dodup) 324 fd = PerlLIO_dup(fd); 325 else 326 was_fdopen = TRUE; 327 if (!(fp = PerlIO_fdopen(fd,mode))) { 328 if (dodup) 329 PerlLIO_close(fd); 330 } 331 } 332 } 333 else { 334 /*SUPPRESS 530*/ 335 for (; isSPACE(*type); type++) ; 336 if (*type == IoTYPE_STD && !type[1]) { 337 fp = PerlIO_stdout(); 338 IoTYPE(io) = IoTYPE_STD; 339 } 340 else { 341 fp = PerlIO_open((num_svs ? name : type), mode); 342 } 343 } 344 } 345 else if (*type == IoTYPE_RDONLY) { 346 if (num_svs && tlen != 1) 347 goto unknown_desr; 348 /*SUPPRESS 530*/ 349 for (type++; isSPACE(*type); type++) ; 350 mode[0] = 'r'; 351 if (in_raw) 352 strcat(mode, "b"); 353 else if (in_crlf) 354 strcat(mode, "t"); 355 356 if (*type == '&') { 357 name = type; 358 goto duplicity; 359 } 360 if (*type == IoTYPE_STD && !type[1]) { 361 fp = PerlIO_stdin(); 362 IoTYPE(io) = IoTYPE_STD; 363 } 364 else 365 fp = PerlIO_open((num_svs ? name : type), mode); 366 } 367 else if (tlen > 1 && type[tlen-1] == IoTYPE_PIPE) { 368 if (num_svs) { 369 if (tlen != 2 || type[0] != IoTYPE_STD) 370 goto unknown_desr; 371 } 372 else { 373 type[--tlen] = '\0'; 374 while (tlen && isSPACE(type[tlen-1])) 375 type[--tlen] = '\0'; 376 /*SUPPRESS 530*/ 377 for (; isSPACE(*type); type++) ; 378 name = type; 379 } 380 if (*name == '\0') { /* command is missing 19990114 */ 381 if (ckWARN(WARN_PIPE)) 382 Perl_warner(aTHX_ WARN_PIPE, "Missing command in piped open"); 383 errno = EPIPE; 384 goto say_false; 385 } 386 if (strNE(name,"-") || num_svs) 387 TAINT_ENV(); 388 TAINT_PROPER("piped open"); 389 { 390 char *mode; 391 if (in_raw) 392 mode = "rb"; 393 else if (in_crlf) 394 mode = "rt"; 395 else 396 mode = "r"; 397 fp = PerlProc_popen(name,mode); 398 } 399 IoTYPE(io) = IoTYPE_PIPE; 400 } 401 else { 402 if (num_svs) 403 goto unknown_desr; 404 name = type; 405 IoTYPE(io) = IoTYPE_RDONLY; 406 /*SUPPRESS 530*/ 407 for (; isSPACE(*name); name++) ; 408 if (strEQ(name,"-")) { 409 fp = PerlIO_stdin(); 410 IoTYPE(io) = IoTYPE_STD; 411 } 412 else { 413 char *mode; 414 if (in_raw) 415 mode = "rb"; 416 else if (in_crlf) 417 mode = "rt"; 418 else 419 mode = "r"; 420 fp = PerlIO_open(name,mode); 421 } 422 } 423 } 424 if (!fp) { 425 if (ckWARN(WARN_NEWLINE) && IoTYPE(io) == IoTYPE_RDONLY && strchr(name, '\n')) 426 Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "open"); 427 goto say_false; 428 } 429 if (IoTYPE(io) && IoTYPE(io) != IoTYPE_PIPE && IoTYPE(io) != IoTYPE_STD) { 430 if (PerlLIO_fstat(PerlIO_fileno(fp),&PL_statbuf) < 0) { 431 (void)PerlIO_close(fp); 432 goto say_false; 433 } 434 if (S_ISSOCK(PL_statbuf.st_mode)) 435 IoTYPE(io) = IoTYPE_SOCKET; /* in case a socket was passed in to us */ 436 #ifdef HAS_SOCKET 437 else if ( 438 #ifdef S_IFMT 439 !(PL_statbuf.st_mode & S_IFMT) 440 #else 441 !PL_statbuf.st_mode 442 #endif 443 && IoTYPE(io) != IoTYPE_WRONLY /* Dups of STD* filehandles already have */ 444 && IoTYPE(io) != IoTYPE_RDONLY /* type so they aren't marked as sockets */ 445 ) { /* on OS's that return 0 on fstat()ed pipe */ 446 char tmpbuf[256]; 447 Sock_size_t buflen = sizeof tmpbuf; 448 if (PerlSock_getsockname(PerlIO_fileno(fp), (struct sockaddr *)tmpbuf, 449 &buflen) >= 0 450 || errno != ENOTSOCK) 451 IoTYPE(io) = IoTYPE_SOCKET; /* some OS's return 0 on fstat()ed socket */ 452 /* but some return 0 for streams too, sigh */ 453 } 454 #endif 455 } 456 if (saveifp) { /* must use old fp? */ 457 fd = PerlIO_fileno(saveifp); 458 if (saveofp) { 459 PerlIO_flush(saveofp); /* emulate PerlIO_close() */ 460 if (saveofp != saveifp) { /* was a socket? */ 461 PerlIO_close(saveofp); 462 if (fd > 2) 463 Safefree(saveofp); 464 } 465 } 466 if (fd != PerlIO_fileno(fp)) { 467 Pid_t pid; 468 SV *sv; 469 470 PerlLIO_dup2(PerlIO_fileno(fp), fd); 471 #ifdef VMS 472 if (fd != PerlIO_fileno(PerlIO_stdin())) { 473 char newname[FILENAME_MAX+1]; 474 if (fgetname(fp, newname)) { 475 if (fd == PerlIO_fileno(PerlIO_stdout())) Perl_vmssetuserlnm("SYS$OUTPUT", newname); 476 if (fd == PerlIO_fileno(PerlIO_stderr())) Perl_vmssetuserlnm("SYS$ERROR", newname); 477 } 478 } 479 #endif 480 LOCK_FDPID_MUTEX; 481 sv = *av_fetch(PL_fdpid,PerlIO_fileno(fp),TRUE); 482 (void)SvUPGRADE(sv, SVt_IV); 483 pid = SvIVX(sv); 484 SvIVX(sv) = 0; 485 sv = *av_fetch(PL_fdpid,fd,TRUE); 486 UNLOCK_FDPID_MUTEX; 487 (void)SvUPGRADE(sv, SVt_IV); 488 SvIVX(sv) = pid; 489 if (!was_fdopen) 490 PerlIO_close(fp); 491 492 } 493 fp = saveifp; 494 PerlIO_clearerr(fp); 495 } 496 #if defined(HAS_FCNTL) && defined(F_SETFD) 497 { 498 int save_errno = errno; 499 fd = PerlIO_fileno(fp); 500 fcntl(fd,F_SETFD,fd > PL_maxsysfd); /* can change errno */ 501 errno = save_errno; 502 } 503 #endif 504 IoIFP(io) = fp; 505 IoFLAGS(io) &= ~IOf_NOLINE; 506 if (writing) { 507 if (IoTYPE(io) == IoTYPE_SOCKET 508 || (IoTYPE(io) == IoTYPE_WRONLY && S_ISCHR(PL_statbuf.st_mode)) ) 509 { 510 char *mode; 511 if (out_raw) 512 mode = "wb"; 513 else if (out_crlf) 514 mode = "wt"; 515 else 516 mode = "w"; 517 518 if (!(IoOFP(io) = PerlIO_fdopen(PerlIO_fileno(fp),mode))) { 519 PerlIO_close(fp); 520 IoIFP(io) = Nullfp; 521 goto say_false; 522 } 523 } 524 else 525 IoOFP(io) = fp; 526 } 527 return TRUE; 528 529 say_false: 530 IoIFP(io) = saveifp; 531 IoOFP(io) = saveofp; 532 IoTYPE(io) = savetype; 533 return FALSE; 534 } 535 536 PerlIO * 537 Perl_nextargv(pTHX_ register GV *gv) 538 { 539 register SV *sv; 540 #ifndef FLEXFILENAMES 541 int filedev; 542 int fileino; 543 #endif 544 Uid_t fileuid; 545 Gid_t filegid; 546 IO *io = GvIOp(gv); 547 548 if (!PL_argvoutgv) 549 PL_argvoutgv = gv_fetchpv("ARGVOUT",TRUE,SVt_PVIO); 550 if (io && (IoFLAGS(io) & IOf_ARGV) && (IoFLAGS(io) & IOf_START)) { 551 IoFLAGS(io) &= ~IOf_START; 552 if (PL_inplace) { 553 if (!PL_argvout_stack) 554 PL_argvout_stack = newAV(); 555 av_push(PL_argvout_stack, SvREFCNT_inc(PL_defoutgv)); 556 } 557 } 558 if (PL_filemode & (S_ISUID|S_ISGID)) { 559 PerlIO_flush(IoIFP(GvIOn(PL_argvoutgv))); /* chmod must follow last write */ 560 #ifdef HAS_FCHMOD 561 (void)fchmod(PL_lastfd,PL_filemode); 562 #else 563 (void)PerlLIO_chmod(PL_oldname,PL_filemode); 564 #endif 565 } 566 PL_filemode = 0; 567 while (av_len(GvAV(gv)) >= 0) { 568 STRLEN oldlen; 569 sv = av_shift(GvAV(gv)); 570 SAVEFREESV(sv); 571 sv_setsv(GvSV(gv),sv); 572 SvSETMAGIC(GvSV(gv)); 573 PL_oldname = SvPVx(GvSV(gv), oldlen); 574 if (do_open(gv,PL_oldname,oldlen,PL_inplace!=0,O_RDONLY,0,Nullfp)) { 575 if (PL_inplace) { 576 TAINT_PROPER("inplace open"); 577 if (oldlen == 1 && *PL_oldname == '-') { 578 setdefout(gv_fetchpv("STDOUT",TRUE,SVt_PVIO)); 579 return IoIFP(GvIOp(gv)); 580 } 581 #ifndef FLEXFILENAMES 582 filedev = PL_statbuf.st_dev; 583 fileino = PL_statbuf.st_ino; 584 #endif 585 PL_filemode = PL_statbuf.st_mode; 586 fileuid = PL_statbuf.st_uid; 587 filegid = PL_statbuf.st_gid; 588 if (!S_ISREG(PL_filemode)) { 589 if (ckWARN_d(WARN_INPLACE)) 590 Perl_warner(aTHX_ WARN_INPLACE, 591 "Can't do inplace edit: %s is not a regular file", 592 PL_oldname ); 593 do_close(gv,FALSE); 594 continue; 595 } 596 if (*PL_inplace) { 597 char *star = strchr(PL_inplace, '*'); 598 if (star) { 599 char *begin = PL_inplace; 600 sv_setpvn(sv, "", 0); 601 do { 602 sv_catpvn(sv, begin, star - begin); 603 sv_catpvn(sv, PL_oldname, oldlen); 604 begin = ++star; 605 } while ((star = strchr(begin, '*'))); 606 if (*begin) 607 sv_catpv(sv,begin); 608 } 609 else { 610 sv_catpv(sv,PL_inplace); 611 } 612 #ifndef FLEXFILENAMES 613 if (PerlLIO_stat(SvPVX(sv),&PL_statbuf) >= 0 614 && PL_statbuf.st_dev == filedev 615 && PL_statbuf.st_ino == fileino 616 #ifdef DJGPP 617 || (_djstat_fail_bits & _STFAIL_TRUENAME)!=0 618 #endif 619 ) 620 { 621 if (ckWARN_d(WARN_INPLACE)) 622 Perl_warner(aTHX_ WARN_INPLACE, 623 "Can't do inplace edit: %s would not be unique", 624 SvPVX(sv)); 625 do_close(gv,FALSE); 626 continue; 627 } 628 #endif 629 #ifdef HAS_RENAME 630 #if !defined(DOSISH) && !defined(__CYGWIN__) 631 if (PerlLIO_rename(PL_oldname,SvPVX(sv)) < 0) { 632 if (ckWARN_d(WARN_INPLACE)) 633 Perl_warner(aTHX_ WARN_INPLACE, 634 "Can't rename %s to %s: %s, skipping file", 635 PL_oldname, SvPVX(sv), Strerror(errno) ); 636 do_close(gv,FALSE); 637 continue; 638 } 639 #else 640 do_close(gv,FALSE); 641 (void)PerlLIO_unlink(SvPVX(sv)); 642 (void)PerlLIO_rename(PL_oldname,SvPVX(sv)); 643 do_open(gv,SvPVX(sv),SvCUR(sv),PL_inplace!=0,O_RDONLY,0,Nullfp); 644 #endif /* DOSISH */ 645 #else 646 (void)UNLINK(SvPVX(sv)); 647 if (link(PL_oldname,SvPVX(sv)) < 0) { 648 if (ckWARN_d(WARN_INPLACE)) 649 Perl_warner(aTHX_ WARN_INPLACE, 650 "Can't rename %s to %s: %s, skipping file", 651 PL_oldname, SvPVX(sv), Strerror(errno) ); 652 do_close(gv,FALSE); 653 continue; 654 } 655 (void)UNLINK(PL_oldname); 656 #endif 657 } 658 else { 659 #if !defined(DOSISH) && !defined(AMIGAOS) 660 # ifndef VMS /* Don't delete; use automatic file versioning */ 661 if (UNLINK(PL_oldname) < 0) { 662 if (ckWARN_d(WARN_INPLACE)) 663 Perl_warner(aTHX_ WARN_INPLACE, 664 "Can't remove %s: %s, skipping file", 665 PL_oldname, Strerror(errno) ); 666 do_close(gv,FALSE); 667 continue; 668 } 669 # endif 670 #else 671 Perl_croak(aTHX_ "Can't do inplace edit without backup"); 672 #endif 673 } 674 675 sv_setpvn(sv,">",!PL_inplace); 676 sv_catpvn(sv,PL_oldname,oldlen); 677 SETERRNO(0,0); /* in case sprintf set errno */ 678 #ifdef VMS 679 if (!do_open(PL_argvoutgv,SvPVX(sv),SvCUR(sv),PL_inplace!=0, 680 O_WRONLY|O_CREAT|O_TRUNC,0,Nullfp)) 681 #else 682 if (!do_open(PL_argvoutgv,SvPVX(sv),SvCUR(sv),PL_inplace!=0, 683 O_WRONLY|O_CREAT|OPEN_EXCL,0666,Nullfp)) 684 #endif 685 { 686 if (ckWARN_d(WARN_INPLACE)) 687 Perl_warner(aTHX_ WARN_INPLACE, "Can't do inplace edit on %s: %s", 688 PL_oldname, Strerror(errno) ); 689 do_close(gv,FALSE); 690 continue; 691 } 692 setdefout(PL_argvoutgv); 693 PL_lastfd = PerlIO_fileno(IoIFP(GvIOp(PL_argvoutgv))); 694 (void)PerlLIO_fstat(PL_lastfd,&PL_statbuf); 695 #ifdef HAS_FCHMOD 696 (void)fchmod(PL_lastfd,PL_filemode); 697 #else 698 # if !(defined(WIN32) && defined(__BORLANDC__)) 699 /* Borland runtime creates a readonly file! */ 700 (void)PerlLIO_chmod(PL_oldname,PL_filemode); 701 # endif 702 #endif 703 if (fileuid != PL_statbuf.st_uid || filegid != PL_statbuf.st_gid) { 704 #ifdef HAS_FCHOWN 705 (void)fchown(PL_lastfd,fileuid,filegid); 706 #else 707 #ifdef HAS_CHOWN 708 (void)PerlLIO_chown(PL_oldname,fileuid,filegid); 709 #endif 710 #endif 711 } 712 } 713 return IoIFP(GvIOp(gv)); 714 } 715 else { 716 if (ckWARN_d(WARN_INPLACE)) { 717 int eno = errno; 718 if (PerlLIO_stat(PL_oldname, &PL_statbuf) >= 0 719 && !S_ISREG(PL_statbuf.st_mode)) 720 { 721 Perl_warner(aTHX_ WARN_INPLACE, 722 "Can't do inplace edit: %s is not a regular file", 723 PL_oldname); 724 } 725 else 726 Perl_warner(aTHX_ WARN_INPLACE, "Can't open %s: %s", 727 PL_oldname, Strerror(eno)); 728 } 729 } 730 } 731 if (io && (IoFLAGS(io) & IOf_ARGV)) 732 IoFLAGS(io) |= IOf_START; 733 if (PL_inplace) { 734 (void)do_close(PL_argvoutgv,FALSE); 735 if (io && (IoFLAGS(io) & IOf_ARGV) 736 && PL_argvout_stack && AvFILLp(PL_argvout_stack) >= 0) 737 { 738 GV *oldout = (GV*)av_pop(PL_argvout_stack); 739 setdefout(oldout); 740 SvREFCNT_dec(oldout); 741 return Nullfp; 742 } 743 setdefout(gv_fetchpv("STDOUT",TRUE,SVt_PVIO)); 744 } 745 return Nullfp; 746 } 747 748 #ifdef HAS_PIPE 749 void 750 Perl_do_pipe(pTHX_ SV *sv, GV *rgv, GV *wgv) 751 { 752 register IO *rstio; 753 register IO *wstio; 754 int fd[2]; 755 756 if (!rgv) 757 goto badexit; 758 if (!wgv) 759 goto badexit; 760 761 rstio = GvIOn(rgv); 762 wstio = GvIOn(wgv); 763 764 if (IoIFP(rstio)) 765 do_close(rgv,FALSE); 766 if (IoIFP(wstio)) 767 do_close(wgv,FALSE); 768 769 if (PerlProc_pipe(fd) < 0) 770 goto badexit; 771 IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"); 772 IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"); 773 IoIFP(wstio) = IoOFP(wstio); 774 IoTYPE(rstio) = IoTYPE_RDONLY; 775 IoTYPE(wstio) = IoTYPE_WRONLY; 776 if (!IoIFP(rstio) || !IoOFP(wstio)) { 777 if (IoIFP(rstio)) PerlIO_close(IoIFP(rstio)); 778 else PerlLIO_close(fd[0]); 779 if (IoOFP(wstio)) PerlIO_close(IoOFP(wstio)); 780 else PerlLIO_close(fd[1]); 781 goto badexit; 782 } 783 784 sv_setsv(sv,&PL_sv_yes); 785 return; 786 787 badexit: 788 sv_setsv(sv,&PL_sv_undef); 789 return; 790 } 791 #endif 792 793 /* explicit renamed to avoid C++ conflict -- kja */ 794 bool 795 Perl_do_close(pTHX_ GV *gv, bool not_implicit) 796 { 797 bool retval; 798 IO *io; 799 800 if (!gv) 801 gv = PL_argvgv; 802 if (!gv || SvTYPE(gv) != SVt_PVGV) { 803 if (not_implicit) 804 SETERRNO(EBADF,SS$_IVCHAN); 805 return FALSE; 806 } 807 io = GvIO(gv); 808 if (!io) { /* never opened */ 809 if (not_implicit) { 810 if (ckWARN(WARN_UNOPENED)) /* no check for closed here */ 811 report_evil_fh(gv, io, PL_op->op_type); 812 SETERRNO(EBADF,SS$_IVCHAN); 813 } 814 return FALSE; 815 } 816 retval = io_close(io, not_implicit); 817 if (not_implicit) { 818 IoLINES(io) = 0; 819 IoPAGE(io) = 0; 820 IoLINES_LEFT(io) = IoPAGE_LEN(io); 821 } 822 IoTYPE(io) = IoTYPE_CLOSED; 823 return retval; 824 } 825 826 bool 827 Perl_io_close(pTHX_ IO *io, bool not_implicit) 828 { 829 bool retval = FALSE; 830 int status; 831 832 if (IoIFP(io)) { 833 if (IoTYPE(io) == IoTYPE_PIPE) { 834 status = PerlProc_pclose(IoIFP(io)); 835 if (not_implicit) { 836 STATUS_NATIVE_SET(status); 837 retval = (STATUS_POSIX == 0); 838 } 839 else { 840 retval = (status != -1); 841 } 842 } 843 else if (IoTYPE(io) == IoTYPE_STD) 844 retval = TRUE; 845 else { 846 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) { /* a socket */ 847 retval = (PerlIO_close(IoOFP(io)) != EOF); 848 PerlIO_close(IoIFP(io)); /* clear stdio, fd already closed */ 849 } 850 else 851 retval = (PerlIO_close(IoIFP(io)) != EOF); 852 } 853 IoOFP(io) = IoIFP(io) = Nullfp; 854 } 855 else if (not_implicit) { 856 SETERRNO(EBADF,SS$_IVCHAN); 857 } 858 859 return retval; 860 } 861 862 bool 863 Perl_do_eof(pTHX_ GV *gv) 864 { 865 register IO *io; 866 int ch; 867 868 io = GvIO(gv); 869 870 if (!io) 871 return TRUE; 872 else if (ckWARN(WARN_IO) 873 && (IoTYPE(io) == IoTYPE_WRONLY || IoIFP(io) == PerlIO_stdout() 874 || IoIFP(io) == PerlIO_stderr())) 875 { 876 /* integrate to report_evil_fh()? */ 877 char *name = NULL; 878 if (isGV(gv)) { 879 SV* sv = sv_newmortal(); 880 gv_efullname4(sv, gv, Nullch, FALSE); 881 name = SvPV_nolen(sv); 882 } 883 if (name && *name) 884 Perl_warner(aTHX_ WARN_IO, 885 "Filehandle %s opened only for output", name); 886 else 887 Perl_warner(aTHX_ WARN_IO, 888 "Filehandle opened only for output"); 889 } 890 891 while (IoIFP(io)) { 892 893 if (PerlIO_has_cntptr(IoIFP(io))) { /* (the code works without this) */ 894 if (PerlIO_get_cnt(IoIFP(io)) > 0) /* cheat a little, since */ 895 return FALSE; /* this is the most usual case */ 896 } 897 898 ch = PerlIO_getc(IoIFP(io)); 899 if (ch != EOF) { 900 (void)PerlIO_ungetc(IoIFP(io),ch); 901 return FALSE; 902 } 903 if (PerlIO_has_cntptr(IoIFP(io)) && PerlIO_canset_cnt(IoIFP(io))) { 904 if (PerlIO_get_cnt(IoIFP(io)) < -1) 905 PerlIO_set_cnt(IoIFP(io),-1); 906 } 907 if (PL_op->op_flags & OPf_SPECIAL) { /* not necessarily a real EOF yet? */ 908 if (!nextargv(PL_argvgv)) /* get another fp handy */ 909 return TRUE; 910 } 911 else 912 return TRUE; /* normal fp, definitely end of file */ 913 } 914 return TRUE; 915 } 916 917 Off_t 918 Perl_do_tell(pTHX_ GV *gv) 919 { 920 register IO *io; 921 register PerlIO *fp; 922 923 if (gv && (io = GvIO(gv)) && (fp = IoIFP(io))) { 924 #ifdef ULTRIX_STDIO_BOTCH 925 if (PerlIO_eof(fp)) 926 (void)PerlIO_seek(fp, 0L, 2); /* ultrix 1.2 workaround */ 927 #endif 928 return PerlIO_tell(fp); 929 } 930 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) 931 report_evil_fh(gv, io, PL_op->op_type); 932 SETERRNO(EBADF,RMS$_IFI); 933 return (Off_t)-1; 934 } 935 936 bool 937 Perl_do_seek(pTHX_ GV *gv, Off_t pos, int whence) 938 { 939 register IO *io; 940 register PerlIO *fp; 941 942 if (gv && (io = GvIO(gv)) && (fp = IoIFP(io))) { 943 #ifdef ULTRIX_STDIO_BOTCH 944 if (PerlIO_eof(fp)) 945 (void)PerlIO_seek(fp, 0L, 2); /* ultrix 1.2 workaround */ 946 #endif 947 return PerlIO_seek(fp, pos, whence) >= 0; 948 } 949 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) 950 report_evil_fh(gv, io, PL_op->op_type); 951 SETERRNO(EBADF,RMS$_IFI); 952 return FALSE; 953 } 954 955 Off_t 956 Perl_do_sysseek(pTHX_ GV *gv, Off_t pos, int whence) 957 { 958 register IO *io; 959 register PerlIO *fp; 960 961 if (gv && (io = GvIO(gv)) && (fp = IoIFP(io))) 962 return PerlLIO_lseek(PerlIO_fileno(fp), pos, whence); 963 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) 964 report_evil_fh(gv, io, PL_op->op_type); 965 SETERRNO(EBADF,RMS$_IFI); 966 return (Off_t)-1; 967 } 968 969 int 970 Perl_mode_from_discipline(pTHX_ SV *discp) 971 { 972 int mode = O_BINARY; 973 if (discp) { 974 STRLEN len; 975 char *s = SvPV(discp,len); 976 while (*s) { 977 if (*s == ':') { 978 switch (s[1]) { 979 case 'r': 980 if (len > 3 && strnEQ(s+1, "raw", 3) 981 && (!s[4] || s[4] == ':' || isSPACE(s[4]))) 982 { 983 mode = O_BINARY; 984 s += 4; 985 len -= 4; 986 break; 987 } 988 /* FALL THROUGH */ 989 case 'c': 990 if (len > 4 && strnEQ(s+1, "crlf", 4) 991 && (!s[5] || s[5] == ':' || isSPACE(s[5]))) 992 { 993 mode = O_TEXT; 994 s += 5; 995 len -= 5; 996 break; 997 } 998 /* FALL THROUGH */ 999 default: 1000 goto fail_discipline; 1001 } 1002 } 1003 else if (isSPACE(*s)) { 1004 ++s; 1005 --len; 1006 } 1007 else { 1008 char *end; 1009 fail_discipline: 1010 end = strchr(s+1, ':'); 1011 if (!end) 1012 end = s+len; 1013 Perl_croak(aTHX_ "Unknown discipline '%.*s'", end-s, s); 1014 } 1015 } 1016 } 1017 return mode; 1018 } 1019 1020 int 1021 Perl_do_binmode(pTHX_ PerlIO *fp, int iotype, int mode) 1022 { 1023 #ifdef DOSISH 1024 # if defined(atarist) || defined(__MINT__) 1025 if (!PerlIO_flush(fp)) { 1026 if (mode & O_BINARY) 1027 ((FILE*)fp)->_flag |= _IOBIN; 1028 else 1029 ((FILE*)fp)->_flag &= ~ _IOBIN; 1030 return 1; 1031 } 1032 return 0; 1033 # else 1034 if (PerlLIO_setmode(PerlIO_fileno(fp), mode) != -1) { 1035 # if defined(WIN32) && defined(__BORLANDC__) 1036 /* The translation mode of the stream is maintained independent 1037 * of the translation mode of the fd in the Borland RTL (heavy 1038 * digging through their runtime sources reveal). User has to 1039 * set the mode explicitly for the stream (though they don't 1040 * document this anywhere). GSAR 97-5-24 1041 */ 1042 PerlIO_seek(fp,0L,0); 1043 if (mode & O_BINARY) 1044 ((FILE*)fp)->flags |= _F_BIN; 1045 else 1046 ((FILE*)fp)->flags &= ~ _F_BIN; 1047 # endif 1048 return 1; 1049 } 1050 else 1051 return 0; 1052 # endif 1053 #else 1054 # if defined(USEMYBINMODE) 1055 if (my_binmode(fp, iotype, mode) != FALSE) 1056 return 1; 1057 else 1058 return 0; 1059 # else 1060 return 1; 1061 # endif 1062 #endif 1063 } 1064 1065 #if !defined(HAS_TRUNCATE) && !defined(HAS_CHSIZE) && defined(F_FREESP) 1066 /* code courtesy of William Kucharski */ 1067 #define HAS_CHSIZE 1068 1069 I32 my_chsize(fd, length) 1070 I32 fd; /* file descriptor */ 1071 Off_t length; /* length to set file to */ 1072 { 1073 struct flock fl; 1074 struct stat filebuf; 1075 1076 if (PerlLIO_fstat(fd, &filebuf) < 0) 1077 return -1; 1078 1079 if (filebuf.st_size < length) { 1080 1081 /* extend file length */ 1082 1083 if ((PerlLIO_lseek(fd, (length - 1), 0)) < 0) 1084 return -1; 1085 1086 /* write a "0" byte */ 1087 1088 if ((PerlLIO_write(fd, "", 1)) != 1) 1089 return -1; 1090 } 1091 else { 1092 /* truncate length */ 1093 1094 fl.l_whence = 0; 1095 fl.l_len = 0; 1096 fl.l_start = length; 1097 fl.l_type = F_WRLCK; /* write lock on file space */ 1098 1099 /* 1100 * This relies on the UNDOCUMENTED F_FREESP argument to 1101 * fcntl(2), which truncates the file so that it ends at the 1102 * position indicated by fl.l_start. 1103 * 1104 * Will minor miracles never cease? 1105 */ 1106 1107 if (fcntl(fd, F_FREESP, &fl) < 0) 1108 return -1; 1109 1110 } 1111 1112 return 0; 1113 } 1114 #endif /* F_FREESP */ 1115 1116 bool 1117 Perl_do_print(pTHX_ register SV *sv, PerlIO *fp) 1118 { 1119 register char *tmps; 1120 STRLEN len; 1121 1122 /* assuming fp is checked earlier */ 1123 if (!sv) 1124 return TRUE; 1125 if (PL_ofmt) { 1126 if (SvGMAGICAL(sv)) 1127 mg_get(sv); 1128 if (SvIOK(sv) && SvIVX(sv) != 0) { 1129 PerlIO_printf(fp, PL_ofmt, (NV)SvIVX(sv)); 1130 return !PerlIO_error(fp); 1131 } 1132 if ( (SvNOK(sv) && SvNVX(sv) != 0.0) 1133 || (looks_like_number(sv) && sv_2nv(sv) != 0.0) ) { 1134 PerlIO_printf(fp, PL_ofmt, SvNVX(sv)); 1135 return !PerlIO_error(fp); 1136 } 1137 } 1138 switch (SvTYPE(sv)) { 1139 case SVt_NULL: 1140 if (ckWARN(WARN_UNINITIALIZED)) 1141 report_uninit(); 1142 return TRUE; 1143 case SVt_IV: 1144 if (SvIOK(sv)) { 1145 if (SvGMAGICAL(sv)) 1146 mg_get(sv); 1147 if (SvIsUV(sv)) 1148 PerlIO_printf(fp, "%"UVuf, (UV)SvUVX(sv)); 1149 else 1150 PerlIO_printf(fp, "%"IVdf, (IV)SvIVX(sv)); 1151 return !PerlIO_error(fp); 1152 } 1153 /* FALL THROUGH */ 1154 default: 1155 tmps = SvPV(sv, len); 1156 break; 1157 } 1158 /* To detect whether the process is about to overstep its 1159 * filesize limit we would need getrlimit(). We could then 1160 * also transparently raise the limit with setrlimit() -- 1161 * but only until the system hard limit/the filesystem limit, 1162 * at which we would get EPERM. Note that when using buffered 1163 * io the write failure can be delayed until the flush/close. --jhi */ 1164 if (len && (PerlIO_write(fp,tmps,len) == 0)) 1165 return FALSE; 1166 return !PerlIO_error(fp); 1167 } 1168 1169 I32 1170 Perl_my_stat(pTHX) 1171 { 1172 dSP; 1173 IO *io; 1174 GV* gv; 1175 1176 if (PL_op->op_flags & OPf_REF) { 1177 EXTEND(SP,1); 1178 gv = cGVOP_gv; 1179 do_fstat: 1180 io = GvIO(gv); 1181 if (io && IoIFP(io)) { 1182 PL_statgv = gv; 1183 sv_setpv(PL_statname,""); 1184 PL_laststype = OP_STAT; 1185 return (PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache)); 1186 } 1187 else { 1188 if (gv == PL_defgv) 1189 return PL_laststatval; 1190 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) 1191 report_evil_fh(gv, io, PL_op->op_type); 1192 PL_statgv = Nullgv; 1193 sv_setpv(PL_statname,""); 1194 return (PL_laststatval = -1); 1195 } 1196 } 1197 else { 1198 SV* sv = POPs; 1199 char *s; 1200 STRLEN n_a; 1201 PUTBACK; 1202 if (SvTYPE(sv) == SVt_PVGV) { 1203 gv = (GV*)sv; 1204 goto do_fstat; 1205 } 1206 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) { 1207 gv = (GV*)SvRV(sv); 1208 goto do_fstat; 1209 } 1210 1211 s = SvPV(sv, n_a); 1212 PL_statgv = Nullgv; 1213 sv_setpv(PL_statname, s); 1214 PL_laststype = OP_STAT; 1215 PL_laststatval = PerlLIO_stat(s, &PL_statcache); 1216 if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && strchr(s, '\n')) 1217 Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "stat"); 1218 return PL_laststatval; 1219 } 1220 } 1221 1222 I32 1223 Perl_my_lstat(pTHX) 1224 { 1225 dSP; 1226 SV *sv; 1227 STRLEN n_a; 1228 if (PL_op->op_flags & OPf_REF) { 1229 EXTEND(SP,1); 1230 if (cGVOP_gv == PL_defgv) { 1231 if (PL_laststype != OP_LSTAT) 1232 Perl_croak(aTHX_ "The stat preceding -l _ wasn't an lstat"); 1233 return PL_laststatval; 1234 } 1235 Perl_croak(aTHX_ "You can't use -l on a filehandle"); 1236 } 1237 1238 PL_laststype = OP_LSTAT; 1239 PL_statgv = Nullgv; 1240 sv = POPs; 1241 PUTBACK; 1242 sv_setpv(PL_statname,SvPV(sv, n_a)); 1243 PL_laststatval = PerlLIO_lstat(SvPV(sv, n_a),&PL_statcache); 1244 if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, n_a), '\n')) 1245 Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "lstat"); 1246 return PL_laststatval; 1247 } 1248 1249 bool 1250 Perl_do_aexec(pTHX_ SV *really, register SV **mark, register SV **sp) 1251 { 1252 return do_aexec5(really, mark, sp, 0, 0); 1253 } 1254 1255 bool 1256 Perl_do_aexec5(pTHX_ SV *really, register SV **mark, register SV **sp, 1257 int fd, int do_report) 1258 { 1259 #ifdef MACOS_TRADITIONAL 1260 Perl_croak(aTHX_ "exec? I'm not *that* kind of operating system"); 1261 #else 1262 register char **a; 1263 char *tmps; 1264 STRLEN n_a; 1265 1266 if (sp > mark) { 1267 New(401,PL_Argv, sp - mark + 1, char*); 1268 a = PL_Argv; 1269 while (++mark <= sp) { 1270 if (*mark) 1271 *a++ = SvPVx(*mark, n_a); 1272 else 1273 *a++ = ""; 1274 } 1275 *a = Nullch; 1276 if (really) 1277 tmps = SvPV(really, n_a); 1278 if ((!really && *PL_Argv[0] != '/') || 1279 (really && *tmps != '/')) /* will execvp use PATH? */ 1280 TAINT_ENV(); /* testing IFS here is overkill, probably */ 1281 if (really && *tmps) 1282 PerlProc_execvp(tmps,EXEC_ARGV_CAST(PL_Argv)); 1283 else 1284 PerlProc_execvp(PL_Argv[0],EXEC_ARGV_CAST(PL_Argv)); 1285 if (ckWARN(WARN_EXEC)) 1286 Perl_warner(aTHX_ WARN_EXEC, "Can't exec \"%s\": %s", 1287 (really ? tmps : PL_Argv[0]), Strerror(errno)); 1288 if (do_report) { 1289 int e = errno; 1290 1291 PerlLIO_write(fd, (void*)&e, sizeof(int)); 1292 PerlLIO_close(fd); 1293 } 1294 } 1295 do_execfree(); 1296 #endif 1297 return FALSE; 1298 } 1299 1300 void 1301 Perl_do_execfree(pTHX) 1302 { 1303 if (PL_Argv) { 1304 Safefree(PL_Argv); 1305 PL_Argv = Null(char **); 1306 } 1307 if (PL_Cmd) { 1308 Safefree(PL_Cmd); 1309 PL_Cmd = Nullch; 1310 } 1311 } 1312 1313 #if !defined(OS2) && !defined(WIN32) && !defined(DJGPP) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) 1314 1315 bool 1316 Perl_do_exec(pTHX_ char *cmd) 1317 { 1318 return do_exec3(cmd,0,0); 1319 } 1320 1321 bool 1322 Perl_do_exec3(pTHX_ char *cmd, int fd, int do_report) 1323 { 1324 register char **a; 1325 register char *s; 1326 char flags[10]; 1327 1328 while (*cmd && isSPACE(*cmd)) 1329 cmd++; 1330 1331 /* save an extra exec if possible */ 1332 1333 #ifdef CSH 1334 if (strnEQ(cmd,PL_cshname,PL_cshlen) && strnEQ(cmd+PL_cshlen," -c",3)) { 1335 strcpy(flags,"-c"); 1336 s = cmd+PL_cshlen+3; 1337 if (*s == 'f') { 1338 s++; 1339 strcat(flags,"f"); 1340 } 1341 if (*s == ' ') 1342 s++; 1343 if (*s++ == '\'') { 1344 char *ncmd = s; 1345 1346 while (*s) 1347 s++; 1348 if (s[-1] == '\n') 1349 *--s = '\0'; 1350 if (s[-1] == '\'') { 1351 *--s = '\0'; 1352 PerlProc_execl(PL_cshname,"csh", flags,ncmd,(char*)0); 1353 *s = '\''; 1354 return FALSE; 1355 } 1356 } 1357 } 1358 #endif /* CSH */ 1359 1360 /* see if there are shell metacharacters in it */ 1361 1362 if (*cmd == '.' && isSPACE(cmd[1])) 1363 goto doshell; 1364 1365 if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4])) 1366 goto doshell; 1367 1368 for (s = cmd; *s && isALNUM(*s); s++) ; /* catch VAR=val gizmo */ 1369 if (*s == '=') 1370 goto doshell; 1371 1372 for (s = cmd; *s; s++) { 1373 if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) { 1374 if (*s == '\n' && !s[1]) { 1375 *s = '\0'; 1376 break; 1377 } 1378 /* handle the 2>&1 construct at the end */ 1379 if (*s == '>' && s[1] == '&' && s[2] == '1' 1380 && s > cmd + 1 && s[-1] == '2' && isSPACE(s[-2]) 1381 && (!s[3] || isSPACE(s[3]))) 1382 { 1383 char *t = s + 3; 1384 1385 while (*t && isSPACE(*t)) 1386 ++t; 1387 if (!*t && (dup2(1,2) != -1)) { 1388 s[-2] = '\0'; 1389 break; 1390 } 1391 } 1392 doshell: 1393 PerlProc_execl(PL_sh_path, "sh", "-c", cmd, (char*)0); 1394 return FALSE; 1395 } 1396 } 1397 1398 New(402,PL_Argv, (s - cmd) / 2 + 2, char*); 1399 PL_Cmd = savepvn(cmd, s-cmd); 1400 a = PL_Argv; 1401 for (s = PL_Cmd; *s;) { 1402 while (*s && isSPACE(*s)) s++; 1403 if (*s) 1404 *(a++) = s; 1405 while (*s && !isSPACE(*s)) s++; 1406 if (*s) 1407 *s++ = '\0'; 1408 } 1409 *a = Nullch; 1410 if (PL_Argv[0]) { 1411 PerlProc_execvp(PL_Argv[0],PL_Argv); 1412 if (errno == ENOEXEC) { /* for system V NIH syndrome */ 1413 do_execfree(); 1414 goto doshell; 1415 } 1416 { 1417 int e = errno; 1418 1419 if (ckWARN(WARN_EXEC)) 1420 Perl_warner(aTHX_ WARN_EXEC, "Can't exec \"%s\": %s", 1421 PL_Argv[0], Strerror(errno)); 1422 if (do_report) { 1423 PerlLIO_write(fd, (void*)&e, sizeof(int)); 1424 PerlLIO_close(fd); 1425 } 1426 } 1427 } 1428 do_execfree(); 1429 return FALSE; 1430 } 1431 1432 #endif /* OS2 || WIN32 */ 1433 1434 I32 1435 Perl_apply(pTHX_ I32 type, register SV **mark, register SV **sp) 1436 { 1437 register I32 val; 1438 register I32 val2; 1439 register I32 tot = 0; 1440 char *what; 1441 char *s; 1442 SV **oldmark = mark; 1443 STRLEN n_a; 1444 1445 #define APPLY_TAINT_PROPER() \ 1446 STMT_START { \ 1447 if (PL_tainted) { TAINT_PROPER(what); } \ 1448 } STMT_END 1449 1450 /* This is a first heuristic; it doesn't catch tainting magic. */ 1451 if (PL_tainting) { 1452 while (++mark <= sp) { 1453 if (SvTAINTED(*mark)) { 1454 TAINT; 1455 break; 1456 } 1457 } 1458 mark = oldmark; 1459 } 1460 switch (type) { 1461 case OP_CHMOD: 1462 what = "chmod"; 1463 APPLY_TAINT_PROPER(); 1464 if (++mark <= sp) { 1465 val = SvIVx(*mark); 1466 APPLY_TAINT_PROPER(); 1467 tot = sp - mark; 1468 while (++mark <= sp) { 1469 char *name = SvPVx(*mark, n_a); 1470 APPLY_TAINT_PROPER(); 1471 if (PerlLIO_chmod(name, val)) 1472 tot--; 1473 } 1474 } 1475 break; 1476 #ifdef HAS_CHOWN 1477 case OP_CHOWN: 1478 what = "chown"; 1479 APPLY_TAINT_PROPER(); 1480 if (sp - mark > 2) { 1481 val = SvIVx(*++mark); 1482 val2 = SvIVx(*++mark); 1483 APPLY_TAINT_PROPER(); 1484 tot = sp - mark; 1485 while (++mark <= sp) { 1486 char *name = SvPVx(*mark, n_a); 1487 APPLY_TAINT_PROPER(); 1488 if (PerlLIO_chown(name, val, val2)) 1489 tot--; 1490 } 1491 } 1492 break; 1493 #endif 1494 /* 1495 XXX Should we make lchown() directly available from perl? 1496 For now, we'll let Configure test for HAS_LCHOWN, but do 1497 nothing in the core. 1498 --AD 5/1998 1499 */ 1500 #ifdef HAS_KILL 1501 case OP_KILL: 1502 what = "kill"; 1503 APPLY_TAINT_PROPER(); 1504 if (mark == sp) 1505 break; 1506 s = SvPVx(*++mark, n_a); 1507 if (isUPPER(*s)) { 1508 if (*s == 'S' && s[1] == 'I' && s[2] == 'G') 1509 s += 3; 1510 if (!(val = whichsig(s))) 1511 Perl_croak(aTHX_ "Unrecognized signal name \"%s\"",s); 1512 } 1513 else 1514 val = SvIVx(*mark); 1515 APPLY_TAINT_PROPER(); 1516 tot = sp - mark; 1517 #ifdef VMS 1518 /* kill() doesn't do process groups (job trees?) under VMS */ 1519 if (val < 0) val = -val; 1520 if (val == SIGKILL) { 1521 # include <starlet.h> 1522 /* Use native sys$delprc() to insure that target process is 1523 * deleted; supervisor-mode images don't pay attention to 1524 * CRTL's emulation of Unix-style signals and kill() 1525 */ 1526 while (++mark <= sp) { 1527 I32 proc = SvIVx(*mark); 1528 register unsigned long int __vmssts; 1529 APPLY_TAINT_PROPER(); 1530 if (!((__vmssts = sys$delprc(&proc,0)) & 1)) { 1531 tot--; 1532 switch (__vmssts) { 1533 case SS$_NONEXPR: 1534 case SS$_NOSUCHNODE: 1535 SETERRNO(ESRCH,__vmssts); 1536 break; 1537 case SS$_NOPRIV: 1538 SETERRNO(EPERM,__vmssts); 1539 break; 1540 default: 1541 SETERRNO(EVMSERR,__vmssts); 1542 } 1543 } 1544 } 1545 break; 1546 } 1547 #endif 1548 if (val < 0) { 1549 val = -val; 1550 while (++mark <= sp) { 1551 I32 proc = SvIVx(*mark); 1552 APPLY_TAINT_PROPER(); 1553 #ifdef HAS_KILLPG 1554 if (PerlProc_killpg(proc,val)) /* BSD */ 1555 #else 1556 if (PerlProc_kill(-proc,val)) /* SYSV */ 1557 #endif 1558 tot--; 1559 } 1560 } 1561 else { 1562 while (++mark <= sp) { 1563 I32 proc = SvIVx(*mark); 1564 APPLY_TAINT_PROPER(); 1565 if (PerlProc_kill(proc, val)) 1566 tot--; 1567 } 1568 } 1569 break; 1570 #endif 1571 case OP_UNLINK: 1572 what = "unlink"; 1573 APPLY_TAINT_PROPER(); 1574 tot = sp - mark; 1575 while (++mark <= sp) { 1576 s = SvPVx(*mark, n_a); 1577 APPLY_TAINT_PROPER(); 1578 if (PL_euid || PL_unsafe) { 1579 if (UNLINK(s)) 1580 tot--; 1581 } 1582 else { /* don't let root wipe out directories without -U */ 1583 if (PerlLIO_lstat(s,&PL_statbuf) < 0 || S_ISDIR(PL_statbuf.st_mode)) 1584 tot--; 1585 else { 1586 if (UNLINK(s)) 1587 tot--; 1588 } 1589 } 1590 } 1591 break; 1592 #ifdef HAS_UTIME 1593 case OP_UTIME: 1594 what = "utime"; 1595 APPLY_TAINT_PROPER(); 1596 if (sp - mark > 2) { 1597 #if defined(I_UTIME) || defined(VMS) 1598 struct utimbuf utbuf; 1599 #else 1600 struct { 1601 Time_t actime; 1602 Time_t modtime; 1603 } utbuf; 1604 #endif 1605 1606 Zero(&utbuf, sizeof utbuf, char); 1607 #ifdef BIG_TIME 1608 utbuf.actime = (Time_t)SvNVx(*++mark); /* time accessed */ 1609 utbuf.modtime = (Time_t)SvNVx(*++mark); /* time modified */ 1610 #else 1611 utbuf.actime = (Time_t)SvIVx(*++mark); /* time accessed */ 1612 utbuf.modtime = (Time_t)SvIVx(*++mark); /* time modified */ 1613 #endif 1614 APPLY_TAINT_PROPER(); 1615 tot = sp - mark; 1616 while (++mark <= sp) { 1617 char *name = SvPVx(*mark, n_a); 1618 APPLY_TAINT_PROPER(); 1619 if (PerlLIO_utime(name, &utbuf)) 1620 tot--; 1621 } 1622 } 1623 else 1624 tot = 0; 1625 break; 1626 #endif 1627 } 1628 return tot; 1629 1630 #undef APPLY_TAINT_PROPER 1631 } 1632 1633 /* Do the permissions allow some operation? Assumes statcache already set. */ 1634 #ifndef VMS /* VMS' cando is in vms.c */ 1635 bool 1636 Perl_cando(pTHX_ Mode_t mode, Uid_t effective, register Stat_t *statbufp) 1637 /* Note: we use `effective' both for uids and gids. 1638 * Here we are betting on Uid_t being equal or wider than Gid_t. */ 1639 { 1640 #ifdef DOSISH 1641 /* [Comments and code from Len Reed] 1642 * MS-DOS "user" is similar to UNIX's "superuser," but can't write 1643 * to write-protected files. The execute permission bit is set 1644 * by the Miscrosoft C library stat() function for the following: 1645 * .exe files 1646 * .com files 1647 * .bat files 1648 * directories 1649 * All files and directories are readable. 1650 * Directories and special files, e.g. "CON", cannot be 1651 * write-protected. 1652 * [Comment by Tom Dinger -- a directory can have the write-protect 1653 * bit set in the file system, but DOS permits changes to 1654 * the directory anyway. In addition, all bets are off 1655 * here for networked software, such as Novell and 1656 * Sun's PC-NFS.] 1657 */ 1658 1659 /* Atari stat() does pretty much the same thing. we set x_bit_set_in_stat 1660 * too so it will actually look into the files for magic numbers 1661 */ 1662 return (mode & statbufp->st_mode) ? TRUE : FALSE; 1663 1664 #else /* ! DOSISH */ 1665 if ((effective ? PL_euid : PL_uid) == 0) { /* root is special */ 1666 if (mode == S_IXUSR) { 1667 if (statbufp->st_mode & 0111 || S_ISDIR(statbufp->st_mode)) 1668 return TRUE; 1669 } 1670 else 1671 return TRUE; /* root reads and writes anything */ 1672 return FALSE; 1673 } 1674 if (statbufp->st_uid == (effective ? PL_euid : PL_uid) ) { 1675 if (statbufp->st_mode & mode) 1676 return TRUE; /* ok as "user" */ 1677 } 1678 else if (ingroup(statbufp->st_gid,effective)) { 1679 if (statbufp->st_mode & mode >> 3) 1680 return TRUE; /* ok as "group" */ 1681 } 1682 else if (statbufp->st_mode & mode >> 6) 1683 return TRUE; /* ok as "other" */ 1684 return FALSE; 1685 #endif /* ! DOSISH */ 1686 } 1687 #endif /* ! VMS */ 1688 1689 bool 1690 Perl_ingroup(pTHX_ Gid_t testgid, Uid_t effective) 1691 { 1692 #ifdef MACOS_TRADITIONAL 1693 /* This is simply not correct for AppleShare, but fix it yerself. */ 1694 return TRUE; 1695 #else 1696 if (testgid == (effective ? PL_egid : PL_gid)) 1697 return TRUE; 1698 #ifdef HAS_GETGROUPS 1699 #ifndef NGROUPS 1700 #define NGROUPS 32 1701 #endif 1702 { 1703 Groups_t gary[NGROUPS]; 1704 I32 anum; 1705 1706 anum = getgroups(NGROUPS,gary); 1707 while (--anum >= 0) 1708 if (gary[anum] == testgid) 1709 return TRUE; 1710 } 1711 #endif 1712 return FALSE; 1713 #endif 1714 } 1715 1716 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) 1717 1718 I32 1719 Perl_do_ipcget(pTHX_ I32 optype, SV **mark, SV **sp) 1720 { 1721 key_t key; 1722 I32 n, flags; 1723 1724 key = (key_t)SvNVx(*++mark); 1725 n = (optype == OP_MSGGET) ? 0 : SvIVx(*++mark); 1726 flags = SvIVx(*++mark); 1727 SETERRNO(0,0); 1728 switch (optype) 1729 { 1730 #ifdef HAS_MSG 1731 case OP_MSGGET: 1732 return msgget(key, flags); 1733 #endif 1734 #ifdef HAS_SEM 1735 case OP_SEMGET: 1736 return semget(key, n, flags); 1737 #endif 1738 #ifdef HAS_SHM 1739 case OP_SHMGET: 1740 return shmget(key, n, flags); 1741 #endif 1742 #if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM) 1743 default: 1744 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]); 1745 #endif 1746 } 1747 return -1; /* should never happen */ 1748 } 1749 1750 I32 1751 Perl_do_ipcctl(pTHX_ I32 optype, SV **mark, SV **sp) 1752 { 1753 SV *astr; 1754 char *a; 1755 I32 id, n, cmd, infosize, getinfo; 1756 I32 ret = -1; 1757 1758 id = SvIVx(*++mark); 1759 n = (optype == OP_SEMCTL) ? SvIVx(*++mark) : 0; 1760 cmd = SvIVx(*++mark); 1761 astr = *++mark; 1762 infosize = 0; 1763 getinfo = (cmd == IPC_STAT); 1764 1765 switch (optype) 1766 { 1767 #ifdef HAS_MSG 1768 case OP_MSGCTL: 1769 if (cmd == IPC_STAT || cmd == IPC_SET) 1770 infosize = sizeof(struct msqid_ds); 1771 break; 1772 #endif 1773 #ifdef HAS_SHM 1774 case OP_SHMCTL: 1775 if (cmd == IPC_STAT || cmd == IPC_SET) 1776 infosize = sizeof(struct shmid_ds); 1777 break; 1778 #endif 1779 #ifdef HAS_SEM 1780 case OP_SEMCTL: 1781 #ifdef Semctl 1782 if (cmd == IPC_STAT || cmd == IPC_SET) 1783 infosize = sizeof(struct semid_ds); 1784 else if (cmd == GETALL || cmd == SETALL) 1785 { 1786 struct semid_ds semds; 1787 union semun semun; 1788 #ifdef EXTRA_F_IN_SEMUN_BUF 1789 semun.buff = &semds; 1790 #else 1791 semun.buf = &semds; 1792 #endif 1793 getinfo = (cmd == GETALL); 1794 if (Semctl(id, 0, IPC_STAT, semun) == -1) 1795 return -1; 1796 infosize = semds.sem_nsems * sizeof(short); 1797 /* "short" is technically wrong but much more portable 1798 than guessing about u_?short(_t)? */ 1799 } 1800 #else 1801 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]); 1802 #endif 1803 break; 1804 #endif 1805 #if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM) 1806 default: 1807 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]); 1808 #endif 1809 } 1810 1811 if (infosize) 1812 { 1813 STRLEN len; 1814 if (getinfo) 1815 { 1816 SvPV_force(astr, len); 1817 a = SvGROW(astr, infosize+1); 1818 } 1819 else 1820 { 1821 a = SvPV(astr, len); 1822 if (len != infosize) 1823 Perl_croak(aTHX_ "Bad arg length for %s, is %lu, should be %ld", 1824 PL_op_desc[optype], 1825 (unsigned long)len, 1826 (long)infosize); 1827 } 1828 } 1829 else 1830 { 1831 IV i = SvIV(astr); 1832 a = INT2PTR(char *,i); /* ouch */ 1833 } 1834 SETERRNO(0,0); 1835 switch (optype) 1836 { 1837 #ifdef HAS_MSG 1838 case OP_MSGCTL: 1839 ret = msgctl(id, cmd, (struct msqid_ds *)a); 1840 break; 1841 #endif 1842 #ifdef HAS_SEM 1843 case OP_SEMCTL: { 1844 #ifdef Semctl 1845 union semun unsemds; 1846 1847 #ifdef EXTRA_F_IN_SEMUN_BUF 1848 unsemds.buff = (struct semid_ds *)a; 1849 #else 1850 unsemds.buf = (struct semid_ds *)a; 1851 #endif 1852 ret = Semctl(id, n, cmd, unsemds); 1853 #else 1854 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]); 1855 #endif 1856 } 1857 break; 1858 #endif 1859 #ifdef HAS_SHM 1860 case OP_SHMCTL: 1861 ret = shmctl(id, cmd, (struct shmid_ds *)a); 1862 break; 1863 #endif 1864 } 1865 if (getinfo && ret >= 0) { 1866 SvCUR_set(astr, infosize); 1867 *SvEND(astr) = '\0'; 1868 SvSETMAGIC(astr); 1869 } 1870 return ret; 1871 } 1872 1873 I32 1874 Perl_do_msgsnd(pTHX_ SV **mark, SV **sp) 1875 { 1876 #ifdef HAS_MSG 1877 SV *mstr; 1878 char *mbuf; 1879 I32 id, msize, flags; 1880 STRLEN len; 1881 1882 id = SvIVx(*++mark); 1883 mstr = *++mark; 1884 flags = SvIVx(*++mark); 1885 mbuf = SvPV(mstr, len); 1886 if ((msize = len - sizeof(long)) < 0) 1887 Perl_croak(aTHX_ "Arg too short for msgsnd"); 1888 SETERRNO(0,0); 1889 return msgsnd(id, (struct msgbuf *)mbuf, msize, flags); 1890 #else 1891 Perl_croak(aTHX_ "msgsnd not implemented"); 1892 #endif 1893 } 1894 1895 I32 1896 Perl_do_msgrcv(pTHX_ SV **mark, SV **sp) 1897 { 1898 #ifdef HAS_MSG 1899 SV *mstr; 1900 char *mbuf; 1901 long mtype; 1902 I32 id, msize, flags, ret; 1903 STRLEN len; 1904 1905 id = SvIVx(*++mark); 1906 mstr = *++mark; 1907 /* suppress warning when reading into undef var --jhi */ 1908 if (! SvOK(mstr)) 1909 sv_setpvn(mstr, "", 0); 1910 msize = SvIVx(*++mark); 1911 mtype = (long)SvIVx(*++mark); 1912 flags = SvIVx(*++mark); 1913 SvPV_force(mstr, len); 1914 mbuf = SvGROW(mstr, sizeof(long)+msize+1); 1915 1916 SETERRNO(0,0); 1917 ret = msgrcv(id, (struct msgbuf *)mbuf, msize, mtype, flags); 1918 if (ret >= 0) { 1919 SvCUR_set(mstr, sizeof(long)+ret); 1920 *SvEND(mstr) = '\0'; 1921 #ifndef INCOMPLETE_TAINTS 1922 /* who knows who has been playing with this message? */ 1923 SvTAINTED_on(mstr); 1924 #endif 1925 } 1926 return ret; 1927 #else 1928 Perl_croak(aTHX_ "msgrcv not implemented"); 1929 #endif 1930 } 1931 1932 I32 1933 Perl_do_semop(pTHX_ SV **mark, SV **sp) 1934 { 1935 #ifdef HAS_SEM 1936 SV *opstr; 1937 char *opbuf; 1938 I32 id; 1939 STRLEN opsize; 1940 1941 id = SvIVx(*++mark); 1942 opstr = *++mark; 1943 opbuf = SvPV(opstr, opsize); 1944 if (opsize < sizeof(struct sembuf) 1945 || (opsize % sizeof(struct sembuf)) != 0) { 1946 SETERRNO(EINVAL,LIB$_INVARG); 1947 return -1; 1948 } 1949 SETERRNO(0,0); 1950 return semop(id, (struct sembuf *)opbuf, opsize/sizeof(struct sembuf)); 1951 #else 1952 Perl_croak(aTHX_ "semop not implemented"); 1953 #endif 1954 } 1955 1956 I32 1957 Perl_do_shmio(pTHX_ I32 optype, SV **mark, SV **sp) 1958 { 1959 #ifdef HAS_SHM 1960 SV *mstr; 1961 char *mbuf, *shm; 1962 I32 id, mpos, msize; 1963 STRLEN len; 1964 struct shmid_ds shmds; 1965 1966 id = SvIVx(*++mark); 1967 mstr = *++mark; 1968 mpos = SvIVx(*++mark); 1969 msize = SvIVx(*++mark); 1970 SETERRNO(0,0); 1971 if (shmctl(id, IPC_STAT, &shmds) == -1) 1972 return -1; 1973 if (mpos < 0 || msize < 0 || mpos + msize > shmds.shm_segsz) { 1974 SETERRNO(EFAULT,SS$_ACCVIO); /* can't do as caller requested */ 1975 return -1; 1976 } 1977 shm = (char *)shmat(id, (char*)NULL, (optype == OP_SHMREAD) ? SHM_RDONLY : 0); 1978 if (shm == (char *)-1) /* I hate System V IPC, I really do */ 1979 return -1; 1980 if (optype == OP_SHMREAD) { 1981 /* suppress warning when reading into undef var (tchrist 3/Mar/00) */ 1982 if (! SvOK(mstr)) 1983 sv_setpvn(mstr, "", 0); 1984 SvPV_force(mstr, len); 1985 mbuf = SvGROW(mstr, msize+1); 1986 1987 Copy(shm + mpos, mbuf, msize, char); 1988 SvCUR_set(mstr, msize); 1989 *SvEND(mstr) = '\0'; 1990 SvSETMAGIC(mstr); 1991 #ifndef INCOMPLETE_TAINTS 1992 /* who knows who has been playing with this shared memory? */ 1993 SvTAINTED_on(mstr); 1994 #endif 1995 } 1996 else { 1997 I32 n; 1998 1999 mbuf = SvPV(mstr, len); 2000 if ((n = len) > msize) 2001 n = msize; 2002 Copy(mbuf, shm + mpos, n, char); 2003 if (n < msize) 2004 memzero(shm + mpos + n, msize - n); 2005 } 2006 return shmdt(shm); 2007 #else 2008 Perl_croak(aTHX_ "shm I/O not implemented"); 2009 #endif 2010 } 2011 2012 #endif /* SYSV IPC */ 2013 2014