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