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