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