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