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