This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Removed the ifdefs for INCOMPLETE_TAINTS
[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))) {
8903cb82 1055 return PerlIO_tell(fp);
96e4d5b1 1056 }
51087808 1057 report_evil_fh(gv);
93189314 1058 SETERRNO(EBADF,RMS_IFI);
5ff3f7a4 1059 return (Off_t)-1;
a687059c
LW
1060}
1061
1062bool
864dbfa3 1063Perl_do_seek(pTHX_ GV *gv, Off_t pos, int whence)
a687059c 1064{
97aff369 1065 dVAR;
9c9f25b8 1066 IO *const io = GvIO(gv);
eb578fdb 1067 PerlIO *fp;
a687059c 1068
9c9f25b8 1069 if (io && (fp = IoIFP(io))) {
8903cb82 1070 return PerlIO_seek(fp, pos, whence) >= 0;
137443ea 1071 }
51087808 1072 report_evil_fh(gv);
93189314 1073 SETERRNO(EBADF,RMS_IFI);
a687059c
LW
1074 return FALSE;
1075}
1076
97cc44eb 1077Off_t
864dbfa3 1078Perl_do_sysseek(pTHX_ GV *gv, Off_t pos, int whence)
8903cb82 1079{
97aff369 1080 dVAR;
9c9f25b8 1081 IO *const io = GvIO(gv);
eb578fdb 1082 PerlIO *fp;
8903cb82 1083
7918f24d
NC
1084 PERL_ARGS_ASSERT_DO_SYSSEEK;
1085
9c9f25b8 1086 if (io && (fp = IoIFP(io)))
3028581b 1087 return PerlLIO_lseek(PerlIO_fileno(fp), pos, whence);
51087808 1088 report_evil_fh(gv);
93189314 1089 SETERRNO(EBADF,RMS_IFI);
d9b3e12d 1090 return (Off_t)-1;
8903cb82
PP
1091}
1092
6ff81951 1093int
a79b25b7 1094Perl_mode_from_discipline(pTHX_ const char *s, STRLEN len)
16fe6d59
GS
1095{
1096 int mode = O_BINARY;
a79b25b7 1097 if (s) {
16fe6d59
GS
1098 while (*s) {
1099 if (*s == ':') {
1100 switch (s[1]) {
1101 case 'r':
e963d6d2 1102 if (s[2] == 'a' && s[3] == 'w'
16fe6d59
GS
1103 && (!s[4] || s[4] == ':' || isSPACE(s[4])))
1104 {
1105 mode = O_BINARY;
1106 s += 4;
1107 len -= 4;
1108 break;
1109 }
1110 /* FALL THROUGH */
1111 case 'c':
e963d6d2 1112 if (s[2] == 'r' && s[3] == 'l' && s[4] == 'f'
16fe6d59
GS
1113 && (!s[5] || s[5] == ':' || isSPACE(s[5])))
1114 {
1115 mode = O_TEXT;
1116 s += 5;
1117 len -= 5;
1118 break;
1119 }
1120 /* FALL THROUGH */
1121 default:
1122 goto fail_discipline;
1123 }
1124 }
1125 else if (isSPACE(*s)) {
1126 ++s;
1127 --len;
1128 }
1129 else {
4373e329 1130 const char *end;
16fe6d59
GS
1131fail_discipline:
1132 end = strchr(s+1, ':');
1133 if (!end)
1134 end = s+len;
60382766 1135#ifndef PERLIO_LAYERS
363c40c4 1136 Perl_croak(aTHX_ "IO layers (like '%.*s') unavailable", end-s, s);
60382766 1137#else
18a33fb5 1138 len -= end-s;
60382766
NIS
1139 s = end;
1140#endif
16fe6d59
GS
1141 }
1142 }
1143 }
1144 return mode;
1145}
1146
58e24eff 1147#if !defined(HAS_TRUNCATE) && !defined(HAS_CHSIZE)
27da23d5
JH
1148I32
1149my_chsize(int fd, Off_t length)
6eb13c3b 1150{
58e24eff
SH
1151#ifdef F_FREESP
1152 /* code courtesy of William Kucharski */
1153#define HAS_CHSIZE
1154
c623ac67 1155 Stat_t filebuf;
6eb13c3b 1156
3028581b 1157 if (PerlLIO_fstat(fd, &filebuf) < 0)
6eb13c3b
LW
1158 return -1;
1159
1160 if (filebuf.st_size < length) {
1161
1162 /* extend file length */
1163
3028581b 1164 if ((PerlLIO_lseek(fd, (length - 1), 0)) < 0)
6eb13c3b
LW
1165 return -1;
1166
1167 /* write a "0" byte */
1168
3028581b 1169 if ((PerlLIO_write(fd, "", 1)) != 1)
6eb13c3b
LW
1170 return -1;
1171 }
1172 else {
1173 /* truncate length */
35da51f7 1174 struct flock fl;
6eb13c3b
LW
1175 fl.l_whence = 0;
1176 fl.l_len = 0;
1177 fl.l_start = length;
a0d0e21e 1178 fl.l_type = F_WRLCK; /* write lock on file space */
6eb13c3b
LW
1179
1180 /*
a0d0e21e 1181 * This relies on the UNDOCUMENTED F_FREESP argument to
6eb13c3b
LW
1182 * fcntl(2), which truncates the file so that it ends at the
1183 * position indicated by fl.l_start.
1184 *
1185 * Will minor miracles never cease?
1186 */
1187
a0d0e21e 1188 if (fcntl(fd, F_FREESP, &fl) < 0)
6eb13c3b
LW
1189 return -1;
1190
1191 }
6eb13c3b 1192 return 0;
58e24eff 1193#else
27da23d5 1194 Perl_croak_nocontext("truncate not implemented");
a0d0e21e 1195#endif /* F_FREESP */
27da23d5 1196 return -1;
58e24eff
SH
1197}
1198#endif /* !HAS_TRUNCATE && !HAS_CHSIZE */
ff8e2863 1199
a687059c 1200bool
5aaab254 1201Perl_do_print(pTHX_ SV *sv, PerlIO *fp)
a687059c 1202{
97aff369 1203 dVAR;
7918f24d
NC
1204
1205 PERL_ARGS_ASSERT_DO_PRINT;
1206
79072805
LW
1207 /* assuming fp is checked earlier */
1208 if (!sv)
1209 return TRUE;
e9950d3b
NC
1210 if (SvTYPE(sv) == SVt_IV && SvIOK(sv)) {
1211 assert(!SvGMAGICAL(sv));
1212 if (SvIsUV(sv))
1213 PerlIO_printf(fp, "%"UVuf, (UV)SvUVX(sv));
1214 else
1215 PerlIO_printf(fp, "%"IVdf, (IV)SvIVX(sv));
1216 return !PerlIO_error(fp);
1217 }
1218 else {
1219 STRLEN len;
676f44e7 1220 /* Do this first to trigger any overloading. */
e9950d3b
NC
1221 const char *tmps = SvPV_const(sv, len);
1222 U8 *tmpbuf = NULL;
1223 bool happy = TRUE;
1224
d791f93f
KW
1225 if (PerlIO_isutf8(fp)) { /* If the stream is utf8 ... */
1226 if (!SvUTF8(sv)) { /* Convert to utf8 if necessary */
676f44e7
NC
1227 /* We don't modify the original scalar. */
1228 tmpbuf = bytes_to_utf8((const U8*) tmps, &len);
1229 tmps = (char *) tmpbuf;
1230 }
a099aed4 1231 else if (ckWARN4_d(WARN_UTF8, WARN_SURROGATE, WARN_NON_UNICODE, WARN_NONCHAR)) {
0876b9a0
KW
1232 (void) check_utf8_print((const U8*) tmps, len);
1233 }
d791f93f
KW
1234 } /* else stream isn't utf8 */
1235 else if (DO_UTF8(sv)) { /* But if is utf8 internally, attempt to
1236 convert to bytes */
676f44e7
NC
1237 STRLEN tmplen = len;
1238 bool utf8 = TRUE;
35da51f7 1239 U8 * const result = bytes_from_utf8((const U8*) tmps, &tmplen, &utf8);
676f44e7 1240 if (!utf8) {
d791f93f
KW
1241
1242 /* Here, succeeded in downgrading from utf8. Set up to below
1243 * output the converted value */
676f44e7
NC
1244 tmpbuf = result;
1245 tmps = (char *) tmpbuf;
1246 len = tmplen;
1247 }
d791f93f
KW
1248 else { /* Non-utf8 output stream, but string only representable in
1249 utf8 */
676f44e7 1250 assert((char *)result == tmps);
9b387841 1251 Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8),
21630838
FC
1252 "Wide character in %s",
1253 PL_op ? OP_DESC(PL_op) : "print"
1254 );
0876b9a0
KW
1255 /* Could also check that isn't one of the things to avoid
1256 * in utf8 by using check_utf8_print(), but not doing so,
1257 * since the stream isn't a UTF8 stream */
ae798467
NIS
1258 }
1259 }
e9950d3b
NC
1260 /* To detect whether the process is about to overstep its
1261 * filesize limit we would need getrlimit(). We could then
1262 * also transparently raise the limit with setrlimit() --
1263 * but only until the system hard limit/the filesystem limit,
1264 * at which we would get EPERM. Note that when using buffered
1265 * io the write failure can be delayed until the flush/close. --jhi */
1266 if (len && (PerlIO_write(fp,tmps,len) == 0))
1267 happy = FALSE;
1268 Safefree(tmpbuf);
1269 return happy ? !PerlIO_error(fp) : FALSE;
ff8e2863 1270 }
a687059c
LW
1271}
1272
79072805 1273I32
0d7d409d 1274Perl_my_stat_flags(pTHX_ const U32 flags)
a687059c 1275{
97aff369 1276 dVAR;
39644a26 1277 dSP;
79072805 1278 IO *io;
2dd78f96 1279 GV* gv;
79072805 1280
533c011a 1281 if (PL_op->op_flags & OPf_REF) {
2dd78f96 1282 gv = cGVOP_gv;
748a9306 1283 do_fstat:
5228a96c
SP
1284 if (gv == PL_defgv)
1285 return PL_laststatval;
2dd78f96 1286 io = GvIO(gv);
ad02613c 1287 do_fstat_have_io:
5228a96c 1288 PL_laststype = OP_STAT;
bd5f6c01 1289 PL_statgv = gv ? gv : (GV *)io;
76f68e9b 1290 sv_setpvs(PL_statname, "");
5228a96c
SP
1291 if(io) {
1292 if (IoIFP(io)) {
1293 return (PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache));
1294 } else if (IoDIRP(io)) {
3497a01f 1295 return (PL_laststatval = PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache));
5228a96c 1296 }
5228a96c 1297 }
3888144c
FC
1298 PL_laststatval = -1;
1299 report_evil_fh(gv);
1300 return -1;
a687059c 1301 }
d2c4d2d1 1302 else if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t))
8db8f6b6
FC
1303 == OPpFT_STACKED)
1304 return PL_laststatval;
d2c4d2d1
FC
1305 else {
1306 SV* const sv = TOPs;
4373e329 1307 const char *s;
4ecd490c 1308 STRLEN len;
094a3eec 1309 if ((gv = MAYBE_DEREF_GV_flags(sv,flags))) {
748a9306
LW
1310 goto do_fstat;
1311 }
ad02613c 1312 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
a45c7426 1313 io = MUTABLE_IO(SvRV(sv));
7f39519f 1314 gv = NULL;
ad02613c
SP
1315 goto do_fstat_have_io;
1316 }
748a9306 1317
0d7d409d 1318 s = SvPV_flags_const(sv, len, flags);
a0714e2c 1319 PL_statgv = NULL;
4ecd490c 1320 sv_setpvn(PL_statname, s, len);
95a20fc0 1321 s = SvPVX_const(PL_statname); /* s now NUL-terminated */
3280af22
NIS
1322 PL_laststype = OP_STAT;
1323 PL_laststatval = PerlLIO_stat(s, &PL_statcache);
ce44635a 1324 if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && strchr(s, '\n'))
9014280d 1325 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
3280af22 1326 return PL_laststatval;
a687059c
LW
1327 }
1328}
1329
fbb0b3b3 1330
79072805 1331I32
0d7d409d 1332Perl_my_lstat_flags(pTHX_ const U32 flags)
c623bd54 1333{
97aff369 1334 dVAR;
a1894d81 1335 static const char* const no_prev_lstat = "The stat preceding -l _ wasn't an lstat";
39644a26 1336 dSP;
b16276bb 1337 const char *file;
cd22fad3 1338 SV* const sv = TOPs;
5840701a 1339 bool isio = FALSE;
533c011a 1340 if (PL_op->op_flags & OPf_REF) {
638eceb6 1341 if (cGVOP_gv == PL_defgv) {
3280af22 1342 if (PL_laststype != OP_LSTAT)
0157ef98 1343 Perl_croak(aTHX_ "%s", no_prev_lstat);
3280af22 1344 return PL_laststatval;
fe14fcc3 1345 }
31b139ba 1346 PL_laststatval = -1;
5d3e98de 1347 if (ckWARN(WARN_IO)) {
5840701a 1348 /* diag_listed_as: Use of -l on filehandle%s */
d0c0e7dd
FC
1349 Perl_warner(aTHX_ packWARN(WARN_IO),
1350 "Use of -l on filehandle %"HEKf,
1351 HEKfARG(GvENAME_HEK(cGVOP_gv)));
5d3e98de 1352 }
31b139ba 1353 return -1;
fe14fcc3 1354 }
8db8f6b6
FC
1355 if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t))
1356 == OPpFT_STACKED) {
1f26655e 1357 if (PL_laststype != OP_LSTAT)
0157ef98 1358 Perl_croak(aTHX_ "%s", no_prev_lstat);
1f26655e 1359 return PL_laststatval;
cd22fad3 1360 }
c623bd54 1361
3280af22 1362 PL_laststype = OP_LSTAT;
a0714e2c 1363 PL_statgv = NULL;
5840701a
FC
1364 if ( ( (SvROK(sv) && ( isGV_with_GP(SvRV(sv))
1365 || (isio = SvTYPE(SvRV(sv)) == SVt_PVIO) )
1366 )
1367 || isGV_with_GP(sv)
1368 )
1369 && ckWARN(WARN_IO)) {
1370 if (isio)
1371 /* diag_listed_as: Use of -l on filehandle%s */
1372 Perl_warner(aTHX_ packWARN(WARN_IO),
1373 "Use of -l on filehandle");
1374 else
1375 /* diag_listed_as: Use of -l on filehandle%s */
1376 Perl_warner(aTHX_ packWARN(WARN_IO),
1377 "Use of -l on filehandle %"HEKf,
1378 GvENAME_HEK((const GV *)
1379 (SvROK(sv) ? SvRV(sv) : sv)));
cd22fad3
RS
1380 }
1381 file = SvPV_flags_const_nolen(sv, flags);
b16276bb
VP
1382 sv_setpv(PL_statname,file);
1383 PL_laststatval = PerlLIO_lstat(file,&PL_statcache);
1384 if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && strchr(file, '\n'))
9014280d 1385 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "lstat");
3280af22 1386 return PL_laststatval;
c623bd54
LW
1387}
1388
a0f2c8ec
JD
1389static void
1390S_exec_failed(pTHX_ const char *cmd, int fd, int do_report)
1391{
1392 const int e = errno;
7918f24d 1393 PERL_ARGS_ASSERT_EXEC_FAILED;
a0f2c8ec
JD
1394 if (ckWARN(WARN_EXEC))
1395 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't exec \"%s\": %s",
1396 cmd, Strerror(e));
1397 if (do_report) {
1398 PerlLIO_write(fd, (void*)&e, sizeof(int));
1399 PerlLIO_close(fd);
1400 }
1401}
1402
d5a9bfb0 1403bool
5aaab254 1404Perl_do_aexec5(pTHX_ SV *really, SV **mark, SV **sp,
2aa1486d 1405 int fd, int do_report)
d5a9bfb0 1406{
27da23d5 1407 dVAR;
7918f24d 1408 PERL_ARGS_ASSERT_DO_AEXEC5;
e37778c2 1409#if defined(__SYMBIAN32__) || defined(__LIBCATAMOUNT__)
cd39f2b6
JH
1410 Perl_croak(aTHX_ "exec? I'm not *that* kind of operating system");
1411#else
79072805 1412 if (sp > mark) {
360ea906 1413 const char **a;
6136c704 1414 const char *tmps = NULL;
360ea906 1415 Newx(PL_Argv, sp - mark + 1, const char*);
c3c5fad7 1416 a = PL_Argv;
890ce7af 1417
79072805
LW
1418 while (++mark <= sp) {
1419 if (*mark)
360ea906 1420 *a++ = SvPV_nolen_const(*mark);
a687059c
LW
1421 else
1422 *a++ = "";
1423 }
6136c704 1424 *a = NULL;
91b2752f 1425 if (really)
e62f0680 1426 tmps = SvPV_nolen_const(really);
91b2752f
RG
1427 if ((!really && *PL_Argv[0] != '/') ||
1428 (really && *tmps != '/')) /* will execvp use PATH? */
79072805 1429 TAINT_ENV(); /* testing IFS here is overkill, probably */
b35112e7 1430 PERL_FPU_PRE_EXEC
91b2752f 1431 if (really && *tmps)
b4748376 1432 PerlProc_execvp(tmps,EXEC_ARGV_CAST(PL_Argv));
a687059c 1433 else
b4748376 1434 PerlProc_execvp(PL_Argv[0],EXEC_ARGV_CAST(PL_Argv));
b35112e7 1435 PERL_FPU_POST_EXEC
a0f2c8ec 1436 S_exec_failed(aTHX_ (really ? tmps : PL_Argv[0]), fd, do_report);
a687059c 1437 }
bee1dbe2 1438 do_execfree();
cd39f2b6 1439#endif
a687059c
LW
1440 return FALSE;
1441}
1442
fe14fcc3 1443void
864dbfa3 1444Perl_do_execfree(pTHX)
ff8e2863 1445{
97aff369 1446 dVAR;
43c5f42d 1447 Safefree(PL_Argv);
4608196e 1448 PL_Argv = NULL;
43c5f42d 1449 Safefree(PL_Cmd);
bd61b366 1450 PL_Cmd = NULL;
ff8e2863
LW
1451}
1452
9555a685 1453#ifdef PERL_DEFAULT_DO_EXEC3_IMPLEMENTATION
e446cec8
IZ
1454
1455bool
2fbb330f 1456Perl_do_exec3(pTHX_ const char *incmd, int fd, int do_report)
e446cec8 1457{
27da23d5 1458 dVAR;
eb578fdb
KW
1459 const char **a;
1460 char *s;
15db3ae2 1461 char *buf;
2fbb330f 1462 char *cmd;
2fbb330f 1463 /* Make a copy so we can change it */
6fca0082 1464 const Size_t cmdlen = strlen(incmd) + 1;
7918f24d
NC
1465
1466 PERL_ARGS_ASSERT_DO_EXEC3;
1467
15db3ae2
DM
1468 Newx(buf, cmdlen, char);
1469 cmd = buf;
cfff9797 1470 memcpy(cmd, incmd, cmdlen);
a687059c 1471
748a9306
LW
1472 while (*cmd && isSPACE(*cmd))
1473 cmd++;
1474
a687059c
LW
1475 /* save an extra exec if possible */
1476
bf38876a 1477#ifdef CSH
d05c1ba0 1478 {
0c19750d 1479 char flags[PERL_FLAGS_MAX];
d05c1ba0
JH
1480 if (strnEQ(cmd,PL_cshname,PL_cshlen) &&
1481 strnEQ(cmd+PL_cshlen," -c",3)) {
28f0d0ec 1482 my_strlcpy(flags, "-c", PERL_FLAGS_MAX);
d05c1ba0
JH
1483 s = cmd+PL_cshlen+3;
1484 if (*s == 'f') {
1485 s++;
28f0d0ec 1486 my_strlcat(flags, "f", PERL_FLAGS_MAX - 2);
d05c1ba0
JH
1487 }
1488 if (*s == ' ')
1489 s++;
1490 if (*s++ == '\'') {
0bcc34c2 1491 char * const ncmd = s;
d05c1ba0
JH
1492
1493 while (*s)
1494 s++;
1495 if (s[-1] == '\n')
1496 *--s = '\0';
1497 if (s[-1] == '\'') {
1498 *--s = '\0';
b35112e7 1499 PERL_FPU_PRE_EXEC
7c0dd7ca 1500 PerlProc_execl(PL_cshname, "csh", flags, ncmd, (char*)NULL);
b35112e7 1501 PERL_FPU_POST_EXEC
d05c1ba0 1502 *s = '\'';
a0f2c8ec 1503 S_exec_failed(aTHX_ PL_cshname, fd, do_report);
15db3ae2 1504 Safefree(buf);
d05c1ba0
JH
1505 return FALSE;
1506 }
1507 }
a687059c
LW
1508 }
1509 }
bf38876a 1510#endif /* CSH */
a687059c
LW
1511
1512 /* see if there are shell metacharacters in it */
1513
748a9306
LW
1514 if (*cmd == '.' && isSPACE(cmd[1]))
1515 goto doshell;
1516
1517 if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
1518 goto doshell;
1519
294b3b39 1520 s = cmd;
0eb30aeb 1521 while (isWORDCHAR(*s))
294b3b39 1522 s++; /* catch VAR=val gizmo */
63f2c1e1
LW
1523 if (*s == '=')
1524 goto doshell;
748a9306 1525
a687059c 1526 for (s = cmd; *s; s++) {
d05c1ba0
JH
1527 if (*s != ' ' && !isALPHA(*s) &&
1528 strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
a687059c
LW
1529 if (*s == '\n' && !s[1]) {
1530 *s = '\0';
1531 break;
1532 }
603a98b0
IZ
1533 /* handle the 2>&1 construct at the end */
1534 if (*s == '>' && s[1] == '&' && s[2] == '1'
1535 && s > cmd + 1 && s[-1] == '2' && isSPACE(s[-2])
1536 && (!s[3] || isSPACE(s[3])))
1537 {
6867be6d 1538 const char *t = s + 3;
603a98b0
IZ
1539
1540 while (*t && isSPACE(*t))
1541 ++t;
943bbd07 1542 if (!*t && (PerlLIO_dup2(1,2) != -1)) {
603a98b0
IZ
1543 s[-2] = '\0';
1544 break;
1545 }
1546 }
a687059c 1547 doshell:
b35112e7 1548 PERL_FPU_PRE_EXEC
7c0dd7ca 1549 PerlProc_execl(PL_sh_path, "sh", "-c", cmd, (char *)NULL);
b35112e7 1550 PERL_FPU_POST_EXEC
a0f2c8ec 1551 S_exec_failed(aTHX_ PL_sh_path, fd, do_report);
15db3ae2 1552 Safefree(buf);
a687059c
LW
1553 return FALSE;
1554 }
1555 }
748a9306 1556
360ea906 1557 Newx(PL_Argv, (s - cmd) / 2 + 2, const char*);
3280af22
NIS
1558 PL_Cmd = savepvn(cmd, s-cmd);
1559 a = PL_Argv;
1560 for (s = PL_Cmd; *s;) {
294b3b39
AL
1561 while (isSPACE(*s))
1562 s++;
a687059c
LW
1563 if (*s)
1564 *(a++) = s;
294b3b39
AL
1565 while (*s && !isSPACE(*s))
1566 s++;
a687059c
LW
1567 if (*s)
1568 *s++ = '\0';
1569 }
6136c704 1570 *a = NULL;
3280af22 1571 if (PL_Argv[0]) {
b35112e7 1572 PERL_FPU_PRE_EXEC
360ea906 1573 PerlProc_execvp(PL_Argv[0],EXEC_ARGV_CAST(PL_Argv));
b35112e7 1574 PERL_FPU_POST_EXEC
b1248f16 1575 if (errno == ENOEXEC) { /* for system V NIH syndrome */
ff8e2863 1576 do_execfree();
a687059c 1577 goto doshell;
b1248f16 1578 }
a0f2c8ec 1579 S_exec_failed(aTHX_ PL_Argv[0], fd, do_report);
a687059c 1580 }
ff8e2863 1581 do_execfree();
15db3ae2 1582 Safefree(buf);
a687059c
LW
1583 return FALSE;
1584}
1585
6890e559 1586#endif /* OS2 || WIN32 */
760ac839 1587
25bbd826
CB
1588#ifdef VMS
1589#include <starlet.h> /* for sys$delprc */
1590#endif
1591
79072805 1592I32
5aaab254 1593Perl_apply(pTHX_ I32 type, SV **mark, SV **sp)
a687059c 1594{
97aff369 1595 dVAR;
eb578fdb
KW
1596 I32 val;
1597 I32 tot = 0;
4634a855 1598 const char *const what = PL_op_name[type];
5c144d81 1599 const char *s;
84c7b88c 1600 STRLEN len;
890ce7af 1601 SV ** const oldmark = mark;
885b4b39 1602 bool killgp = FALSE;
a687059c 1603
7918f24d
NC
1604 PERL_ARGS_ASSERT_APPLY;
1605
9a9b5ec9
DM
1606 PERL_UNUSED_VAR(what); /* may not be used depending on compile options */
1607
1444765e
NC
1608 /* Doing this ahead of the switch statement preserves the old behaviour,
1609 where attempting to use kill as a taint test test would fail on
1610 platforms where kill was not defined. */
1611#ifndef HAS_KILL
1612 if (type == OP_KILL)
4634a855 1613 Perl_die(aTHX_ PL_no_func, what);
1444765e
NC
1614#endif
1615#ifndef HAS_CHOWN
1616 if (type == OP_CHOWN)
4634a855 1617 Perl_die(aTHX_ PL_no_func, what);
1444765e
NC
1618#endif
1619
1620
20408e3c 1621#define APPLY_TAINT_PROPER() \
3280af22 1622 STMT_START { \
284167a5 1623 if (TAINT_get) { TAINT_PROPER(what); } \
873ef191 1624 } STMT_END
20408e3c
GS
1625
1626 /* This is a first heuristic; it doesn't catch tainting magic. */
284167a5 1627 if (TAINTING_get) {
463ee0b2 1628 while (++mark <= sp) {
bbce6d69
PP
1629 if (SvTAINTED(*mark)) {
1630 TAINT;
1631 break;
1632 }
463ee0b2
LW
1633 }
1634 mark = oldmark;
1635 }
a687059c 1636 switch (type) {
79072805 1637 case OP_CHMOD:
20408e3c 1638 APPLY_TAINT_PROPER();
79072805 1639 if (++mark <= sp) {
4ea561bc 1640 val = SvIV(*mark);
20408e3c
GS
1641 APPLY_TAINT_PROPER();
1642 tot = sp - mark;
79072805 1643 while (++mark <= sp) {
c4aca7d0 1644 GV* gv;
2ea1cce7 1645 if ((gv = MAYBE_DEREF_GV(*mark))) {
c4aca7d0
GA
1646 if (GvIO(gv) && IoIFP(GvIOp(gv))) {
1647#ifdef HAS_FCHMOD
1648 APPLY_TAINT_PROPER();
1649 if (fchmod(PerlIO_fileno(IoIFP(GvIOn(gv))), val))
1650 tot--;
1651#else
b9c6780e 1652 Perl_die(aTHX_ PL_no_func, "fchmod");
c4aca7d0
GA
1653#endif
1654 }
1655 else {
1656 tot--;
1657 }
1658 }
c4aca7d0 1659 else {
41188aa0 1660 const char *name = SvPV_nomg_const(*mark, len);
c4aca7d0 1661 APPLY_TAINT_PROPER();
41188aa0 1662 if (!IS_SAFE_PATHNAME(name, len, "chmod") ||
c8028aa6
TC
1663 PerlLIO_chmod(name, val)) {
1664 tot--;
1665 }
c4aca7d0 1666 }
a687059c
LW
1667 }
1668 }
1669 break;
fe14fcc3 1670#ifdef HAS_CHOWN
79072805 1671 case OP_CHOWN:
20408e3c 1672 APPLY_TAINT_PROPER();
79072805 1673 if (sp - mark > 2) {
eb578fdb 1674 I32 val2;
463ee0b2
LW
1675 val = SvIVx(*++mark);
1676 val2 = SvIVx(*++mark);
20408e3c 1677 APPLY_TAINT_PROPER();
a0d0e21e 1678 tot = sp - mark;
79072805 1679 while (++mark <= sp) {
c4aca7d0 1680 GV* gv;
2ea1cce7 1681 if ((gv = MAYBE_DEREF_GV(*mark))) {
c4aca7d0
GA
1682 if (GvIO(gv) && IoIFP(GvIOp(gv))) {
1683#ifdef HAS_FCHOWN
1684 APPLY_TAINT_PROPER();
1685 if (fchown(PerlIO_fileno(IoIFP(GvIOn(gv))), val, val2))
1686 tot--;
1687#else
b9c6780e 1688 Perl_die(aTHX_ PL_no_func, "fchown");
c4aca7d0
GA
1689#endif
1690 }
1691 else {
1692 tot--;
1693 }
1694 }
c4aca7d0 1695 else {
41188aa0 1696 const char *name = SvPV_nomg_const(*mark, len);
c4aca7d0 1697 APPLY_TAINT_PROPER();
41188aa0 1698 if (!IS_SAFE_PATHNAME(name, len, "chown") ||
c8028aa6 1699 PerlLIO_chown(name, val, val2)) {
c4aca7d0 1700 tot--;
c8028aa6 1701 }
c4aca7d0 1702 }
a687059c
LW
1703 }
1704 }
1705 break;
b1248f16 1706#endif
a1d180c4 1707/*
dd64f1c3
AD
1708XXX Should we make lchown() directly available from perl?
1709For now, we'll let Configure test for HAS_LCHOWN, but do
1710nothing in the core.
1711 --AD 5/1998
1712*/
fe14fcc3 1713#ifdef HAS_KILL
79072805 1714 case OP_KILL:
20408e3c 1715 APPLY_TAINT_PROPER();
55497cff
PP
1716 if (mark == sp)
1717 break;
84c7b88c 1718 s = SvPVx_const(*++mark, len);
c2fd40cb
DM
1719 if (*s == '-' && isALPHA(s[1]))
1720 {
1721 s++;
1722 len--;
885b4b39 1723 killgp = TRUE;
c2fd40cb 1724 }
e02bfb16 1725 if (isALPHA(*s)) {
84c7b88c 1726 if (*s == 'S' && s[1] == 'I' && s[2] == 'G') {
79072805 1727 s += 3;
84c7b88c
BF
1728 len -= 3;
1729 }
1730 if ((val = whichsig_pvn(s, len)) < 0)
1731 Perl_croak(aTHX_ "Unrecognized signal name \"%"SVf"\"", SVfARG(*mark));
79072805
LW
1732 }
1733 else
c2fd40cb 1734 {
4ea561bc 1735 val = SvIV(*mark);
c2fd40cb
DM
1736 if (val < 0)
1737 {
885b4b39 1738 killgp = TRUE;
c2fd40cb
DM
1739 val = -val;
1740 }
1741 }
20408e3c
GS
1742 APPLY_TAINT_PROPER();
1743 tot = sp - mark;
3595fcef
PP
1744#ifdef VMS
1745 /* kill() doesn't do process groups (job trees?) under VMS */
3595fcef 1746 if (val == SIGKILL) {
3595fcef
PP
1747 /* Use native sys$delprc() to insure that target process is
1748 * deleted; supervisor-mode images don't pay attention to
1749 * CRTL's emulation of Unix-style signals and kill()
1750 */
1751 while (++mark <= sp) {
5f521955 1752 I32 proc;
eb578fdb 1753 unsigned long int __vmssts;
8af710eb 1754 SvGETMAGIC(*mark);
e2c0f81f
DG
1755 if (!(SvIOK(*mark) || SvNOK(*mark) || looks_like_number(*mark)))
1756 Perl_croak(aTHX_ "Can't kill a non-numeric process ID");
8af710eb 1757 proc = SvIV_nomg(*mark);
20408e3c 1758 APPLY_TAINT_PROPER();
3595fcef
PP
1759 if (!((__vmssts = sys$delprc(&proc,0)) & 1)) {
1760 tot--;
1761 switch (__vmssts) {
1762 case SS$_NONEXPR:
1763 case SS$_NOSUCHNODE:
1764 SETERRNO(ESRCH,__vmssts);
1765 break;
1766 case SS$_NOPRIV:
1767 SETERRNO(EPERM,__vmssts);
1768 break;
1769 default:
1770 SETERRNO(EVMSERR,__vmssts);
1771 }
1772 }
1773 }
8165faea 1774 PERL_ASYNC_CHECK();
3595fcef
PP
1775 break;
1776 }
1777#endif
c2fd40cb 1778 while (++mark <= sp) {
60082291 1779 Pid_t proc;
c2fd40cb 1780 SvGETMAGIC(*mark);
60082291 1781 if (!(SvNIOK(*mark) || looks_like_number(*mark)))
c2fd40cb
DM
1782 Perl_croak(aTHX_ "Can't kill a non-numeric process ID");
1783 proc = SvIV_nomg(*mark);
1784 if (killgp)
1785 {
1786 proc = -proc;
a687059c 1787 }
c2fd40cb
DM
1788 APPLY_TAINT_PROPER();
1789 if (PerlProc_kill(proc, val))
1790 tot--;
a687059c 1791 }
8165faea 1792 PERL_ASYNC_CHECK();
a687059c 1793 break;
b1248f16 1794#endif
79072805 1795 case OP_UNLINK:
20408e3c 1796 APPLY_TAINT_PROPER();
79072805
LW
1797 tot = sp - mark;
1798 while (++mark <= sp) {
41188aa0 1799 s = SvPV_const(*mark, len);
20408e3c 1800 APPLY_TAINT_PROPER();
41188aa0 1801 if (!IS_SAFE_PATHNAME(s, len, "unlink")) {
c8028aa6
TC
1802 tot--;
1803 }
1804 else if (PerlProc_geteuid() || PL_unsafe) {
b8ffc8df 1805 if (UNLINK(s))
a687059c
LW
1806 tot--;
1807 }
1808 else { /* don't let root wipe out directories without -U */
3280af22 1809 if (PerlLIO_lstat(s,&PL_statbuf) < 0 || S_ISDIR(PL_statbuf.st_mode))
a687059c
LW
1810 tot--;
1811 else {
b8ffc8df 1812 if (UNLINK(s))
a687059c
LW
1813 tot--;
1814 }
1815 }
1816 }
1817 break;
e96b369d 1818#if defined(HAS_UTIME) || defined(HAS_FUTIMES)
79072805 1819 case OP_UTIME:
20408e3c 1820 APPLY_TAINT_PROPER();
79072805 1821 if (sp - mark > 2) {
e96b369d
GA
1822#if defined(HAS_FUTIMES)
1823 struct timeval utbuf[2];
1824 void *utbufp = utbuf;
1825#elif defined(I_UTIME) || defined(VMS)
663a0e37 1826 struct utimbuf utbuf;
07409e01 1827 struct utimbuf *utbufp = &utbuf;
663a0e37 1828#else
a687059c 1829 struct {
dd2821f6
GS
1830 Time_t actime;
1831 Time_t modtime;
a687059c 1832 } utbuf;
07409e01 1833 void *utbufp = &utbuf;
663a0e37 1834#endif
a687059c 1835
0bcc34c2
AL
1836 SV* const accessed = *++mark;
1837 SV* const modified = *++mark;
c6f7b413 1838
6ec06612
SB
1839 /* Be like C, and if both times are undefined, let the C
1840 * library figure out what to do. This usually means
1841 * "current time". */
c6f7b413
RS
1842
1843 if ( accessed == &PL_sv_undef && modified == &PL_sv_undef )
6ec06612
SB
1844 utbufp = NULL;
1845 else {
1846 Zero(&utbuf, sizeof utbuf, char);
e96b369d 1847#ifdef HAS_FUTIMES
4ea561bc 1848 utbuf[0].tv_sec = (long)SvIV(accessed); /* time accessed */
e96b369d 1849 utbuf[0].tv_usec = 0;
4ea561bc 1850 utbuf[1].tv_sec = (long)SvIV(modified); /* time modified */
e96b369d
GA
1851 utbuf[1].tv_usec = 0;
1852#elif defined(BIG_TIME)
4ea561bc
NC
1853 utbuf.actime = (Time_t)SvNV(accessed); /* time accessed */
1854 utbuf.modtime = (Time_t)SvNV(modified); /* time modified */
517844ec 1855#else
4ea561bc
NC
1856 utbuf.actime = (Time_t)SvIV(accessed); /* time accessed */
1857 utbuf.modtime = (Time_t)SvIV(modified); /* time modified */
517844ec 1858#endif
6ec06612 1859 }
4373e329 1860 APPLY_TAINT_PROPER();
79072805
LW
1861 tot = sp - mark;
1862 while (++mark <= sp) {
e96b369d 1863 GV* gv;
64617da9 1864 if ((gv = MAYBE_DEREF_GV(*mark))) {
e96b369d
GA
1865 if (GvIO(gv) && IoIFP(GvIOp(gv))) {
1866#ifdef HAS_FUTIMES
1867 APPLY_TAINT_PROPER();
8b7231d9
SP
1868 if (futimes(PerlIO_fileno(IoIFP(GvIOn(gv))),
1869 (struct timeval *) utbufp))
e96b369d
GA
1870 tot--;
1871#else
1872 Perl_die(aTHX_ PL_no_func, "futimes");
1873#endif
1874 }
1875 else {
1876 tot--;
1877 }
1878 }
e96b369d 1879 else {
41188aa0 1880 const char * const name = SvPV_nomg_const(*mark, len);
e96b369d 1881 APPLY_TAINT_PROPER();
41188aa0 1882 if (!IS_SAFE_PATHNAME(name, len, "utime")) {
c8028aa6
TC
1883 tot--;
1884 }
1885 else
e96b369d 1886#ifdef HAS_FUTIMES
8b7231d9 1887 if (utimes(name, (struct timeval *)utbufp))
e96b369d
GA
1888#else
1889 if (PerlLIO_utime(name, utbufp))
1890#endif
1891 tot--;
1892 }
1893
a687059c 1894 }
a687059c
LW
1895 }
1896 else
79072805 1897 tot = 0;
a687059c 1898 break;
a0d0e21e 1899#endif
a687059c
LW
1900 }
1901 return tot;
20408e3c 1902
20408e3c 1903#undef APPLY_TAINT_PROPER
a687059c
LW
1904}
1905
1906/* Do the permissions allow some operation? Assumes statcache already set. */
a0d0e21e 1907#ifndef VMS /* VMS' cando is in vms.c */
7f4774ae 1908bool
5aaab254 1909Perl_cando(pTHX_ Mode_t mode, bool effective, const Stat_t *statbufp)
ae1951c1
NC
1910/* effective is a flag, true for EUID, or for checking if the effective gid
1911 * is in the list of groups returned from getgroups().
1912 */
a687059c 1913{
97aff369 1914 dVAR;
7918f24d
NC
1915
1916 PERL_ARGS_ASSERT_CANDO;
1917
bee1dbe2 1918#ifdef DOSISH
fe14fcc3
LW
1919 /* [Comments and code from Len Reed]
1920 * MS-DOS "user" is similar to UNIX's "superuser," but can't write
1921 * to write-protected files. The execute permission bit is set
486ec47a 1922 * by the Microsoft C library stat() function for the following:
fe14fcc3
LW
1923 * .exe files
1924 * .com files
1925 * .bat files
1926 * directories
1927 * All files and directories are readable.
1928 * Directories and special files, e.g. "CON", cannot be
1929 * write-protected.
1930 * [Comment by Tom Dinger -- a directory can have the write-protect
1931 * bit set in the file system, but DOS permits changes to
1932 * the directory anyway. In addition, all bets are off
1933 * here for networked software, such as Novell and
1934 * Sun's PC-NFS.]
1935 */
1936
bee1dbe2
LW
1937 /* Atari stat() does pretty much the same thing. we set x_bit_set_in_stat
1938 * too so it will actually look into the files for magic numbers
1939 */
7f4774ae 1940 return (mode & statbufp->st_mode) ? TRUE : FALSE;
fe14fcc3 1941
55497cff 1942#else /* ! DOSISH */
b595cd4b
RU
1943# ifdef __CYGWIN__
1944 if (ingroup(544,effective)) { /* member of Administrators */
1945# else
985213f2 1946 if ((effective ? PerlProc_geteuid() : PerlProc_getuid()) == 0) { /* root is special */
b595cd4b 1947# endif
7f4774ae 1948 if (mode == S_IXUSR) {
c623bd54 1949 if (statbufp->st_mode & 0111 || S_ISDIR(statbufp->st_mode))
a687059c
LW
1950 return TRUE;
1951 }
1952 else
1953 return TRUE; /* root reads and writes anything */
1954 return FALSE;
1955 }
985213f2 1956 if (statbufp->st_uid == (effective ? PerlProc_geteuid() : PerlProc_getuid()) ) {
7f4774ae 1957 if (statbufp->st_mode & mode)
a687059c
LW
1958 return TRUE; /* ok as "user" */
1959 }
d8eceb89 1960 else if (ingroup(statbufp->st_gid,effective)) {
7f4774ae 1961 if (statbufp->st_mode & mode >> 3)
a687059c
LW
1962 return TRUE; /* ok as "group" */
1963 }
7f4774ae 1964 else if (statbufp->st_mode & mode >> 6)
a687059c
LW
1965 return TRUE; /* ok as "other" */
1966 return FALSE;
55497cff 1967#endif /* ! DOSISH */
a687059c 1968}
a0d0e21e 1969#endif /* ! VMS */
a687059c 1970
1f676739 1971static bool
0da8eb3a 1972S_ingroup(pTHX_ Gid_t testgid, bool effective)
a687059c 1973{
97aff369 1974 dVAR;
985213f2 1975 if (testgid == (effective ? PerlProc_getegid() : PerlProc_getgid()))
a687059c 1976 return TRUE;
fe14fcc3 1977#ifdef HAS_GETGROUPS
a687059c 1978 {
331b57bc 1979 Groups_t *gary = NULL;
79072805 1980 I32 anum;
331b57bc 1981 bool rc = FALSE;
a687059c 1982
331b57bc
SP
1983 anum = getgroups(0, gary);
1984 Newx(gary, anum, Groups_t);
1985 anum = getgroups(anum, gary);
a687059c 1986 while (--anum >= 0)
331b57bc
SP
1987 if (gary[anum] == testgid) {
1988 rc = TRUE;
1989 break;
1990 }
1991
1992 Safefree(gary);
1993 return rc;
a687059c 1994 }
c685562b 1995#else
a687059c 1996 return FALSE;
cd39f2b6 1997#endif
a687059c 1998}
c2ab57d4 1999
fe14fcc3 2000#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
c2ab57d4 2001
79072805 2002I32
864dbfa3 2003Perl_do_ipcget(pTHX_ I32 optype, SV **mark, SV **sp)
c2ab57d4 2004{
97aff369 2005 dVAR;
0bcc34c2 2006 const key_t key = (key_t)SvNVx(*++mark);
c3312966 2007 SV *nsv = optype == OP_MSGGET ? NULL : *++mark;
6867be6d 2008 const I32 flags = SvIVx(*++mark);
294a48e9 2009
7918f24d 2010 PERL_ARGS_ASSERT_DO_IPCGET;
294a48e9 2011 PERL_UNUSED_ARG(sp);
c2ab57d4 2012
748a9306 2013 SETERRNO(0,0);
c2ab57d4
LW
2014 switch (optype)
2015 {
fe14fcc3 2016#ifdef HAS_MSG
79072805 2017 case OP_MSGGET:
c2ab57d4 2018 return msgget(key, flags);
e5d73d77 2019#endif
fe14fcc3 2020#ifdef HAS_SEM
79072805 2021 case OP_SEMGET:
c3312966 2022 return semget(key, (int) SvIV(nsv), flags);
e5d73d77 2023#endif
fe14fcc3 2024#ifdef HAS_SHM
79072805 2025 case OP_SHMGET:
c3312966 2026 return shmget(key, (size_t) SvUV(nsv), flags);
e5d73d77 2027#endif
fe14fcc3 2028#if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
e5d73d77 2029 default:
fe13d51d 2030 /* diag_listed_as: msg%s not implemented */
cea2e8a9 2031 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
e5d73d77 2032#endif
c2ab57d4
LW
2033 }
2034 return -1; /* should never happen */
2035}
2036
79072805 2037I32
864dbfa3 2038Perl_do_ipcctl(pTHX_ I32 optype, SV **mark, SV **sp)
c2ab57d4 2039{
97aff369 2040 dVAR;
c2ab57d4 2041 char *a;
a0d0e21e 2042 I32 ret = -1;
6867be6d 2043 const I32 id = SvIVx(*++mark);
95b63a38 2044#ifdef Semctl
6867be6d 2045 const I32 n = (optype == OP_SEMCTL) ? SvIVx(*++mark) : 0;
95b63a38 2046#endif
6867be6d 2047 const I32 cmd = SvIVx(*++mark);
0bcc34c2
AL
2048 SV * const astr = *++mark;
2049 STRLEN infosize = 0;
2050 I32 getinfo = (cmd == IPC_STAT);
c2ab57d4 2051
7918f24d 2052 PERL_ARGS_ASSERT_DO_IPCCTL;
0bcc34c2 2053 PERL_UNUSED_ARG(sp);
c2ab57d4
LW
2054
2055 switch (optype)
2056 {
fe14fcc3 2057#ifdef HAS_MSG
79072805 2058 case OP_MSGCTL:
c2ab57d4
LW
2059 if (cmd == IPC_STAT || cmd == IPC_SET)
2060 infosize = sizeof(struct msqid_ds);
2061 break;
e5d73d77 2062#endif
fe14fcc3 2063#ifdef HAS_SHM
79072805 2064 case OP_SHMCTL:
c2ab57d4
LW
2065 if (cmd == IPC_STAT || cmd == IPC_SET)
2066 infosize = sizeof(struct shmid_ds);
2067 break;
e5d73d77 2068#endif
fe14fcc3 2069#ifdef HAS_SEM
79072805 2070 case OP_SEMCTL:
39398f3f 2071#ifdef Semctl
c2ab57d4
LW
2072 if (cmd == IPC_STAT || cmd == IPC_SET)
2073 infosize = sizeof(struct semid_ds);
2074 else if (cmd == GETALL || cmd == SETALL)
2075 {
8e591e46 2076 struct semid_ds semds;
bd89102f 2077 union semun semun;
e6f0bdd6
GS
2078#ifdef EXTRA_F_IN_SEMUN_BUF
2079 semun.buff = &semds;
2080#else
84902520 2081 semun.buf = &semds;
e6f0bdd6 2082#endif
c2ab57d4 2083 getinfo = (cmd == GETALL);
9b89d93d
GB
2084 if (Semctl(id, 0, IPC_STAT, semun) == -1)
2085 return -1;
6e21c824
LW
2086 infosize = semds.sem_nsems * sizeof(short);
2087 /* "short" is technically wrong but much more portable
2088 than guessing about u_?short(_t)? */
c2ab57d4 2089 }
39398f3f 2090#else
fe13d51d 2091 /* diag_listed_as: sem%s not implemented */
cea2e8a9 2092 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
39398f3f 2093#endif
c2ab57d4 2094 break;
e5d73d77 2095#endif
fe14fcc3 2096#if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
e5d73d77 2097 default:
fe13d51d 2098 /* diag_listed_as: shm%s not implemented */
cea2e8a9 2099 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
e5d73d77 2100#endif
c2ab57d4
LW
2101 }
2102
2103 if (infosize)
2104 {
2105 if (getinfo)
2106 {
93524f2b 2107 SvPV_force_nolen(astr);
a0d0e21e 2108 a = SvGROW(astr, infosize+1);
c2ab57d4
LW
2109 }
2110 else
2111 {
93524f2b 2112 STRLEN len;
463ee0b2
LW
2113 a = SvPV(astr, len);
2114 if (len != infosize)
cea2e8a9 2115 Perl_croak(aTHX_ "Bad arg length for %s, is %lu, should be %ld",
4ec43091
JH
2116 PL_op_desc[optype],
2117 (unsigned long)len,
2118 (long)infosize);
c2ab57d4
LW
2119 }
2120 }
2121 else
2122 {
0bcc34c2 2123 const IV i = SvIV(astr);
56431972 2124 a = INT2PTR(char *,i); /* ouch */
c2ab57d4 2125 }
748a9306 2126 SETERRNO(0,0);
c2ab57d4
LW
2127 switch (optype)
2128 {
fe14fcc3 2129#ifdef HAS_MSG
79072805 2130 case OP_MSGCTL:
bee1dbe2 2131 ret = msgctl(id, cmd, (struct msqid_ds *)a);
c2ab57d4 2132 break;
e5d73d77 2133#endif
fe14fcc3 2134#ifdef HAS_SEM
bd89102f 2135 case OP_SEMCTL: {
39398f3f 2136#ifdef Semctl
bd89102f
AD
2137 union semun unsemds;
2138
e6f0bdd6
GS
2139#ifdef EXTRA_F_IN_SEMUN_BUF
2140 unsemds.buff = (struct semid_ds *)a;
2141#else
bd89102f 2142 unsemds.buf = (struct semid_ds *)a;
e6f0bdd6 2143#endif
bd89102f 2144 ret = Semctl(id, n, cmd, unsemds);
39398f3f 2145#else
fe13d51d 2146 /* diag_listed_as: sem%s not implemented */
cea2e8a9 2147 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
39398f3f 2148#endif
bd89102f 2149 }
c2ab57d4 2150 break;
e5d73d77 2151#endif
fe14fcc3 2152#ifdef HAS_SHM
79072805 2153 case OP_SHMCTL:
bee1dbe2 2154 ret = shmctl(id, cmd, (struct shmid_ds *)a);
c2ab57d4 2155 break;
e5d73d77 2156#endif
c2ab57d4
LW
2157 }
2158 if (getinfo && ret >= 0) {
79072805
LW
2159 SvCUR_set(astr, infosize);
2160 *SvEND(astr) = '\0';
a0d0e21e 2161 SvSETMAGIC(astr);
c2ab57d4
LW
2162 }
2163 return ret;
2164}
2165
79072805 2166I32
864dbfa3 2167Perl_do_msgsnd(pTHX_ SV **mark, SV **sp)
c2ab57d4 2168{
97aff369 2169 dVAR;
fe14fcc3 2170#ifdef HAS_MSG
463ee0b2 2171 STRLEN len;
6867be6d 2172 const I32 id = SvIVx(*++mark);
0bcc34c2
AL
2173 SV * const mstr = *++mark;
2174 const I32 flags = SvIVx(*++mark);
2175 const char * const mbuf = SvPV_const(mstr, len);
2176 const I32 msize = len - sizeof(long);
2177
7918f24d 2178 PERL_ARGS_ASSERT_DO_MSGSND;
890ce7af 2179 PERL_UNUSED_ARG(sp);
c2ab57d4 2180
0bcc34c2 2181 if (msize < 0)
cea2e8a9 2182 Perl_croak(aTHX_ "Arg too short for msgsnd");
748a9306 2183 SETERRNO(0,0);
bee1dbe2 2184 return msgsnd(id, (struct msgbuf *)mbuf, msize, flags);
e5d73d77 2185#else
2d51fa4d
RGS
2186 PERL_UNUSED_ARG(sp);
2187 PERL_UNUSED_ARG(mark);
fe13d51d 2188 /* diag_listed_as: msg%s not implemented */
cea2e8a9 2189 Perl_croak(aTHX_ "msgsnd not implemented");
7c522378 2190 return -1;
e5d73d77 2191#endif
c2ab57d4
LW
2192}
2193
79072805 2194I32
864dbfa3 2195Perl_do_msgrcv(pTHX_ SV **mark, SV **sp)
c2ab57d4 2196{
fe14fcc3 2197#ifdef HAS_MSG
97aff369 2198 dVAR;
c2ab57d4
LW
2199 char *mbuf;
2200 long mtype;
6867be6d 2201 I32 msize, flags, ret;
6867be6d 2202 const I32 id = SvIVx(*++mark);
0bcc34c2 2203 SV * const mstr = *++mark;
7918f24d
NC
2204
2205 PERL_ARGS_ASSERT_DO_MSGRCV;
890ce7af 2206 PERL_UNUSED_ARG(sp);
79072805 2207
c2e66d9e
GS
2208 /* suppress warning when reading into undef var --jhi */
2209 if (! SvOK(mstr))
76f68e9b 2210 sv_setpvs(mstr, "");
463ee0b2
LW
2211 msize = SvIVx(*++mark);
2212 mtype = (long)SvIVx(*++mark);
2213 flags = SvIVx(*++mark);
93524f2b 2214 SvPV_force_nolen(mstr);
a0d0e21e 2215 mbuf = SvGROW(mstr, sizeof(long)+msize+1);
a1d180c4 2216
748a9306 2217 SETERRNO(0,0);
bee1dbe2 2218 ret = msgrcv(id, (struct msgbuf *)mbuf, msize, mtype, flags);
c2ab57d4 2219 if (ret >= 0) {
79072805
LW
2220 SvCUR_set(mstr, sizeof(long)+ret);
2221 *SvEND(mstr) = '\0';
41d6edb2
JH
2222 /* who knows who has been playing with this message? */
2223 SvTAINTED_on(mstr);
c2ab57d4
LW
2224 }
2225 return ret;
e5d73d77 2226#else
2d51fa4d
RGS
2227 PERL_UNUSED_ARG(sp);
2228 PERL_UNUSED_ARG(mark);
fe13d51d 2229 /* diag_listed_as: msg%s not implemented */
cea2e8a9 2230 Perl_croak(aTHX_ "msgrcv not implemented");
7c522378 2231 return -1;
e5d73d77 2232#endif
c2ab57d4
LW
2233}
2234
79072805 2235I32
864dbfa3 2236Perl_do_semop(pTHX_ SV **mark, SV **sp)
c2ab57d4 2237{
fe14fcc3 2238#ifdef HAS_SEM
97aff369 2239 dVAR;
463ee0b2 2240 STRLEN opsize;
6867be6d 2241 const I32 id = SvIVx(*++mark);
0bcc34c2
AL
2242 SV * const opstr = *++mark;
2243 const char * const opbuf = SvPV_const(opstr, opsize);
7918f24d
NC
2244
2245 PERL_ARGS_ASSERT_DO_SEMOP;
890ce7af 2246 PERL_UNUSED_ARG(sp);
c2ab57d4 2247
248ff010
NC
2248 if (opsize < 3 * SHORTSIZE
2249 || (opsize % (3 * SHORTSIZE))) {
93189314 2250 SETERRNO(EINVAL,LIB_INVARG);
c2ab57d4
LW
2251 return -1;
2252 }
748a9306 2253 SETERRNO(0,0);
248ff010
NC
2254 /* We can't assume that sizeof(struct sembuf) == 3 * sizeof(short). */
2255 {
6867be6d 2256 const int nsops = opsize / (3 * sizeof (short));
248ff010 2257 int i = nsops;
0bcc34c2 2258 short * const ops = (short *) opbuf;
248ff010
NC
2259 short *o = ops;
2260 struct sembuf *temps, *t;
2261 I32 result;
2262
a02a5408 2263 Newx (temps, nsops, struct sembuf);
248ff010
NC
2264 t = temps;
2265 while (i--) {
2266 t->sem_num = *o++;
2267 t->sem_op = *o++;
2268 t->sem_flg = *o++;
2269 t++;
2270 }
2271 result = semop(id, temps, nsops);
2272 t = temps;
2273 o = ops;
2274 i = nsops;
2275 while (i--) {
2276 *o++ = t->sem_num;
2277 *o++ = t->sem_op;
2278 *o++ = t->sem_flg;
2279 t++;
2280 }
2281 Safefree(temps);
2282 return result;
2283 }
e5d73d77 2284#else
fe13d51d 2285 /* diag_listed_as: sem%s not implemented */
cea2e8a9 2286 Perl_croak(aTHX_ "semop not implemented");
e5d73d77 2287#endif
c2ab57d4
LW
2288}
2289
79072805 2290I32
864dbfa3 2291Perl_do_shmio(pTHX_ I32 optype, SV **mark, SV **sp)
c2ab57d4 2292{
fe14fcc3 2293#ifdef HAS_SHM
97aff369 2294 dVAR;
4373e329 2295 char *shm;
c2ab57d4 2296 struct shmid_ds shmds;
6867be6d 2297 const I32 id = SvIVx(*++mark);
0bcc34c2
AL
2298 SV * const mstr = *++mark;
2299 const I32 mpos = SvIVx(*++mark);
2300 const I32 msize = SvIVx(*++mark);
7918f24d
NC
2301
2302 PERL_ARGS_ASSERT_DO_SHMIO;
890ce7af 2303 PERL_UNUSED_ARG(sp);
c2ab57d4 2304
748a9306 2305 SETERRNO(0,0);
c2ab57d4
LW
2306 if (shmctl(id, IPC_STAT, &shmds) == -1)
2307 return -1;
7f39519f
NC
2308 if (mpos < 0 || msize < 0
2309 || (size_t)mpos + msize > (size_t)shmds.shm_segsz) {
93189314 2310 SETERRNO(EFAULT,SS_ACCVIO); /* can't do as caller requested */
c2ab57d4
LW
2311 return -1;
2312 }
d4c19fe8 2313 shm = (char *)shmat(id, NULL, (optype == OP_SHMREAD) ? SHM_RDONLY : 0);
c2ab57d4
LW
2314 if (shm == (char *)-1) /* I hate System V IPC, I really do */
2315 return -1;
79072805 2316 if (optype == OP_SHMREAD) {
c8ae91a8 2317 char *mbuf;
9f538c04 2318 /* suppress warning when reading into undef var (tchrist 3/Mar/00) */
b399897d
CS
2319 SvGETMAGIC(mstr);
2320 SvUPGRADE(mstr, SVt_PV);
9f538c04 2321 if (! SvOK(mstr))
76f68e9b 2322 sv_setpvs(mstr, "");
af8ff727 2323 SvPOK_only(mstr);
bb7a0f54 2324 mbuf = SvGROW(mstr, (STRLEN)msize+1);
a0d0e21e 2325
bee1dbe2 2326 Copy(shm + mpos, mbuf, msize, char);
79072805
LW
2327 SvCUR_set(mstr, msize);
2328 *SvEND(mstr) = '\0';
a0d0e21e 2329 SvSETMAGIC(mstr);
d929ce6f
JH
2330 /* who knows who has been playing with this shared memory? */
2331 SvTAINTED_on(mstr);
c2ab57d4
LW
2332 }
2333 else {
93524f2b 2334 STRLEN len;
c2ab57d4 2335
93524f2b 2336 const char *mbuf = SvPV_const(mstr, len);
027aa12d 2337 const I32 n = ((I32)len > msize) ? msize : (I32)len;
bee1dbe2 2338 Copy(mbuf, shm + mpos, n, char);
c2ab57d4 2339 if (n < msize)
bee1dbe2 2340 memzero(shm + mpos + n, msize - n);
c2ab57d4
LW
2341 }
2342 return shmdt(shm);
e5d73d77 2343#else
fe13d51d 2344 /* diag_listed_as: shm%s not implemented */
cea2e8a9 2345 Perl_croak(aTHX_ "shm I/O not implemented");
7c522378 2346 return -1;
e5d73d77 2347#endif
c2ab57d4
LW
2348}
2349
fe14fcc3 2350#endif /* SYSV IPC */
4e35701f 2351
0d44d22b 2352/*
ccfc67b7
JH
2353=head1 IO Functions
2354
0d44d22b
NC
2355=for apidoc start_glob
2356
2357Function called by C<do_readline> to spawn a glob (or do the glob inside
2358perl on VMS). This code used to be inline, but now perl uses C<File::Glob>
210b36aa 2359this glob starter is only used by miniperl during the build process.
0d44d22b 2360Moving it away shrinks pp_hot.c; shrinking pp_hot.c helps speed perl up.
fab3f3a7 2361
0d44d22b
NC
2362=cut
2363*/
2364
2365PerlIO *
2366Perl_start_glob (pTHX_ SV *tmpglob, IO *io)
2367{
27da23d5 2368 dVAR;
561b68a9 2369 SV * const tmpcmd = newSV(0);
0d44d22b 2370 PerlIO *fp;
41188aa0
TC
2371 STRLEN len;
2372 const char *s = SvPV(tmpglob, len);
7918f24d
NC
2373
2374 PERL_ARGS_ASSERT_START_GLOB;
2375
41188aa0 2376 if (!IS_SAFE_SYSCALL(s, len, "pattern", "glob"))
c8028aa6
TC
2377 return NULL;
2378
0d44d22b
NC
2379 ENTER;
2380 SAVEFREESV(tmpcmd);
2381#ifdef VMS /* expand the wildcards right here, rather than opening a pipe, */
2382 /* since spawning off a process is a real performance hit */
dca5a913
JM
2383
2384PerlIO *
2385Perl_vms_start_glob
2386 (pTHX_ SV *tmpglob,
2387 IO *io);
2388
49a7a762 2389 fp = Perl_vms_start_glob(aTHX_ tmpglob, io);
dca5a913 2390
0d44d22b 2391#else /* !VMS */
0d44d22b
NC
2392#ifdef DOSISH
2393#ifdef OS2
2394 sv_setpv(tmpcmd, "for a in ");
2395 sv_catsv(tmpcmd, tmpglob);
2396 sv_catpv(tmpcmd, "; do echo \"$a\\0\\c\"; done |");
2397#else
2398#ifdef DJGPP
2399 sv_setpv(tmpcmd, "/dev/dosglob/"); /* File System Extension */
2400 sv_catsv(tmpcmd, tmpglob);
2401#else
2402 sv_setpv(tmpcmd, "perlglob ");
2403 sv_catsv(tmpcmd, tmpglob);
2404 sv_catpv(tmpcmd, " |");
2405#endif /* !DJGPP */
2406#endif /* !OS2 */
2407#else /* !DOSISH */
2408#if defined(CSH)
2409 sv_setpvn(tmpcmd, PL_cshname, PL_cshlen);
2410 sv_catpv(tmpcmd, " -cf 'set nonomatch; glob ");
2411 sv_catsv(tmpcmd, tmpglob);
2412 sv_catpv(tmpcmd, "' 2>/dev/null |");
2413#else
2414 sv_setpv(tmpcmd, "echo ");
2415 sv_catsv(tmpcmd, tmpglob);
2416#if 'z' - 'a' == 25
2417 sv_catpv(tmpcmd, "|tr -s ' \t\f\r' '\\012\\012\\012\\012'|");
2418#else
2419 sv_catpv(tmpcmd, "|tr -s ' \t\f\r' '\\n\\n\\n\\n'|");
2420#endif
2421#endif /* !CSH */
2422#endif /* !DOSISH */
93b2dae1
FC
2423 {
2424 GV * const envgv = gv_fetchpvs("ENV", 0, SVt_PVHV);
2425 SV ** const home = hv_fetchs(GvHV(envgv), "HOME", 0);
25018358 2426 SV ** const path = hv_fetchs(GvHV(envgv), "PATH", 0);
93b2dae1 2427 if (home && *home) SvGETMAGIC(*home);
25018358 2428 if (path && *path) SvGETMAGIC(*path);
93b2dae1
FC
2429 save_hash(gv_fetchpvs("ENV", 0, SVt_PVHV));
2430 if (home && *home) SvSETMAGIC(*home);
25018358 2431 if (path && *path) SvSETMAGIC(*path);
93b2dae1 2432 }
93524f2b 2433 (void)do_open(PL_last_in_gv, (char*)SvPVX_const(tmpcmd), SvCUR(tmpcmd),
4608196e 2434 FALSE, O_RDONLY, 0, NULL);
0d44d22b
NC
2435 fp = IoIFP(io);
2436#endif /* !VMS */
2437 LEAVE;
de7dabb6
TC
2438
2439 if (!fp && ckWARN(WARN_GLOB)) {
2440 Perl_warner(aTHX_ packWARN(WARN_GLOB), "glob failed (can't start child: %s)",
2441 Strerror(errno));
2442 }
2443
0d44d22b
NC
2444 return fp;
2445}
66610fdd
RGS
2446
2447/*
2448 * Local variables:
2449 * c-indentation-style: bsd
2450 * c-basic-offset: 4
14d04a33 2451 * indent-tabs-mode: nil
66610fdd
RGS
2452 * End:
2453 *
14d04a33 2454 * ex: set ts=8 sts=4 sw=4 et:
37442d52 2455 */