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