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