This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Consistent spaces after dots in perlintern.pod
[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 */
7211d486
JH
362 /* On the other hand, do all platforms
363 * take gracefully to flushing a read-only
364 * filehandle? Perhaps we should do
365 * fsetpos(src)+fgetpos(dst)? --nik */
ecdeb87c
NIS
366 PerlIO_flush(that_fp);
367 fd = PerlIO_fileno(that_fp);
0759c907
JH
368 /* When dup()ing STDIN, STDOUT or STDERR
369 * explicitly set appropriate access mode */
f4e789af
NC
370 if (that_fp == PerlIO_stdout()
371 || that_fp == PerlIO_stderr())
0759c907 372 IoTYPE(io) = IoTYPE_WRONLY;
f4e789af 373 else if (that_fp == PerlIO_stdin())
0759c907
JH
374 IoTYPE(io) = IoTYPE_RDONLY;
375 /* When dup()ing a socket, say result is
376 * one as well */
377 else if (IoTYPE(thatio) == IoTYPE_SOCKET)
50952442 378 IoTYPE(io) = IoTYPE_SOCKET;
c07a80fd
PP
379 }
380 else
381 fd = -1;
a0d0e21e 382 }
ee518936 383 if (!num_svs)
bd61b366 384 type = NULL;
ecdeb87c
NIS
385 if (that_fp) {
386 fp = PerlIO_fdupopen(aTHX_ that_fp, NULL, dodup);
387 }
388 else {
c07a80fd 389 if (dodup)
ecdeb87c
NIS
390 fd = PerlLIO_dup(fd);
391 else
392 was_fdopen = TRUE;
393 if (!(fp = PerlIO_openn(aTHX_ type,mode,fd,0,0,NULL,num_svs,svp))) {
b42969c0 394 if (dodup && fd >= 0)
ecdeb87c
NIS
395 PerlLIO_close(fd);
396 }
faecd977 397 }
c07a80fd 398 }
ee518936 399 } /* & */
c07a80fd 400 else {
294b3b39
AL
401 while (isSPACE(*type))
402 type++;
b931b1d9 403 if (*type == IoTYPE_STD && (!type[1] || isSPACE(type[1]) || type[1] == ':')) {
b931b1d9 404 type++;
760ac839 405 fp = PerlIO_stdout();
50952442 406 IoTYPE(io) = IoTYPE_STD;
7cf31beb 407 if (num_svs > 1) {
fe13d51d 408 /* diag_listed_as: More than one argument to '%s' open */
7cf31beb
NIS
409 Perl_croak(aTHX_ "More than one argument to '>%c' open",IoTYPE_STD);
410 }
c07a80fd
PP
411 }
412 else {
ee518936 413 if (!num_svs) {
59cd0e26 414 namesv = newSVpvn_flags(type, tend - type, SVs_TEMP);
ee518936
NIS
415 num_svs = 1;
416 svp = &namesv;
bd61b366 417 type = NULL;
ee518936 418 }
6e60e805 419 fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,num_svs,svp);
c07a80fd 420 }
ee518936 421 } /* !& */
7e72d509
JH
422 if (!fp && type && *type && *type != ':' && !isIDFIRST(*type))
423 goto unknown_open_mode;
c2be40b1 424 } /* IoTYPE_WRONLY */
9f37169a 425 else if (*type == IoTYPE_RDONLY) {
294b3b39
AL
426 do {
427 type++;
428 } while (isSPACE(*type));
bf38876a 429 mode[0] = 'r';
0c19750d 430 if (in_raw)
5686ee58 431 mode[1] = 'b';
0c19750d 432 else if (in_crlf)
5686ee58 433 mode[1] = 't';
6170680b 434 if (*type == '&') {
bf38876a 435 goto duplicity;
6170680b 436 }
b931b1d9 437 if (*type == IoTYPE_STD && (!type[1] || isSPACE(type[1]) || type[1] == ':')) {
b931b1d9 438 type++;
760ac839 439 fp = PerlIO_stdin();
50952442 440 IoTYPE(io) = IoTYPE_STD;
7cf31beb 441 if (num_svs > 1) {
fe13d51d 442 /* diag_listed_as: More than one argument to '%s' open */
7cf31beb
NIS
443 Perl_croak(aTHX_ "More than one argument to '<%c' open",IoTYPE_STD);
444 }
a687059c 445 }
ee518936
NIS
446 else {
447 if (!num_svs) {
59cd0e26 448 namesv = newSVpvn_flags(type, tend - type, SVs_TEMP);
ee518936
NIS
449 num_svs = 1;
450 svp = &namesv;
bd61b366 451 type = NULL;
ee518936 452 }
6e60e805 453 fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,num_svs,svp);
ee518936 454 }
7e72d509
JH
455 if (!fp && type && *type && *type != ':' && !isIDFIRST(*type))
456 goto unknown_open_mode;
c2be40b1
JH
457 } /* IoTYPE_RDONLY */
458 else if ((num_svs && /* '-|...' or '...|' */
459 type[0] == IoTYPE_STD && type[1] == IoTYPE_PIPE) ||
b931b1d9 460 (!num_svs && tend > type+1 && tend[-1] == IoTYPE_PIPE)) {
6170680b 461 if (num_svs) {
b931b1d9 462 type += 2; /* skip over '-|' */
6170680b
IZ
463 }
464 else {
b931b1d9
NIS
465 *--tend = '\0';
466 while (tend > type && isSPACE(tend[-1]))
467 *--tend = '\0';
a6e20a40
AL
468 for (; isSPACE(*type); type++)
469 ;
6170680b 470 name = type;
b931b1d9 471 len = tend-type;
6170680b 472 }
4a7d1889
NIS
473 if (*name == '\0') {
474 /* command is missing 19990114 */
06eaf0bc 475 if (ckWARN(WARN_PIPE))
9014280d 476 Perl_warner(aTHX_ packWARN(WARN_PIPE), "Missing command in piped open");
06eaf0bc
GS
477 errno = EPIPE;
478 goto say_false;
479 }
770526c1 480 if (!(*name == '-' && name[1] == '\0') || num_svs)
79072805
LW
481 TAINT_ENV();
482 TAINT_PROPER("piped open");
a1d180c4 483 mode[0] = 'r';
0c19750d 484
0c19750d 485 if (in_raw)
5686ee58 486 mode[1] = 'b';
0c19750d 487 else if (in_crlf)
5686ee58 488 mode[1] = 't';
0c19750d 489
4a7d1889
NIS
490 if (num_svs > 1) {
491 fp = PerlProc_popen_list(mode,num_svs,svp);
492 }
e620cd72 493 else {
4a7d1889
NIS
494 fp = PerlProc_popen(name,mode);
495 }
50952442 496 IoTYPE(io) = IoTYPE_PIPE;
1771866f 497 if (num_svs) {
294b3b39
AL
498 while (isSPACE(*type))
499 type++;
1771866f
NIS
500 if (*type) {
501 if (PerlIO_apply_layers(aTHX_ fp, mode, type) != 0) {
502 goto say_false;
503 }
504 }
505 }
a687059c 506 }
c2be40b1 507 else { /* layer(Args) */
6170680b 508 if (num_svs)
c2be40b1 509 goto unknown_open_mode;
6170680b 510 name = type;
50952442 511 IoTYPE(io) = IoTYPE_RDONLY;
a6e20a40
AL
512 for (; isSPACE(*name); name++)
513 ;
88b61e10 514 mode[0] = 'r';
0c19750d 515
0c19750d 516 if (in_raw)
5686ee58 517 mode[1] = 'b';
0c19750d 518 else if (in_crlf)
5686ee58 519 mode[1] = 't';
0c19750d 520
770526c1 521 if (*name == '-' && name[1] == '\0') {
760ac839 522 fp = PerlIO_stdin();
50952442 523 IoTYPE(io) = IoTYPE_STD;
a687059c 524 }
16fe6d59 525 else {
ee518936 526 if (!num_svs) {
59cd0e26 527 namesv = newSVpvn_flags(type, tend - type, SVs_TEMP);
ee518936
NIS
528 num_svs = 1;
529 svp = &namesv;
bd61b366 530 type = NULL;
ee518936 531 }
6e60e805 532 fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,num_svs,svp);
16fe6d59 533 }
a687059c
LW
534 }
535 }
bee1dbe2 536 if (!fp) {
ce44635a 537 if (IoTYPE(io) == IoTYPE_RDONLY && ckWARN(WARN_NEWLINE)
2fbb330f 538 && strchr(oname, '\n')
ce44635a 539
041457d9 540 )
5d37acd6
DM
541 {
542 GCC_DIAG_IGNORE(-Wformat-nonliteral); /* PL_warn_nl is constant */
9014280d 543 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
5d37acd6
DM
544 GCC_DIAG_RESTORE;
545 }
6e21c824 546 goto say_false;
bee1dbe2 547 }
a00b5bd3
NIS
548
549 if (ckWARN(WARN_IO)) {
550 if ((IoTYPE(io) == IoTYPE_RDONLY) &&
551 (fp == PerlIO_stdout() || fp == PerlIO_stderr())) {
9014280d 552 Perl_warner(aTHX_ packWARN(WARN_IO),
d0c0e7dd
FC
553 "Filehandle STD%s reopened as %"HEKf
554 " only for input",
97828cef 555 ((fp == PerlIO_stdout()) ? "OUT" : "ERR"),
d0c0e7dd 556 HEKfARG(GvENAME_HEK(gv)));
a00b5bd3 557 }
ee518936 558 else if ((IoTYPE(io) == IoTYPE_WRONLY) && fp == PerlIO_stdin()) {
9014280d 559 Perl_warner(aTHX_ packWARN(WARN_IO),
d0c0e7dd
FC
560 "Filehandle STDIN reopened as %"HEKf" only for output",
561 HEKfARG(GvENAME_HEK(gv))
562 );
a00b5bd3
NIS
563 }
564 }
565
e99cca91 566 fd = PerlIO_fileno(fp);
e934609f
JH
567 /* If there is no fd (e.g. PerlIO::scalar) assume it isn't a
568 * socket - this covers PerlIO::scalar - otherwise unless we "know" the
e99cca91
NIS
569 * type probe for socket-ness.
570 */
571 if (IoTYPE(io) && IoTYPE(io) != IoTYPE_PIPE && IoTYPE(io) != IoTYPE_STD && fd >= 0) {
572 if (PerlLIO_fstat(fd,&PL_statbuf) < 0) {
573 /* If PerlIO claims to have fd we had better be able to fstat() it. */
574 (void) PerlIO_close(fp);
6e21c824 575 goto say_false;
a687059c 576 }
7114a2d2 577#ifndef PERL_MICRO
3280af22 578 if (S_ISSOCK(PL_statbuf.st_mode))
50952442 579 IoTYPE(io) = IoTYPE_SOCKET; /* in case a socket was passed in to us */
99b89507
LW
580#ifdef HAS_SOCKET
581 else if (
c623bd54 582#ifdef S_IFMT
3280af22 583 !(PL_statbuf.st_mode & S_IFMT)
99b89507 584#else
b28d0864 585 !PL_statbuf.st_mode
99b89507 586#endif
0759c907
JH
587 && IoTYPE(io) != IoTYPE_WRONLY /* Dups of STD* filehandles already have */
588 && IoTYPE(io) != IoTYPE_RDONLY /* type so they aren't marked as sockets */
589 ) { /* on OS's that return 0 on fstat()ed pipe */
e99cca91
NIS
590 char tmpbuf[256];
591 Sock_size_t buflen = sizeof tmpbuf;
592 if (PerlSock_getsockname(fd, (struct sockaddr *)tmpbuf, &buflen) >= 0
593 || errno != ENOTSOCK)
594 IoTYPE(io) = IoTYPE_SOCKET; /* some OS's return 0 on fstat()ed socket */
595 /* but some return 0 for streams too, sigh */
99b89507 596 }
e99cca91 597#endif /* HAS_SOCKET */
7114a2d2 598#endif /* !PERL_MICRO */
a687059c 599 }
e99cca91
NIS
600
601 /* Eeek - FIXME !!!
602 * If this is a standard handle we discard all the layer stuff
603 * and just dup the fd into whatever was on the handle before !
604 */
605
6e21c824 606 if (saveifp) { /* must use old fp? */
f5b9d040 607 /* If fd is less that PL_maxsysfd i.e. STDIN..STDERR
24c23ab4 608 then dup the new fileno down
f5b9d040 609 */
6e21c824 610 if (saveofp) {
f5b9d040 611 PerlIO_flush(saveofp); /* emulate PerlIO_close() */
6e21c824 612 if (saveofp != saveifp) { /* was a socket? */
760ac839 613 PerlIO_close(saveofp);
6e21c824
LW
614 }
615 }
6e60e805 616 if (savefd != fd) {
e934609f 617 /* Still a small can-of-worms here if (say) PerlIO::scalar
ecdeb87c
NIS
618 is assigned to (say) STDOUT - for now let dup2() fail
619 and provide the error
620 */
bd4a5668
NIS
621 if (PerlLIO_dup2(fd, savefd) < 0) {
622 (void)PerlIO_close(fp);
623 goto say_false;
624 }
d082dcd6 625#ifdef VMS
6e60e805 626 if (savefd != PerlIO_fileno(PerlIO_stdin())) {
d0e2cf63
AMS
627 char newname[FILENAME_MAX+1];
628 if (PerlIO_getname(fp, newname)) {
629 if (fd == PerlIO_fileno(PerlIO_stdout()))
0db50132 630 vmssetuserlnm("SYS$OUTPUT", newname);
d0e2cf63 631 if (fd == PerlIO_fileno(PerlIO_stderr()))
0db50132 632 vmssetuserlnm("SYS$ERROR", newname);
d0e2cf63 633 }
d082dcd6
JH
634 }
635#endif
d0e2cf63
AMS
636
637#if !defined(WIN32)
638 /* PL_fdpid isn't used on Windows, so avoid this useless work.
639 * XXX Probably the same for a lot of other places. */
640 {
641 Pid_t pid;
642 SV *sv;
643
d0e2cf63 644 sv = *av_fetch(PL_fdpid,fd,TRUE);
862a34c6 645 SvUPGRADE(sv, SVt_IV);
d0e2cf63 646 pid = SvIVX(sv);
45977657 647 SvIV_set(sv, 0);
d0e2cf63 648 sv = *av_fetch(PL_fdpid,savefd,TRUE);
862a34c6 649 SvUPGRADE(sv, SVt_IV);
45977657 650 SvIV_set(sv, pid);
d0e2cf63
AMS
651 }
652#endif
653
e212fc47
AMS
654 if (was_fdopen) {
655 /* need to close fp without closing underlying fd */
656 int ofd = PerlIO_fileno(fp);
657 int dupfd = PerlLIO_dup(ofd);
03e631df
JH
658#if defined(HAS_FCNTL) && defined(F_SETFD)
659 /* Assume if we have F_SETFD we have F_GETFD */
660 int coe = fcntl(ofd,F_GETFD);
661#endif
e212fc47
AMS
662 PerlIO_close(fp);
663 PerlLIO_dup2(dupfd,ofd);
03e631df
JH
664#if defined(HAS_FCNTL) && defined(F_SETFD)
665 /* The dup trick has lost close-on-exec on ofd */
666 fcntl(ofd,F_SETFD, coe);
667#endif
e212fc47 668 PerlLIO_close(dupfd);
ecdeb87c 669 }
e212fc47
AMS
670 else
671 PerlIO_close(fp);
6e21c824
LW
672 }
673 fp = saveifp;
760ac839 674 PerlIO_clearerr(fp);
e99cca91 675 fd = PerlIO_fileno(fp);
6e21c824 676 }
a0d0e21e 677#if defined(HAS_FCNTL) && defined(F_SETFD)
e99cca91 678 if (fd >= 0) {
4ee39169 679 dSAVE_ERRNO;
a8710ca1 680 fcntl(fd,F_SETFD,fd > PL_maxsysfd); /* can change errno */
4ee39169 681 RESTORE_ERRNO;
a8710ca1 682 }
1462b684 683#endif
8990e307 684 IoIFP(io) = fp;
b931b1d9 685
684bef36 686 IoFLAGS(io) &= ~IOf_NOLINE;
bf38876a 687 if (writing) {
50952442 688 if (IoTYPE(io) == IoTYPE_SOCKET
e99cca91 689 || (IoTYPE(io) == IoTYPE_WRONLY && fd >= 0 && S_ISCHR(PL_statbuf.st_mode)) ) {
a33cf58c 690 char *s = mode;
3b6c1aba
JH
691 if (*s == IoTYPE_IMPLICIT || *s == IoTYPE_NUMERIC)
692 s++;
a33cf58c 693 *s = 'w';
1feb1812 694 if (!(IoOFP(io) = PerlIO_openn(aTHX_ type,s,fd,0,0,NULL,0,svp))) {
760ac839 695 PerlIO_close(fp);
4608196e 696 IoIFP(io) = NULL;
6e21c824 697 goto say_false;
fe14fcc3 698 }
1462b684
LW
699 }
700 else
8990e307 701 IoOFP(io) = fp;
bf38876a 702 }
a687059c 703 return TRUE;
6e21c824
LW
704
705say_false:
8990e307
LW
706 IoIFP(io) = saveifp;
707 IoOFP(io) = saveofp;
708 IoTYPE(io) = savetype;
6e21c824 709 return FALSE;
a687059c
LW
710}
711
760ac839 712PerlIO *
5aaab254 713Perl_nextargv(pTHX_ GV *gv)
a687059c 714{
97aff369 715 dVAR;
eb578fdb 716 SV *sv;
99b89507 717#ifndef FLEXFILENAMES
c623bd54
LW
718 int filedev;
719 int fileino;
99b89507 720#endif
761237fe
JB
721 Uid_t fileuid;
722 Gid_t filegid;
2d03de9c 723 IO * const io = GvIOp(gv);
fe14fcc3 724
7918f24d
NC
725 PERL_ARGS_ASSERT_NEXTARGV;
726
3280af22 727 if (!PL_argvoutgv)
fafc274c 728 PL_argvoutgv = gv_fetchpvs("ARGVOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO);
18708f5a
GS
729 if (io && (IoFLAGS(io) & IOf_ARGV) && (IoFLAGS(io) & IOf_START)) {
730 IoFLAGS(io) &= ~IOf_START;
7a1c5554 731 if (PL_inplace) {
294b3b39 732 assert(PL_defoutgv);
29a861e7
NC
733 Perl_av_create_and_push(aTHX_ &PL_argvout_stack,
734 SvREFCNT_inc_simple_NN(PL_defoutgv));
7a1c5554 735 }
18708f5a 736 }
3280af22
NIS
737 if (PL_filemode & (S_ISUID|S_ISGID)) {
738 PerlIO_flush(IoIFP(GvIOn(PL_argvoutgv))); /* chmod must follow last write */
fe14fcc3 739#ifdef HAS_FCHMOD
c797f2d8
DM
740 if (PL_lastfd != -1)
741 (void)fchmod(PL_lastfd,PL_filemode);
fe14fcc3 742#else
b28d0864 743 (void)PerlLIO_chmod(PL_oldname,PL_filemode);
fe14fcc3
LW
744#endif
745 }
c797f2d8 746 PL_lastfd = -1;
3280af22 747 PL_filemode = 0;
5c501b37 748 if (!GvAV(gv))
4608196e 749 return NULL;
79072805 750 while (av_len(GvAV(gv)) >= 0) {
85aff577 751 STRLEN oldlen;
79072805 752 sv = av_shift(GvAV(gv));
8990e307 753 SAVEFREESV(sv);
4bac9ae4 754 SvTAINTED_off(GvSVn(gv)); /* previous tainting irrelevant */
e203899d 755 sv_setsv(GvSVn(gv),sv);
79072805 756 SvSETMAGIC(GvSV(gv));
3280af22 757 PL_oldname = SvPVx(GvSV(gv), oldlen);
4608196e 758 if (do_open(gv,PL_oldname,oldlen,PL_inplace!=0,O_RDONLY,0,NULL)) {
3280af22 759 if (PL_inplace) {
79072805 760 TAINT_PROPER("inplace open");
3280af22 761 if (oldlen == 1 && *PL_oldname == '-') {
fafc274c
NC
762 setdefout(gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL,
763 SVt_PVIO));
a0d0e21e 764 return IoIFP(GvIOp(gv));
c623bd54 765 }
99b89507 766#ifndef FLEXFILENAMES
b28d0864
NIS
767 filedev = PL_statbuf.st_dev;
768 fileino = PL_statbuf.st_ino;
99b89507 769#endif
3280af22
NIS
770 PL_filemode = PL_statbuf.st_mode;
771 fileuid = PL_statbuf.st_uid;
772 filegid = PL_statbuf.st_gid;
773 if (!S_ISREG(PL_filemode)) {
9b387841
NC
774 Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE),
775 "Can't do inplace edit: %s is not a regular file",
776 PL_oldname );
79072805 777 do_close(gv,FALSE);
c623bd54
LW
778 continue;
779 }
c9930541 780 if (*PL_inplace && strNE(PL_inplace, "*")) {
2d03de9c 781 const char *star = strchr(PL_inplace, '*');
2d259d92 782 if (star) {
2d03de9c 783 const char *begin = PL_inplace;
76f68e9b 784 sv_setpvs(sv, "");
2d259d92
CK
785 do {
786 sv_catpvn(sv, begin, star - begin);
3280af22 787 sv_catpvn(sv, PL_oldname, oldlen);
2d259d92
CK
788 begin = ++star;
789 } while ((star = strchr(begin, '*')));
3d66d7bb
GS
790 if (*begin)
791 sv_catpv(sv,begin);
2d259d92
CK
792 }
793 else {
3280af22 794 sv_catpv(sv,PL_inplace);
2d259d92 795 }
c623bd54 796#ifndef FLEXFILENAMES
95a20fc0 797 if ((PerlLIO_stat(SvPVX_const(sv),&PL_statbuf) >= 0
5f74f29c
JH
798 && PL_statbuf.st_dev == filedev
799 && PL_statbuf.st_ino == fileino)
39e571d4 800#ifdef DJGPP
5f74f29c 801 || ((_djstat_fail_bits & _STFAIL_TRUENAME)!=0)
39e571d4 802#endif
f248d071
GS
803 )
804 {
9b387841
NC
805 Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE),
806 "Can't do inplace edit: %"SVf" would not be unique",
807 SVfARG(sv));
79072805 808 do_close(gv,FALSE);
c623bd54
LW
809 continue;
810 }
811#endif
fe14fcc3 812#ifdef HAS_RENAME
739a0b84 813#if !defined(DOSISH) && !defined(__CYGWIN__)
95a20fc0 814 if (PerlLIO_rename(PL_oldname,SvPVX_const(sv)) < 0) {
9b387841
NC
815 Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE),
816 "Can't rename %s to %"SVf": %s, skipping file",
817 PL_oldname, SVfARG(sv), Strerror(errno));
79072805 818 do_close(gv,FALSE);
c623bd54
LW
819 continue;
820 }
a687059c 821#else
79072805 822 do_close(gv,FALSE);
95a20fc0
SP
823 (void)PerlLIO_unlink(SvPVX_const(sv));
824 (void)PerlLIO_rename(PL_oldname,SvPVX_const(sv));
30fc4309 825 do_open(gv,(char*)SvPVX_const(sv),SvCUR(sv),TRUE,O_RDONLY,0,NULL);
55497cff 826#endif /* DOSISH */
ff8e2863 827#else
95a20fc0
SP
828 (void)UNLINK(SvPVX_const(sv));
829 if (link(PL_oldname,SvPVX_const(sv)) < 0) {
9b387841
NC
830 Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE),
831 "Can't rename %s to %"SVf": %s, skipping file",
832 PL_oldname, SVfARG(sv), Strerror(errno) );
79072805 833 do_close(gv,FALSE);
c623bd54
LW
834 continue;
835 }
b28d0864 836 (void)UNLINK(PL_oldname);
a687059c
LW
837#endif
838 }
839 else {
c030f24b 840#if !defined(DOSISH) && !defined(AMIGAOS)
edc7bc49 841# ifndef VMS /* Don't delete; use automatic file versioning */
3280af22 842 if (UNLINK(PL_oldname) < 0) {
9b387841
NC
843 Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE),
844 "Can't remove %s: %s, skipping file",
845 PL_oldname, Strerror(errno) );
79072805 846 do_close(gv,FALSE);
fe14fcc3
LW
847 continue;
848 }
edc7bc49 849# endif
ff8e2863 850#else
cea2e8a9 851 Perl_croak(aTHX_ "Can't do inplace edit without backup");
ff8e2863 852#endif
a687059c
LW
853 }
854
30fc4309 855 sv_setpvn(sv,PL_oldname,oldlen);
748a9306 856 SETERRNO(0,0); /* in case sprintf set errno */
7f8ee4be
NC
857 if (!Perl_do_openn(aTHX_ PL_argvoutgv, (char*)SvPVX_const(sv),
858 SvCUR(sv), TRUE,
4119ab01 859#ifdef VMS
7f8ee4be 860 O_WRONLY|O_CREAT|O_TRUNC,0,
4119ab01 861#else
7f8ee4be 862 O_WRONLY|O_CREAT|OPEN_EXCL,0600,
4119ab01 863#endif
7f8ee4be 864 NULL, NULL, 0)) {
9b387841
NC
865 Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE), "Can't do inplace edit on %s: %s",
866 PL_oldname, Strerror(errno) );
79072805 867 do_close(gv,FALSE);
fe14fcc3
LW
868 continue;
869 }
3280af22
NIS
870 setdefout(PL_argvoutgv);
871 PL_lastfd = PerlIO_fileno(IoIFP(GvIOp(PL_argvoutgv)));
872 (void)PerlLIO_fstat(PL_lastfd,&PL_statbuf);
fe14fcc3 873#ifdef HAS_FCHMOD
3280af22 874 (void)fchmod(PL_lastfd,PL_filemode);
a687059c 875#else
b28d0864 876 (void)PerlLIO_chmod(PL_oldname,PL_filemode);
a687059c 877#endif
3280af22 878 if (fileuid != PL_statbuf.st_uid || filegid != PL_statbuf.st_gid) {
04783dc7 879 int rc = 0;
fe14fcc3 880#ifdef HAS_FCHOWN
04783dc7 881 rc = fchown(PL_lastfd,fileuid,filegid);
a687059c 882#else
fe14fcc3 883#ifdef HAS_CHOWN
04783dc7 884 rc = PerlLIO_chown(PL_oldname,fileuid,filegid);
a687059c 885#endif
b1248f16 886#endif
04783dc7
DM
887 /* XXX silently ignore failures */
888 PERL_UNUSED_VAR(rc);
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);
5d37acd6
DM
1324 if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && strchr(s, '\n')) {
1325 GCC_DIAG_IGNORE(-Wformat-nonliteral); /* PL_warn_nl is constant */
9014280d 1326 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
5d37acd6
DM
1327 GCC_DIAG_RESTORE;
1328 }
3280af22 1329 return PL_laststatval;
a687059c
LW
1330 }
1331}
1332
fbb0b3b3 1333
79072805 1334I32
0d7d409d 1335Perl_my_lstat_flags(pTHX_ const U32 flags)
c623bd54 1336{
97aff369 1337 dVAR;
a1894d81 1338 static const char* const no_prev_lstat = "The stat preceding -l _ wasn't an lstat";
39644a26 1339 dSP;
b16276bb 1340 const char *file;
cd22fad3 1341 SV* const sv = TOPs;
5840701a 1342 bool isio = FALSE;
533c011a 1343 if (PL_op->op_flags & OPf_REF) {
638eceb6 1344 if (cGVOP_gv == PL_defgv) {
3280af22 1345 if (PL_laststype != OP_LSTAT)
0157ef98 1346 Perl_croak(aTHX_ "%s", no_prev_lstat);
3280af22 1347 return PL_laststatval;
fe14fcc3 1348 }
31b139ba 1349 PL_laststatval = -1;
5d3e98de 1350 if (ckWARN(WARN_IO)) {
5840701a 1351 /* diag_listed_as: Use of -l on filehandle%s */
d0c0e7dd
FC
1352 Perl_warner(aTHX_ packWARN(WARN_IO),
1353 "Use of -l on filehandle %"HEKf,
1354 HEKfARG(GvENAME_HEK(cGVOP_gv)));
5d3e98de 1355 }
31b139ba 1356 return -1;
fe14fcc3 1357 }
8db8f6b6
FC
1358 if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t))
1359 == OPpFT_STACKED) {
1f26655e 1360 if (PL_laststype != OP_LSTAT)
0157ef98 1361 Perl_croak(aTHX_ "%s", no_prev_lstat);
1f26655e 1362 return PL_laststatval;
cd22fad3 1363 }
c623bd54 1364
3280af22 1365 PL_laststype = OP_LSTAT;
a0714e2c 1366 PL_statgv = NULL;
5840701a
FC
1367 if ( ( (SvROK(sv) && ( isGV_with_GP(SvRV(sv))
1368 || (isio = SvTYPE(SvRV(sv)) == SVt_PVIO) )
1369 )
1370 || isGV_with_GP(sv)
1371 )
1372 && ckWARN(WARN_IO)) {
1373 if (isio)
1374 /* diag_listed_as: Use of -l on filehandle%s */
1375 Perl_warner(aTHX_ packWARN(WARN_IO),
1376 "Use of -l on filehandle");
1377 else
1378 /* diag_listed_as: Use of -l on filehandle%s */
1379 Perl_warner(aTHX_ packWARN(WARN_IO),
1380 "Use of -l on filehandle %"HEKf,
1381 GvENAME_HEK((const GV *)
1382 (SvROK(sv) ? SvRV(sv) : sv)));
cd22fad3
RS
1383 }
1384 file = SvPV_flags_const_nolen(sv, flags);
b16276bb
VP
1385 sv_setpv(PL_statname,file);
1386 PL_laststatval = PerlLIO_lstat(file,&PL_statcache);
5d37acd6
DM
1387 if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && strchr(file, '\n')) {
1388 GCC_DIAG_IGNORE(-Wformat-nonliteral); /* PL_warn_nl is constant */
1389 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "lstat");
1390 GCC_DIAG_RESTORE;
1391 }
3280af22 1392 return PL_laststatval;
c623bd54
LW
1393}
1394
a0f2c8ec
JD
1395static void
1396S_exec_failed(pTHX_ const char *cmd, int fd, int do_report)
1397{
1398 const int e = errno;
7918f24d 1399 PERL_ARGS_ASSERT_EXEC_FAILED;
a0f2c8ec
JD
1400 if (ckWARN(WARN_EXEC))
1401 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't exec \"%s\": %s",
1402 cmd, Strerror(e));
1403 if (do_report) {
04783dc7
DM
1404 int rc = PerlLIO_write(fd, (void*)&e, sizeof(int));
1405 /* silently ignore failures */
1406 PERL_UNUSED_VAR(rc);
a0f2c8ec
JD
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 }
f0d85c30 1812 else if (PL_unsafe) {
b8ffc8df 1813 if (UNLINK(s))
a687059c
LW
1814 tot--;
1815 }
1816 else { /* don't let root wipe out directories without -U */
1dcae8b8 1817 if (PerlLIO_lstat(s,&PL_statbuf) < 0)
a687059c 1818 tot--;
1dcae8b8
EZ
1819 else if (S_ISDIR(PL_statbuf.st_mode)) {
1820 tot--;
1821 SETERRNO(EISDIR, SS$_NOPRIV);
1822 }
a687059c 1823 else {
b8ffc8df 1824 if (UNLINK(s))
a687059c
LW
1825 tot--;
1826 }
1827 }
1828 }
1829 break;
e96b369d 1830#if defined(HAS_UTIME) || defined(HAS_FUTIMES)
79072805 1831 case OP_UTIME:
20408e3c 1832 APPLY_TAINT_PROPER();
79072805 1833 if (sp - mark > 2) {
e96b369d
GA
1834#if defined(HAS_FUTIMES)
1835 struct timeval utbuf[2];
1836 void *utbufp = utbuf;
1837#elif defined(I_UTIME) || defined(VMS)
663a0e37 1838 struct utimbuf utbuf;
07409e01 1839 struct utimbuf *utbufp = &utbuf;
663a0e37 1840#else
a687059c 1841 struct {
dd2821f6
GS
1842 Time_t actime;
1843 Time_t modtime;
a687059c 1844 } utbuf;
07409e01 1845 void *utbufp = &utbuf;
663a0e37 1846#endif
a687059c 1847
0bcc34c2
AL
1848 SV* const accessed = *++mark;
1849 SV* const modified = *++mark;
c6f7b413 1850
6ec06612
SB
1851 /* Be like C, and if both times are undefined, let the C
1852 * library figure out what to do. This usually means
1853 * "current time". */
c6f7b413
RS
1854
1855 if ( accessed == &PL_sv_undef && modified == &PL_sv_undef )
6ec06612
SB
1856 utbufp = NULL;
1857 else {
1858 Zero(&utbuf, sizeof utbuf, char);
e96b369d 1859#ifdef HAS_FUTIMES
4ea561bc 1860 utbuf[0].tv_sec = (long)SvIV(accessed); /* time accessed */
e96b369d 1861 utbuf[0].tv_usec = 0;
4ea561bc 1862 utbuf[1].tv_sec = (long)SvIV(modified); /* time modified */
e96b369d
GA
1863 utbuf[1].tv_usec = 0;
1864#elif defined(BIG_TIME)
4ea561bc
NC
1865 utbuf.actime = (Time_t)SvNV(accessed); /* time accessed */
1866 utbuf.modtime = (Time_t)SvNV(modified); /* time modified */
517844ec 1867#else
4ea561bc
NC
1868 utbuf.actime = (Time_t)SvIV(accessed); /* time accessed */
1869 utbuf.modtime = (Time_t)SvIV(modified); /* time modified */
517844ec 1870#endif
6ec06612 1871 }
4373e329 1872 APPLY_TAINT_PROPER();
79072805
LW
1873 tot = sp - mark;
1874 while (++mark <= sp) {
e96b369d 1875 GV* gv;
64617da9 1876 if ((gv = MAYBE_DEREF_GV(*mark))) {
e96b369d
GA
1877 if (GvIO(gv) && IoIFP(GvIOp(gv))) {
1878#ifdef HAS_FUTIMES
1879 APPLY_TAINT_PROPER();
8b7231d9
SP
1880 if (futimes(PerlIO_fileno(IoIFP(GvIOn(gv))),
1881 (struct timeval *) utbufp))
e96b369d
GA
1882 tot--;
1883#else
1884 Perl_die(aTHX_ PL_no_func, "futimes");
1885#endif
1886 }
1887 else {
1888 tot--;
1889 }
1890 }
e96b369d 1891 else {
41188aa0 1892 const char * const name = SvPV_nomg_const(*mark, len);
e96b369d 1893 APPLY_TAINT_PROPER();
41188aa0 1894 if (!IS_SAFE_PATHNAME(name, len, "utime")) {
c8028aa6
TC
1895 tot--;
1896 }
1897 else
e96b369d 1898#ifdef HAS_FUTIMES
8b7231d9 1899 if (utimes(name, (struct timeval *)utbufp))
e96b369d
GA
1900#else
1901 if (PerlLIO_utime(name, utbufp))
1902#endif
1903 tot--;
1904 }
1905
a687059c 1906 }
a687059c
LW
1907 }
1908 else
79072805 1909 tot = 0;
a687059c 1910 break;
a0d0e21e 1911#endif
a687059c
LW
1912 }
1913 return tot;
20408e3c 1914
20408e3c 1915#undef APPLY_TAINT_PROPER
a687059c
LW
1916}
1917
1918/* Do the permissions allow some operation? Assumes statcache already set. */
a0d0e21e 1919#ifndef VMS /* VMS' cando is in vms.c */
7f4774ae 1920bool
5aaab254 1921Perl_cando(pTHX_ Mode_t mode, bool effective, const Stat_t *statbufp)
ae1951c1
NC
1922/* effective is a flag, true for EUID, or for checking if the effective gid
1923 * is in the list of groups returned from getgroups().
1924 */
a687059c 1925{
97aff369 1926 dVAR;
7918f24d
NC
1927
1928 PERL_ARGS_ASSERT_CANDO;
1929
bee1dbe2 1930#ifdef DOSISH
fe14fcc3
LW
1931 /* [Comments and code from Len Reed]
1932 * MS-DOS "user" is similar to UNIX's "superuser," but can't write
1933 * to write-protected files. The execute permission bit is set
486ec47a 1934 * by the Microsoft C library stat() function for the following:
fe14fcc3
LW
1935 * .exe files
1936 * .com files
1937 * .bat files
1938 * directories
1939 * All files and directories are readable.
1940 * Directories and special files, e.g. "CON", cannot be
1941 * write-protected.
1942 * [Comment by Tom Dinger -- a directory can have the write-protect
1943 * bit set in the file system, but DOS permits changes to
1944 * the directory anyway. In addition, all bets are off
1945 * here for networked software, such as Novell and
1946 * Sun's PC-NFS.]
1947 */
1948
bee1dbe2
LW
1949 /* Atari stat() does pretty much the same thing. we set x_bit_set_in_stat
1950 * too so it will actually look into the files for magic numbers
1951 */
7f4774ae 1952 return (mode & statbufp->st_mode) ? TRUE : FALSE;
fe14fcc3 1953
55497cff 1954#else /* ! DOSISH */
b595cd4b
RU
1955# ifdef __CYGWIN__
1956 if (ingroup(544,effective)) { /* member of Administrators */
1957# else
985213f2 1958 if ((effective ? PerlProc_geteuid() : PerlProc_getuid()) == 0) { /* root is special */
b595cd4b 1959# endif
7f4774ae 1960 if (mode == S_IXUSR) {
c623bd54 1961 if (statbufp->st_mode & 0111 || S_ISDIR(statbufp->st_mode))
a687059c
LW
1962 return TRUE;
1963 }
1964 else
1965 return TRUE; /* root reads and writes anything */
1966 return FALSE;
1967 }
985213f2 1968 if (statbufp->st_uid == (effective ? PerlProc_geteuid() : PerlProc_getuid()) ) {
7f4774ae 1969 if (statbufp->st_mode & mode)
a687059c
LW
1970 return TRUE; /* ok as "user" */
1971 }
d8eceb89 1972 else if (ingroup(statbufp->st_gid,effective)) {
7f4774ae 1973 if (statbufp->st_mode & mode >> 3)
a687059c
LW
1974 return TRUE; /* ok as "group" */
1975 }
7f4774ae 1976 else if (statbufp->st_mode & mode >> 6)
a687059c
LW
1977 return TRUE; /* ok as "other" */
1978 return FALSE;
55497cff 1979#endif /* ! DOSISH */
a687059c 1980}
a0d0e21e 1981#endif /* ! VMS */
a687059c 1982
1f676739 1983static bool
0da8eb3a 1984S_ingroup(pTHX_ Gid_t testgid, bool effective)
a687059c 1985{
97aff369 1986 dVAR;
985213f2 1987 if (testgid == (effective ? PerlProc_getegid() : PerlProc_getgid()))
a687059c 1988 return TRUE;
fe14fcc3 1989#ifdef HAS_GETGROUPS
a687059c 1990 {
331b57bc 1991 Groups_t *gary = NULL;
79072805 1992 I32 anum;
331b57bc 1993 bool rc = FALSE;
a687059c 1994
331b57bc
SP
1995 anum = getgroups(0, gary);
1996 Newx(gary, anum, Groups_t);
1997 anum = getgroups(anum, gary);
a687059c 1998 while (--anum >= 0)
331b57bc
SP
1999 if (gary[anum] == testgid) {
2000 rc = TRUE;
2001 break;
2002 }
2003
2004 Safefree(gary);
2005 return rc;
a687059c 2006 }
c685562b 2007#else
a687059c 2008 return FALSE;
cd39f2b6 2009#endif
a687059c 2010}
c2ab57d4 2011
fe14fcc3 2012#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
c2ab57d4 2013
79072805 2014I32
864dbfa3 2015Perl_do_ipcget(pTHX_ I32 optype, SV **mark, SV **sp)
c2ab57d4 2016{
97aff369 2017 dVAR;
0bcc34c2 2018 const key_t key = (key_t)SvNVx(*++mark);
c3312966 2019 SV *nsv = optype == OP_MSGGET ? NULL : *++mark;
6867be6d 2020 const I32 flags = SvIVx(*++mark);
294a48e9 2021
7918f24d 2022 PERL_ARGS_ASSERT_DO_IPCGET;
294a48e9 2023 PERL_UNUSED_ARG(sp);
c2ab57d4 2024
748a9306 2025 SETERRNO(0,0);
c2ab57d4
LW
2026 switch (optype)
2027 {
fe14fcc3 2028#ifdef HAS_MSG
79072805 2029 case OP_MSGGET:
c2ab57d4 2030 return msgget(key, flags);
e5d73d77 2031#endif
fe14fcc3 2032#ifdef HAS_SEM
79072805 2033 case OP_SEMGET:
c3312966 2034 return semget(key, (int) SvIV(nsv), flags);
e5d73d77 2035#endif
fe14fcc3 2036#ifdef HAS_SHM
79072805 2037 case OP_SHMGET:
c3312966 2038 return shmget(key, (size_t) SvUV(nsv), flags);
e5d73d77 2039#endif
fe14fcc3 2040#if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
e5d73d77 2041 default:
fe13d51d 2042 /* diag_listed_as: msg%s not implemented */
cea2e8a9 2043 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
e5d73d77 2044#endif
c2ab57d4
LW
2045 }
2046 return -1; /* should never happen */
2047}
2048
79072805 2049I32
864dbfa3 2050Perl_do_ipcctl(pTHX_ I32 optype, SV **mark, SV **sp)
c2ab57d4 2051{
97aff369 2052 dVAR;
c2ab57d4 2053 char *a;
a0d0e21e 2054 I32 ret = -1;
6867be6d 2055 const I32 id = SvIVx(*++mark);
95b63a38 2056#ifdef Semctl
6867be6d 2057 const I32 n = (optype == OP_SEMCTL) ? SvIVx(*++mark) : 0;
95b63a38 2058#endif
6867be6d 2059 const I32 cmd = SvIVx(*++mark);
0bcc34c2
AL
2060 SV * const astr = *++mark;
2061 STRLEN infosize = 0;
2062 I32 getinfo = (cmd == IPC_STAT);
c2ab57d4 2063
7918f24d 2064 PERL_ARGS_ASSERT_DO_IPCCTL;
0bcc34c2 2065 PERL_UNUSED_ARG(sp);
c2ab57d4
LW
2066
2067 switch (optype)
2068 {
fe14fcc3 2069#ifdef HAS_MSG
79072805 2070 case OP_MSGCTL:
c2ab57d4
LW
2071 if (cmd == IPC_STAT || cmd == IPC_SET)
2072 infosize = sizeof(struct msqid_ds);
2073 break;
e5d73d77 2074#endif
fe14fcc3 2075#ifdef HAS_SHM
79072805 2076 case OP_SHMCTL:
c2ab57d4
LW
2077 if (cmd == IPC_STAT || cmd == IPC_SET)
2078 infosize = sizeof(struct shmid_ds);
2079 break;
e5d73d77 2080#endif
fe14fcc3 2081#ifdef HAS_SEM
79072805 2082 case OP_SEMCTL:
39398f3f 2083#ifdef Semctl
c2ab57d4
LW
2084 if (cmd == IPC_STAT || cmd == IPC_SET)
2085 infosize = sizeof(struct semid_ds);
2086 else if (cmd == GETALL || cmd == SETALL)
2087 {
8e591e46 2088 struct semid_ds semds;
bd89102f 2089 union semun semun;
e6f0bdd6
GS
2090#ifdef EXTRA_F_IN_SEMUN_BUF
2091 semun.buff = &semds;
2092#else
84902520 2093 semun.buf = &semds;
e6f0bdd6 2094#endif
c2ab57d4 2095 getinfo = (cmd == GETALL);
9b89d93d
GB
2096 if (Semctl(id, 0, IPC_STAT, semun) == -1)
2097 return -1;
6e21c824
LW
2098 infosize = semds.sem_nsems * sizeof(short);
2099 /* "short" is technically wrong but much more portable
2100 than guessing about u_?short(_t)? */
c2ab57d4 2101 }
39398f3f 2102#else
fe13d51d 2103 /* diag_listed_as: sem%s not implemented */
cea2e8a9 2104 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
39398f3f 2105#endif
c2ab57d4 2106 break;
e5d73d77 2107#endif
fe14fcc3 2108#if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
e5d73d77 2109 default:
fe13d51d 2110 /* diag_listed_as: shm%s not implemented */
cea2e8a9 2111 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
e5d73d77 2112#endif
c2ab57d4
LW
2113 }
2114
2115 if (infosize)
2116 {
2117 if (getinfo)
2118 {
93524f2b 2119 SvPV_force_nolen(astr);
a0d0e21e 2120 a = SvGROW(astr, infosize+1);
c2ab57d4
LW
2121 }
2122 else
2123 {
93524f2b 2124 STRLEN len;
463ee0b2
LW
2125 a = SvPV(astr, len);
2126 if (len != infosize)
cea2e8a9 2127 Perl_croak(aTHX_ "Bad arg length for %s, is %lu, should be %ld",
4ec43091
JH
2128 PL_op_desc[optype],
2129 (unsigned long)len,
2130 (long)infosize);
c2ab57d4
LW
2131 }
2132 }
2133 else
2134 {
0bcc34c2 2135 const IV i = SvIV(astr);
56431972 2136 a = INT2PTR(char *,i); /* ouch */
c2ab57d4 2137 }
748a9306 2138 SETERRNO(0,0);
c2ab57d4
LW
2139 switch (optype)
2140 {
fe14fcc3 2141#ifdef HAS_MSG
79072805 2142 case OP_MSGCTL:
bee1dbe2 2143 ret = msgctl(id, cmd, (struct msqid_ds *)a);
c2ab57d4 2144 break;
e5d73d77 2145#endif
fe14fcc3 2146#ifdef HAS_SEM
bd89102f 2147 case OP_SEMCTL: {
39398f3f 2148#ifdef Semctl
bd89102f
AD
2149 union semun unsemds;
2150
64d76282
BC
2151 if(cmd == SETVAL) {
2152 unsemds.val = PTR2nat(a);
2153 }
2154 else {
e6f0bdd6 2155#ifdef EXTRA_F_IN_SEMUN_BUF
64d76282 2156 unsemds.buff = (struct semid_ds *)a;
e6f0bdd6 2157#else
64d76282 2158 unsemds.buf = (struct semid_ds *)a;
e6f0bdd6 2159#endif
64d76282 2160 }
bd89102f 2161 ret = Semctl(id, n, cmd, unsemds);
39398f3f 2162#else
fe13d51d 2163 /* diag_listed_as: sem%s not implemented */
cea2e8a9 2164 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
39398f3f 2165#endif
bd89102f 2166 }
c2ab57d4 2167 break;
e5d73d77 2168#endif
fe14fcc3 2169#ifdef HAS_SHM
79072805 2170 case OP_SHMCTL:
bee1dbe2 2171 ret = shmctl(id, cmd, (struct shmid_ds *)a);
c2ab57d4 2172 break;
e5d73d77 2173#endif
c2ab57d4
LW
2174 }
2175 if (getinfo && ret >= 0) {
79072805
LW
2176 SvCUR_set(astr, infosize);
2177 *SvEND(astr) = '\0';
a0d0e21e 2178 SvSETMAGIC(astr);
c2ab57d4
LW
2179 }
2180 return ret;
2181}
2182
79072805 2183I32
864dbfa3 2184Perl_do_msgsnd(pTHX_ SV **mark, SV **sp)
c2ab57d4 2185{
97aff369 2186 dVAR;
fe14fcc3 2187#ifdef HAS_MSG
463ee0b2 2188 STRLEN len;
6867be6d 2189 const I32 id = SvIVx(*++mark);
0bcc34c2
AL
2190 SV * const mstr = *++mark;
2191 const I32 flags = SvIVx(*++mark);
2192 const char * const mbuf = SvPV_const(mstr, len);
2193 const I32 msize = len - sizeof(long);
2194
7918f24d 2195 PERL_ARGS_ASSERT_DO_MSGSND;
890ce7af 2196 PERL_UNUSED_ARG(sp);
c2ab57d4 2197
0bcc34c2 2198 if (msize < 0)
cea2e8a9 2199 Perl_croak(aTHX_ "Arg too short for msgsnd");
748a9306 2200 SETERRNO(0,0);
bee1dbe2 2201 return msgsnd(id, (struct msgbuf *)mbuf, msize, flags);
e5d73d77 2202#else
2d51fa4d
RGS
2203 PERL_UNUSED_ARG(sp);
2204 PERL_UNUSED_ARG(mark);
fe13d51d 2205 /* diag_listed_as: msg%s not implemented */
cea2e8a9 2206 Perl_croak(aTHX_ "msgsnd not implemented");
7c522378 2207 return -1;
e5d73d77 2208#endif
c2ab57d4
LW
2209}
2210
79072805 2211I32
864dbfa3 2212Perl_do_msgrcv(pTHX_ SV **mark, SV **sp)
c2ab57d4 2213{
fe14fcc3 2214#ifdef HAS_MSG
97aff369 2215 dVAR;
c2ab57d4
LW
2216 char *mbuf;
2217 long mtype;
6867be6d 2218 I32 msize, flags, ret;
6867be6d 2219 const I32 id = SvIVx(*++mark);
0bcc34c2 2220 SV * const mstr = *++mark;
7918f24d
NC
2221
2222 PERL_ARGS_ASSERT_DO_MSGRCV;
890ce7af 2223 PERL_UNUSED_ARG(sp);
79072805 2224
c2e66d9e
GS
2225 /* suppress warning when reading into undef var --jhi */
2226 if (! SvOK(mstr))
76f68e9b 2227 sv_setpvs(mstr, "");
463ee0b2
LW
2228 msize = SvIVx(*++mark);
2229 mtype = (long)SvIVx(*++mark);
2230 flags = SvIVx(*++mark);
93524f2b 2231 SvPV_force_nolen(mstr);
a0d0e21e 2232 mbuf = SvGROW(mstr, sizeof(long)+msize+1);
a1d180c4 2233
748a9306 2234 SETERRNO(0,0);
bee1dbe2 2235 ret = msgrcv(id, (struct msgbuf *)mbuf, msize, mtype, flags);
c2ab57d4 2236 if (ret >= 0) {
79072805
LW
2237 SvCUR_set(mstr, sizeof(long)+ret);
2238 *SvEND(mstr) = '\0';
41d6edb2
JH
2239 /* who knows who has been playing with this message? */
2240 SvTAINTED_on(mstr);
c2ab57d4
LW
2241 }
2242 return ret;
e5d73d77 2243#else
2d51fa4d
RGS
2244 PERL_UNUSED_ARG(sp);
2245 PERL_UNUSED_ARG(mark);
fe13d51d 2246 /* diag_listed_as: msg%s not implemented */
cea2e8a9 2247 Perl_croak(aTHX_ "msgrcv not implemented");
7c522378 2248 return -1;
e5d73d77 2249#endif
c2ab57d4
LW
2250}
2251
79072805 2252I32
864dbfa3 2253Perl_do_semop(pTHX_ SV **mark, SV **sp)
c2ab57d4 2254{
fe14fcc3 2255#ifdef HAS_SEM
97aff369 2256 dVAR;
463ee0b2 2257 STRLEN opsize;
6867be6d 2258 const I32 id = SvIVx(*++mark);
0bcc34c2
AL
2259 SV * const opstr = *++mark;
2260 const char * const opbuf = SvPV_const(opstr, opsize);
7918f24d
NC
2261
2262 PERL_ARGS_ASSERT_DO_SEMOP;
890ce7af 2263 PERL_UNUSED_ARG(sp);
c2ab57d4 2264
248ff010
NC
2265 if (opsize < 3 * SHORTSIZE
2266 || (opsize % (3 * SHORTSIZE))) {
93189314 2267 SETERRNO(EINVAL,LIB_INVARG);
c2ab57d4
LW
2268 return -1;
2269 }
748a9306 2270 SETERRNO(0,0);
248ff010
NC
2271 /* We can't assume that sizeof(struct sembuf) == 3 * sizeof(short). */
2272 {
6867be6d 2273 const int nsops = opsize / (3 * sizeof (short));
248ff010 2274 int i = nsops;
0bcc34c2 2275 short * const ops = (short *) opbuf;
248ff010
NC
2276 short *o = ops;
2277 struct sembuf *temps, *t;
2278 I32 result;
2279
a02a5408 2280 Newx (temps, nsops, struct sembuf);
248ff010
NC
2281 t = temps;
2282 while (i--) {
2283 t->sem_num = *o++;
2284 t->sem_op = *o++;
2285 t->sem_flg = *o++;
2286 t++;
2287 }
2288 result = semop(id, temps, nsops);
248ff010
NC
2289 Safefree(temps);
2290 return result;
2291 }
e5d73d77 2292#else
fe13d51d 2293 /* diag_listed_as: sem%s not implemented */
cea2e8a9 2294 Perl_croak(aTHX_ "semop not implemented");
e5d73d77 2295#endif
c2ab57d4
LW
2296}
2297
79072805 2298I32
864dbfa3 2299Perl_do_shmio(pTHX_ I32 optype, SV **mark, SV **sp)
c2ab57d4 2300{
fe14fcc3 2301#ifdef HAS_SHM
97aff369 2302 dVAR;
4373e329 2303 char *shm;
c2ab57d4 2304 struct shmid_ds shmds;
6867be6d 2305 const I32 id = SvIVx(*++mark);
0bcc34c2
AL
2306 SV * const mstr = *++mark;
2307 const I32 mpos = SvIVx(*++mark);
2308 const I32 msize = SvIVx(*++mark);
7918f24d
NC
2309
2310 PERL_ARGS_ASSERT_DO_SHMIO;
890ce7af 2311 PERL_UNUSED_ARG(sp);
c2ab57d4 2312
748a9306 2313 SETERRNO(0,0);
c2ab57d4
LW
2314 if (shmctl(id, IPC_STAT, &shmds) == -1)
2315 return -1;
7f39519f
NC
2316 if (mpos < 0 || msize < 0
2317 || (size_t)mpos + msize > (size_t)shmds.shm_segsz) {
93189314 2318 SETERRNO(EFAULT,SS_ACCVIO); /* can't do as caller requested */
c2ab57d4
LW
2319 return -1;
2320 }
d4c19fe8 2321 shm = (char *)shmat(id, NULL, (optype == OP_SHMREAD) ? SHM_RDONLY : 0);
c2ab57d4
LW
2322 if (shm == (char *)-1) /* I hate System V IPC, I really do */
2323 return -1;
79072805 2324 if (optype == OP_SHMREAD) {
c8ae91a8 2325 char *mbuf;
9f538c04 2326 /* suppress warning when reading into undef var (tchrist 3/Mar/00) */
b399897d
CS
2327 SvGETMAGIC(mstr);
2328 SvUPGRADE(mstr, SVt_PV);
9f538c04 2329 if (! SvOK(mstr))
76f68e9b 2330 sv_setpvs(mstr, "");
af8ff727 2331 SvPOK_only(mstr);
bb7a0f54 2332 mbuf = SvGROW(mstr, (STRLEN)msize+1);
a0d0e21e 2333
bee1dbe2 2334 Copy(shm + mpos, mbuf, msize, char);
79072805
LW
2335 SvCUR_set(mstr, msize);
2336 *SvEND(mstr) = '\0';
a0d0e21e 2337 SvSETMAGIC(mstr);
d929ce6f
JH
2338 /* who knows who has been playing with this shared memory? */
2339 SvTAINTED_on(mstr);
c2ab57d4
LW
2340 }
2341 else {
93524f2b 2342 STRLEN len;
c2ab57d4 2343
93524f2b 2344 const char *mbuf = SvPV_const(mstr, len);
027aa12d 2345 const I32 n = ((I32)len > msize) ? msize : (I32)len;
bee1dbe2 2346 Copy(mbuf, shm + mpos, n, char);
c2ab57d4 2347 if (n < msize)
bee1dbe2 2348 memzero(shm + mpos + n, msize - n);
c2ab57d4
LW
2349 }
2350 return shmdt(shm);
e5d73d77 2351#else
fe13d51d 2352 /* diag_listed_as: shm%s not implemented */
cea2e8a9 2353 Perl_croak(aTHX_ "shm I/O not implemented");
7c522378 2354 return -1;
e5d73d77 2355#endif
c2ab57d4
LW
2356}
2357
fe14fcc3 2358#endif /* SYSV IPC */
4e35701f 2359
0d44d22b 2360/*
ccfc67b7
JH
2361=head1 IO Functions
2362
0d44d22b
NC
2363=for apidoc start_glob
2364
2365Function called by C<do_readline> to spawn a glob (or do the glob inside
154e47c8 2366perl on VMS). This code used to be inline, but now perl uses C<File::Glob>
210b36aa 2367this glob starter is only used by miniperl during the build process.
0d44d22b 2368Moving it away shrinks pp_hot.c; shrinking pp_hot.c helps speed perl up.
fab3f3a7 2369
0d44d22b
NC
2370=cut
2371*/
2372
2373PerlIO *
2374Perl_start_glob (pTHX_ SV *tmpglob, IO *io)
2375{
27da23d5 2376 dVAR;
561b68a9 2377 SV * const tmpcmd = newSV(0);
0d44d22b 2378 PerlIO *fp;
41188aa0
TC
2379 STRLEN len;
2380 const char *s = SvPV(tmpglob, len);
7918f24d
NC
2381
2382 PERL_ARGS_ASSERT_START_GLOB;
2383
41188aa0 2384 if (!IS_SAFE_SYSCALL(s, len, "pattern", "glob"))
c8028aa6
TC
2385 return NULL;
2386
0d44d22b
NC
2387 ENTER;
2388 SAVEFREESV(tmpcmd);
2389#ifdef VMS /* expand the wildcards right here, rather than opening a pipe, */
2390 /* since spawning off a process is a real performance hit */
dca5a913
JM
2391
2392PerlIO *
2393Perl_vms_start_glob
2394 (pTHX_ SV *tmpglob,
2395 IO *io);
2396
49a7a762 2397 fp = Perl_vms_start_glob(aTHX_ tmpglob, io);
dca5a913 2398
0d44d22b 2399#else /* !VMS */
0d44d22b
NC
2400#ifdef DOSISH
2401#ifdef OS2
2402 sv_setpv(tmpcmd, "for a in ");
2403 sv_catsv(tmpcmd, tmpglob);
2404 sv_catpv(tmpcmd, "; do echo \"$a\\0\\c\"; done |");
2405#else
2406#ifdef DJGPP
2407 sv_setpv(tmpcmd, "/dev/dosglob/"); /* File System Extension */
2408 sv_catsv(tmpcmd, tmpglob);
2409#else
2410 sv_setpv(tmpcmd, "perlglob ");
2411 sv_catsv(tmpcmd, tmpglob);
2412 sv_catpv(tmpcmd, " |");
2413#endif /* !DJGPP */
2414#endif /* !OS2 */
2415#else /* !DOSISH */
2416#if defined(CSH)
2417 sv_setpvn(tmpcmd, PL_cshname, PL_cshlen);
2418 sv_catpv(tmpcmd, " -cf 'set nonomatch; glob ");
2419 sv_catsv(tmpcmd, tmpglob);
2420 sv_catpv(tmpcmd, "' 2>/dev/null |");
2421#else
2422 sv_setpv(tmpcmd, "echo ");
2423 sv_catsv(tmpcmd, tmpglob);
0d44d22b 2424 sv_catpv(tmpcmd, "|tr -s ' \t\f\r' '\\n\\n\\n\\n'|");
0d44d22b
NC
2425#endif /* !CSH */
2426#endif /* !DOSISH */
93b2dae1
FC
2427 {
2428 GV * const envgv = gv_fetchpvs("ENV", 0, SVt_PVHV);
2429 SV ** const home = hv_fetchs(GvHV(envgv), "HOME", 0);
25018358 2430 SV ** const path = hv_fetchs(GvHV(envgv), "PATH", 0);
93b2dae1 2431 if (home && *home) SvGETMAGIC(*home);
25018358 2432 if (path && *path) SvGETMAGIC(*path);
93b2dae1
FC
2433 save_hash(gv_fetchpvs("ENV", 0, SVt_PVHV));
2434 if (home && *home) SvSETMAGIC(*home);
25018358 2435 if (path && *path) SvSETMAGIC(*path);
93b2dae1 2436 }
93524f2b 2437 (void)do_open(PL_last_in_gv, (char*)SvPVX_const(tmpcmd), SvCUR(tmpcmd),
4608196e 2438 FALSE, O_RDONLY, 0, NULL);
0d44d22b
NC
2439 fp = IoIFP(io);
2440#endif /* !VMS */
2441 LEAVE;
de7dabb6
TC
2442
2443 if (!fp && ckWARN(WARN_GLOB)) {
2444 Perl_warner(aTHX_ packWARN(WARN_GLOB), "glob failed (can't start child: %s)",
2445 Strerror(errno));
2446 }
2447
0d44d22b
NC
2448 return fp;
2449}
66610fdd
RGS
2450
2451/*
2452 * Local variables:
2453 * c-indentation-style: bsd
2454 * c-basic-offset: 4
14d04a33 2455 * indent-tabs-mode: nil
66610fdd
RGS
2456 * End:
2457 *
14d04a33 2458 * ex: set ts=8 sts=4 sw=4 et:
37442d52 2459 */