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