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