This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Magic flags harmonization.
[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
2fbb330f 64Perl_do_openn(pTHX_ GV *gv, register 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;
890ce7af 69 register 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()))
626 Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT", newname);
627 if (fd == PerlIO_fileno(PerlIO_stderr()))
628 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR", newname);
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 *
864dbfa3 709Perl_nextargv(pTHX_ register GV *gv)
a687059c 710{
97aff369 711 dVAR;
79072805 712 register 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
2585f9a3 809#if !defined(DOSISH) && !defined(__CYGWIN__) && !defined(EPOC)
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
GS
910 setdefout(oldout);
911 SvREFCNT_dec(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;
0bcc34c2 997 register 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);
96e4d5b1 1043 register 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);
137443ea 1064 register 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);
8903cb82
PP
1083 register PerlIO *fp;
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
864dbfa3 1202Perl_do_print(pTHX_ register 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;
0bd48802 1336 static const char no_prev_lstat[] = "The stat preceding -l _ wasn't an lstat";
39644a26 1337 dSP;
b16276bb 1338 const char *file;
533c011a 1339 if (PL_op->op_flags & OPf_REF) {
638eceb6 1340 if (cGVOP_gv == PL_defgv) {
3280af22 1341 if (PL_laststype != OP_LSTAT)
fbb0b3b3 1342 Perl_croak(aTHX_ no_prev_lstat);
3280af22 1343 return PL_laststatval;
fe14fcc3 1344 }
31b139ba 1345 PL_laststatval = -1;
5d3e98de 1346 if (ckWARN(WARN_IO)) {
d0c0e7dd
FC
1347 Perl_warner(aTHX_ packWARN(WARN_IO),
1348 "Use of -l on filehandle %"HEKf,
1349 HEKfARG(GvENAME_HEK(cGVOP_gv)));
5d3e98de 1350 }
31b139ba 1351 return -1;
fe14fcc3 1352 }
8db8f6b6
FC
1353 if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t))
1354 == OPpFT_STACKED) {
1f26655e 1355 if (PL_laststype != OP_LSTAT)
fbb0b3b3 1356 Perl_croak(aTHX_ no_prev_lstat);
1f26655e
FC
1357 return PL_laststatval;
1358 }
c623bd54 1359
3280af22 1360 PL_laststype = OP_LSTAT;
a0714e2c 1361 PL_statgv = NULL;
d2c4d2d1 1362 file = SvPV_flags_const_nolen(TOPs, flags);
b16276bb
VP
1363 sv_setpv(PL_statname,file);
1364 PL_laststatval = PerlLIO_lstat(file,&PL_statcache);
1365 if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && strchr(file, '\n'))
9014280d 1366 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "lstat");
3280af22 1367 return PL_laststatval;
c623bd54
LW
1368}
1369
a0f2c8ec
JD
1370static void
1371S_exec_failed(pTHX_ const char *cmd, int fd, int do_report)
1372{
1373 const int e = errno;
7918f24d 1374 PERL_ARGS_ASSERT_EXEC_FAILED;
a0f2c8ec
JD
1375 if (ckWARN(WARN_EXEC))
1376 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't exec \"%s\": %s",
1377 cmd, Strerror(e));
1378 if (do_report) {
1379 PerlLIO_write(fd, (void*)&e, sizeof(int));
1380 PerlLIO_close(fd);
1381 }
1382}
1383
d5a9bfb0 1384bool
2aa1486d
GS
1385Perl_do_aexec5(pTHX_ SV *really, register SV **mark, register SV **sp,
1386 int fd, int do_report)
d5a9bfb0 1387{
27da23d5 1388 dVAR;
7918f24d 1389 PERL_ARGS_ASSERT_DO_AEXEC5;
e37778c2 1390#if defined(__SYMBIAN32__) || defined(__LIBCATAMOUNT__)
cd39f2b6
JH
1391 Perl_croak(aTHX_ "exec? I'm not *that* kind of operating system");
1392#else
79072805 1393 if (sp > mark) {
360ea906 1394 const char **a;
6136c704 1395 const char *tmps = NULL;
360ea906 1396 Newx(PL_Argv, sp - mark + 1, const char*);
c3c5fad7 1397 a = PL_Argv;
890ce7af 1398
79072805
LW
1399 while (++mark <= sp) {
1400 if (*mark)
360ea906 1401 *a++ = SvPV_nolen_const(*mark);
a687059c
LW
1402 else
1403 *a++ = "";
1404 }
6136c704 1405 *a = NULL;
91b2752f 1406 if (really)
e62f0680 1407 tmps = SvPV_nolen_const(really);
91b2752f
RG
1408 if ((!really && *PL_Argv[0] != '/') ||
1409 (really && *tmps != '/')) /* will execvp use PATH? */
79072805 1410 TAINT_ENV(); /* testing IFS here is overkill, probably */
b35112e7 1411 PERL_FPU_PRE_EXEC
91b2752f 1412 if (really && *tmps)
b4748376 1413 PerlProc_execvp(tmps,EXEC_ARGV_CAST(PL_Argv));
a687059c 1414 else
b4748376 1415 PerlProc_execvp(PL_Argv[0],EXEC_ARGV_CAST(PL_Argv));
b35112e7 1416 PERL_FPU_POST_EXEC
a0f2c8ec 1417 S_exec_failed(aTHX_ (really ? tmps : PL_Argv[0]), fd, do_report);
a687059c 1418 }
bee1dbe2 1419 do_execfree();
cd39f2b6 1420#endif
a687059c
LW
1421 return FALSE;
1422}
1423
fe14fcc3 1424void
864dbfa3 1425Perl_do_execfree(pTHX)
ff8e2863 1426{
97aff369 1427 dVAR;
43c5f42d 1428 Safefree(PL_Argv);
4608196e 1429 PL_Argv = NULL;
43c5f42d 1430 Safefree(PL_Cmd);
bd61b366 1431 PL_Cmd = NULL;
ff8e2863
LW
1432}
1433
9555a685 1434#ifdef PERL_DEFAULT_DO_EXEC3_IMPLEMENTATION
e446cec8
IZ
1435
1436bool
2fbb330f 1437Perl_do_exec3(pTHX_ const char *incmd, int fd, int do_report)
e446cec8 1438{
27da23d5 1439 dVAR;
360ea906 1440 register const char **a;
a687059c 1441 register char *s;
15db3ae2 1442 char *buf;
2fbb330f 1443 char *cmd;
2fbb330f 1444 /* Make a copy so we can change it */
6fca0082 1445 const Size_t cmdlen = strlen(incmd) + 1;
7918f24d
NC
1446
1447 PERL_ARGS_ASSERT_DO_EXEC3;
1448
15db3ae2
DM
1449 Newx(buf, cmdlen, char);
1450 cmd = buf;
cfff9797 1451 memcpy(cmd, incmd, cmdlen);
a687059c 1452
748a9306
LW
1453 while (*cmd && isSPACE(*cmd))
1454 cmd++;
1455
a687059c
LW
1456 /* save an extra exec if possible */
1457
bf38876a 1458#ifdef CSH
d05c1ba0 1459 {
0c19750d 1460 char flags[PERL_FLAGS_MAX];
d05c1ba0
JH
1461 if (strnEQ(cmd,PL_cshname,PL_cshlen) &&
1462 strnEQ(cmd+PL_cshlen," -c",3)) {
28f0d0ec 1463 my_strlcpy(flags, "-c", PERL_FLAGS_MAX);
d05c1ba0
JH
1464 s = cmd+PL_cshlen+3;
1465 if (*s == 'f') {
1466 s++;
28f0d0ec 1467 my_strlcat(flags, "f", PERL_FLAGS_MAX - 2);
d05c1ba0
JH
1468 }
1469 if (*s == ' ')
1470 s++;
1471 if (*s++ == '\'') {
0bcc34c2 1472 char * const ncmd = s;
d05c1ba0
JH
1473
1474 while (*s)
1475 s++;
1476 if (s[-1] == '\n')
1477 *--s = '\0';
1478 if (s[-1] == '\'') {
1479 *--s = '\0';
b35112e7 1480 PERL_FPU_PRE_EXEC
7c0dd7ca 1481 PerlProc_execl(PL_cshname, "csh", flags, ncmd, (char*)NULL);
b35112e7 1482 PERL_FPU_POST_EXEC
d05c1ba0 1483 *s = '\'';
a0f2c8ec 1484 S_exec_failed(aTHX_ PL_cshname, fd, do_report);
15db3ae2 1485 Safefree(buf);
d05c1ba0
JH
1486 return FALSE;
1487 }
1488 }
a687059c
LW
1489 }
1490 }
bf38876a 1491#endif /* CSH */
a687059c
LW
1492
1493 /* see if there are shell metacharacters in it */
1494
748a9306
LW
1495 if (*cmd == '.' && isSPACE(cmd[1]))
1496 goto doshell;
1497
1498 if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
1499 goto doshell;
1500
294b3b39
AL
1501 s = cmd;
1502 while (isALNUM(*s))
1503 s++; /* catch VAR=val gizmo */
63f2c1e1
LW
1504 if (*s == '=')
1505 goto doshell;
748a9306 1506
a687059c 1507 for (s = cmd; *s; s++) {
d05c1ba0
JH
1508 if (*s != ' ' && !isALPHA(*s) &&
1509 strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
a687059c
LW
1510 if (*s == '\n' && !s[1]) {
1511 *s = '\0';
1512 break;
1513 }
603a98b0
IZ
1514 /* handle the 2>&1 construct at the end */
1515 if (*s == '>' && s[1] == '&' && s[2] == '1'
1516 && s > cmd + 1 && s[-1] == '2' && isSPACE(s[-2])
1517 && (!s[3] || isSPACE(s[3])))
1518 {
6867be6d 1519 const char *t = s + 3;
603a98b0
IZ
1520
1521 while (*t && isSPACE(*t))
1522 ++t;
943bbd07 1523 if (!*t && (PerlLIO_dup2(1,2) != -1)) {
603a98b0
IZ
1524 s[-2] = '\0';
1525 break;
1526 }
1527 }
a687059c 1528 doshell:
b35112e7 1529 PERL_FPU_PRE_EXEC
7c0dd7ca 1530 PerlProc_execl(PL_sh_path, "sh", "-c", cmd, (char *)NULL);
b35112e7 1531 PERL_FPU_POST_EXEC
a0f2c8ec 1532 S_exec_failed(aTHX_ PL_sh_path, fd, do_report);
15db3ae2 1533 Safefree(buf);
a687059c
LW
1534 return FALSE;
1535 }
1536 }
748a9306 1537
360ea906 1538 Newx(PL_Argv, (s - cmd) / 2 + 2, const char*);
3280af22
NIS
1539 PL_Cmd = savepvn(cmd, s-cmd);
1540 a = PL_Argv;
1541 for (s = PL_Cmd; *s;) {
294b3b39
AL
1542 while (isSPACE(*s))
1543 s++;
a687059c
LW
1544 if (*s)
1545 *(a++) = s;
294b3b39
AL
1546 while (*s && !isSPACE(*s))
1547 s++;
a687059c
LW
1548 if (*s)
1549 *s++ = '\0';
1550 }
6136c704 1551 *a = NULL;
3280af22 1552 if (PL_Argv[0]) {
b35112e7 1553 PERL_FPU_PRE_EXEC
360ea906 1554 PerlProc_execvp(PL_Argv[0],EXEC_ARGV_CAST(PL_Argv));
b35112e7 1555 PERL_FPU_POST_EXEC
b1248f16 1556 if (errno == ENOEXEC) { /* for system V NIH syndrome */
ff8e2863 1557 do_execfree();
a687059c 1558 goto doshell;
b1248f16 1559 }
a0f2c8ec 1560 S_exec_failed(aTHX_ PL_Argv[0], fd, do_report);
a687059c 1561 }
ff8e2863 1562 do_execfree();
15db3ae2 1563 Safefree(buf);
a687059c
LW
1564 return FALSE;
1565}
1566
6890e559 1567#endif /* OS2 || WIN32 */
760ac839 1568
25bbd826
CB
1569#ifdef VMS
1570#include <starlet.h> /* for sys$delprc */
1571#endif
1572
79072805 1573I32
864dbfa3 1574Perl_apply(pTHX_ I32 type, register SV **mark, register SV **sp)
a687059c 1575{
97aff369 1576 dVAR;
79072805 1577 register I32 val;
79072805 1578 register I32 tot = 0;
4634a855 1579 const char *const what = PL_op_name[type];
5c144d81 1580 const char *s;
84c7b88c 1581 STRLEN len;
890ce7af 1582 SV ** const oldmark = mark;
885b4b39 1583 bool killgp = FALSE;
a687059c 1584
7918f24d
NC
1585 PERL_ARGS_ASSERT_APPLY;
1586
1444765e
NC
1587 /* Doing this ahead of the switch statement preserves the old behaviour,
1588 where attempting to use kill as a taint test test would fail on
1589 platforms where kill was not defined. */
1590#ifndef HAS_KILL
1591 if (type == OP_KILL)
4634a855 1592 Perl_die(aTHX_ PL_no_func, what);
1444765e
NC
1593#endif
1594#ifndef HAS_CHOWN
1595 if (type == OP_CHOWN)
4634a855 1596 Perl_die(aTHX_ PL_no_func, what);
1444765e
NC
1597#endif
1598
1599
20408e3c 1600#define APPLY_TAINT_PROPER() \
3280af22 1601 STMT_START { \
17406bd6 1602 if (PL_tainted) { TAINT_PROPER(what); } \
873ef191 1603 } STMT_END
20408e3c
GS
1604
1605 /* This is a first heuristic; it doesn't catch tainting magic. */
3280af22 1606 if (PL_tainting) {
463ee0b2 1607 while (++mark <= sp) {
bbce6d69
PP
1608 if (SvTAINTED(*mark)) {
1609 TAINT;
1610 break;
1611 }
463ee0b2
LW
1612 }
1613 mark = oldmark;
1614 }
a687059c 1615 switch (type) {
79072805 1616 case OP_CHMOD:
20408e3c 1617 APPLY_TAINT_PROPER();
79072805 1618 if (++mark <= sp) {
4ea561bc 1619 val = SvIV(*mark);
20408e3c
GS
1620 APPLY_TAINT_PROPER();
1621 tot = sp - mark;
79072805 1622 while (++mark <= sp) {
c4aca7d0 1623 GV* gv;
2ea1cce7 1624 if ((gv = MAYBE_DEREF_GV(*mark))) {
c4aca7d0
GA
1625 if (GvIO(gv) && IoIFP(GvIOp(gv))) {
1626#ifdef HAS_FCHMOD
1627 APPLY_TAINT_PROPER();
1628 if (fchmod(PerlIO_fileno(IoIFP(GvIOn(gv))), val))
1629 tot--;
1630#else
b9c6780e 1631 Perl_die(aTHX_ PL_no_func, "fchmod");
c4aca7d0
GA
1632#endif
1633 }
1634 else {
1635 tot--;
1636 }
1637 }
c4aca7d0 1638 else {
93564729 1639 const char *name = SvPV_nomg_const_nolen(*mark);
c4aca7d0
GA
1640 APPLY_TAINT_PROPER();
1641 if (PerlLIO_chmod(name, val))
1642 tot--;
1643 }
a687059c
LW
1644 }
1645 }
1646 break;
fe14fcc3 1647#ifdef HAS_CHOWN
79072805 1648 case OP_CHOWN:
20408e3c 1649 APPLY_TAINT_PROPER();
79072805 1650 if (sp - mark > 2) {
6867be6d 1651 register I32 val2;
463ee0b2
LW
1652 val = SvIVx(*++mark);
1653 val2 = SvIVx(*++mark);
20408e3c 1654 APPLY_TAINT_PROPER();
a0d0e21e 1655 tot = sp - mark;
79072805 1656 while (++mark <= sp) {
c4aca7d0 1657 GV* gv;
2ea1cce7 1658 if ((gv = MAYBE_DEREF_GV(*mark))) {
c4aca7d0
GA
1659 if (GvIO(gv) && IoIFP(GvIOp(gv))) {
1660#ifdef HAS_FCHOWN
1661 APPLY_TAINT_PROPER();
1662 if (fchown(PerlIO_fileno(IoIFP(GvIOn(gv))), val, val2))
1663 tot--;
1664#else
b9c6780e 1665 Perl_die(aTHX_ PL_no_func, "fchown");
c4aca7d0
GA
1666#endif
1667 }
1668 else {
1669 tot--;
1670 }
1671 }
c4aca7d0 1672 else {
93564729 1673 const char *name = SvPV_nomg_const_nolen(*mark);
c4aca7d0
GA
1674 APPLY_TAINT_PROPER();
1675 if (PerlLIO_chown(name, val, val2))
1676 tot--;
1677 }
a687059c
LW
1678 }
1679 }
1680 break;
b1248f16 1681#endif
a1d180c4 1682/*
dd64f1c3
AD
1683XXX Should we make lchown() directly available from perl?
1684For now, we'll let Configure test for HAS_LCHOWN, but do
1685nothing in the core.
1686 --AD 5/1998
1687*/
fe14fcc3 1688#ifdef HAS_KILL
79072805 1689 case OP_KILL:
20408e3c 1690 APPLY_TAINT_PROPER();
55497cff
PP
1691 if (mark == sp)
1692 break;
84c7b88c 1693 s = SvPVx_const(*++mark, len);
c2fd40cb
DM
1694 if (*s == '-' && isALPHA(s[1]))
1695 {
1696 s++;
1697 len--;
885b4b39 1698 killgp = TRUE;
c2fd40cb 1699 }
e02bfb16 1700 if (isALPHA(*s)) {
84c7b88c 1701 if (*s == 'S' && s[1] == 'I' && s[2] == 'G') {
79072805 1702 s += 3;
84c7b88c
BF
1703 len -= 3;
1704 }
1705 if ((val = whichsig_pvn(s, len)) < 0)
1706 Perl_croak(aTHX_ "Unrecognized signal name \"%"SVf"\"", SVfARG(*mark));
79072805
LW
1707 }
1708 else
c2fd40cb 1709 {
4ea561bc 1710 val = SvIV(*mark);
c2fd40cb
DM
1711 if (val < 0)
1712 {
885b4b39 1713 killgp = TRUE;
c2fd40cb
DM
1714 val = -val;
1715 }
1716 }
20408e3c
GS
1717 APPLY_TAINT_PROPER();
1718 tot = sp - mark;
3595fcef
PP
1719#ifdef VMS
1720 /* kill() doesn't do process groups (job trees?) under VMS */
3595fcef 1721 if (val == SIGKILL) {
3595fcef
PP
1722 /* Use native sys$delprc() to insure that target process is
1723 * deleted; supervisor-mode images don't pay attention to
1724 * CRTL's emulation of Unix-style signals and kill()
1725 */
1726 while (++mark <= sp) {
5f521955
JH
1727 I32 proc;
1728 register unsigned long int __vmssts;
8af710eb 1729 SvGETMAGIC(*mark);
e2c0f81f
DG
1730 if (!(SvIOK(*mark) || SvNOK(*mark) || looks_like_number(*mark)))
1731 Perl_croak(aTHX_ "Can't kill a non-numeric process ID");
8af710eb 1732 proc = SvIV_nomg(*mark);
20408e3c 1733 APPLY_TAINT_PROPER();
3595fcef
PP
1734 if (!((__vmssts = sys$delprc(&proc,0)) & 1)) {
1735 tot--;
1736 switch (__vmssts) {
1737 case SS$_NONEXPR:
1738 case SS$_NOSUCHNODE:
1739 SETERRNO(ESRCH,__vmssts);
1740 break;
1741 case SS$_NOPRIV:
1742 SETERRNO(EPERM,__vmssts);
1743 break;
1744 default:
1745 SETERRNO(EVMSERR,__vmssts);
1746 }
1747 }
1748 }
8165faea 1749 PERL_ASYNC_CHECK();
3595fcef
PP
1750 break;
1751 }
1752#endif
c2fd40cb 1753 while (++mark <= sp) {
60082291 1754 Pid_t proc;
c2fd40cb 1755 SvGETMAGIC(*mark);
60082291 1756 if (!(SvNIOK(*mark) || looks_like_number(*mark)))
c2fd40cb
DM
1757 Perl_croak(aTHX_ "Can't kill a non-numeric process ID");
1758 proc = SvIV_nomg(*mark);
1759 if (killgp)
1760 {
1761 proc = -proc;
a687059c 1762 }
c2fd40cb
DM
1763 APPLY_TAINT_PROPER();
1764 if (PerlProc_kill(proc, val))
1765 tot--;
a687059c 1766 }
8165faea 1767 PERL_ASYNC_CHECK();
a687059c 1768 break;
b1248f16 1769#endif
79072805 1770 case OP_UNLINK:
20408e3c 1771 APPLY_TAINT_PROPER();
79072805
LW
1772 tot = sp - mark;
1773 while (++mark <= sp) {
e62f0680 1774 s = SvPV_nolen_const(*mark);
20408e3c 1775 APPLY_TAINT_PROPER();
985213f2 1776 if (PerlProc_geteuid() || PL_unsafe) {
b8ffc8df 1777 if (UNLINK(s))
a687059c
LW
1778 tot--;
1779 }
1780 else { /* don't let root wipe out directories without -U */
3280af22 1781 if (PerlLIO_lstat(s,&PL_statbuf) < 0 || S_ISDIR(PL_statbuf.st_mode))
a687059c
LW
1782 tot--;
1783 else {
b8ffc8df 1784 if (UNLINK(s))
a687059c
LW
1785 tot--;
1786 }
1787 }
1788 }
1789 break;
e96b369d 1790#if defined(HAS_UTIME) || defined(HAS_FUTIMES)
79072805 1791 case OP_UTIME:
20408e3c 1792 APPLY_TAINT_PROPER();
79072805 1793 if (sp - mark > 2) {
e96b369d
GA
1794#if defined(HAS_FUTIMES)
1795 struct timeval utbuf[2];
1796 void *utbufp = utbuf;
1797#elif defined(I_UTIME) || defined(VMS)
663a0e37 1798 struct utimbuf utbuf;
07409e01 1799 struct utimbuf *utbufp = &utbuf;
663a0e37 1800#else
a687059c 1801 struct {
dd2821f6
GS
1802 Time_t actime;
1803 Time_t modtime;
a687059c 1804 } utbuf;
07409e01 1805 void *utbufp = &utbuf;
663a0e37 1806#endif
a687059c 1807
0bcc34c2
AL
1808 SV* const accessed = *++mark;
1809 SV* const modified = *++mark;
c6f7b413 1810
6ec06612
SB
1811 /* Be like C, and if both times are undefined, let the C
1812 * library figure out what to do. This usually means
1813 * "current time". */
c6f7b413
RS
1814
1815 if ( accessed == &PL_sv_undef && modified == &PL_sv_undef )
6ec06612
SB
1816 utbufp = NULL;
1817 else {
1818 Zero(&utbuf, sizeof utbuf, char);
e96b369d 1819#ifdef HAS_FUTIMES
4ea561bc 1820 utbuf[0].tv_sec = (long)SvIV(accessed); /* time accessed */
e96b369d 1821 utbuf[0].tv_usec = 0;
4ea561bc 1822 utbuf[1].tv_sec = (long)SvIV(modified); /* time modified */
e96b369d
GA
1823 utbuf[1].tv_usec = 0;
1824#elif defined(BIG_TIME)
4ea561bc
NC
1825 utbuf.actime = (Time_t)SvNV(accessed); /* time accessed */
1826 utbuf.modtime = (Time_t)SvNV(modified); /* time modified */
517844ec 1827#else
4ea561bc
NC
1828 utbuf.actime = (Time_t)SvIV(accessed); /* time accessed */
1829 utbuf.modtime = (Time_t)SvIV(modified); /* time modified */
517844ec 1830#endif
6ec06612 1831 }
4373e329 1832 APPLY_TAINT_PROPER();
79072805
LW
1833 tot = sp - mark;
1834 while (++mark <= sp) {
e96b369d 1835 GV* gv;
64617da9 1836 if ((gv = MAYBE_DEREF_GV(*mark))) {
e96b369d
GA
1837 if (GvIO(gv) && IoIFP(GvIOp(gv))) {
1838#ifdef HAS_FUTIMES
1839 APPLY_TAINT_PROPER();
8b7231d9
SP
1840 if (futimes(PerlIO_fileno(IoIFP(GvIOn(gv))),
1841 (struct timeval *) utbufp))
e96b369d
GA
1842 tot--;
1843#else
1844 Perl_die(aTHX_ PL_no_func, "futimes");
1845#endif
1846 }
1847 else {
1848 tot--;
1849 }
1850 }
e96b369d 1851 else {
64617da9 1852 const char * const name = SvPV_nomg_const_nolen(*mark);
e96b369d
GA
1853 APPLY_TAINT_PROPER();
1854#ifdef HAS_FUTIMES
8b7231d9 1855 if (utimes(name, (struct timeval *)utbufp))
e96b369d
GA
1856#else
1857 if (PerlLIO_utime(name, utbufp))
1858#endif
1859 tot--;
1860 }
1861
a687059c 1862 }
a687059c
LW
1863 }
1864 else
79072805 1865 tot = 0;
a687059c 1866 break;
a0d0e21e 1867#endif
a687059c
LW
1868 }
1869 return tot;
20408e3c 1870
20408e3c 1871#undef APPLY_TAINT_PROPER
a687059c
LW
1872}
1873
1874/* Do the permissions allow some operation? Assumes statcache already set. */
a0d0e21e 1875#ifndef VMS /* VMS' cando is in vms.c */
7f4774ae 1876bool
ae1951c1
NC
1877Perl_cando(pTHX_ Mode_t mode, bool effective, register const Stat_t *statbufp)
1878/* effective is a flag, true for EUID, or for checking if the effective gid
1879 * is in the list of groups returned from getgroups().
1880 */
a687059c 1881{
97aff369 1882 dVAR;
7918f24d
NC
1883
1884 PERL_ARGS_ASSERT_CANDO;
1885
bee1dbe2 1886#ifdef DOSISH
fe14fcc3
LW
1887 /* [Comments and code from Len Reed]
1888 * MS-DOS "user" is similar to UNIX's "superuser," but can't write
1889 * to write-protected files. The execute permission bit is set
486ec47a 1890 * by the Microsoft C library stat() function for the following:
fe14fcc3
LW
1891 * .exe files
1892 * .com files
1893 * .bat files
1894 * directories
1895 * All files and directories are readable.
1896 * Directories and special files, e.g. "CON", cannot be
1897 * write-protected.
1898 * [Comment by Tom Dinger -- a directory can have the write-protect
1899 * bit set in the file system, but DOS permits changes to
1900 * the directory anyway. In addition, all bets are off
1901 * here for networked software, such as Novell and
1902 * Sun's PC-NFS.]
1903 */
1904
bee1dbe2
LW
1905 /* Atari stat() does pretty much the same thing. we set x_bit_set_in_stat
1906 * too so it will actually look into the files for magic numbers
1907 */
7f4774ae 1908 return (mode & statbufp->st_mode) ? TRUE : FALSE;
fe14fcc3 1909
55497cff 1910#else /* ! DOSISH */
b595cd4b
RU
1911# ifdef __CYGWIN__
1912 if (ingroup(544,effective)) { /* member of Administrators */
1913# else
985213f2 1914 if ((effective ? PerlProc_geteuid() : PerlProc_getuid()) == 0) { /* root is special */
b595cd4b 1915# endif
7f4774ae 1916 if (mode == S_IXUSR) {
c623bd54 1917 if (statbufp->st_mode & 0111 || S_ISDIR(statbufp->st_mode))
a687059c
LW
1918 return TRUE;
1919 }
1920 else
1921 return TRUE; /* root reads and writes anything */
1922 return FALSE;
1923 }
985213f2 1924 if (statbufp->st_uid == (effective ? PerlProc_geteuid() : PerlProc_getuid()) ) {
7f4774ae 1925 if (statbufp->st_mode & mode)
a687059c
LW
1926 return TRUE; /* ok as "user" */
1927 }
d8eceb89 1928 else if (ingroup(statbufp->st_gid,effective)) {
7f4774ae 1929 if (statbufp->st_mode & mode >> 3)
a687059c
LW
1930 return TRUE; /* ok as "group" */
1931 }
7f4774ae 1932 else if (statbufp->st_mode & mode >> 6)
a687059c
LW
1933 return TRUE; /* ok as "other" */
1934 return FALSE;
55497cff 1935#endif /* ! DOSISH */
a687059c 1936}
a0d0e21e 1937#endif /* ! VMS */
a687059c 1938
1f676739 1939static bool
0da8eb3a 1940S_ingroup(pTHX_ Gid_t testgid, bool effective)
a687059c 1941{
97aff369 1942 dVAR;
985213f2 1943 if (testgid == (effective ? PerlProc_getegid() : PerlProc_getgid()))
a687059c 1944 return TRUE;
fe14fcc3 1945#ifdef HAS_GETGROUPS
a687059c 1946 {
331b57bc 1947 Groups_t *gary = NULL;
79072805 1948 I32 anum;
331b57bc 1949 bool rc = FALSE;
a687059c 1950
331b57bc
SP
1951 anum = getgroups(0, gary);
1952 Newx(gary, anum, Groups_t);
1953 anum = getgroups(anum, gary);
a687059c 1954 while (--anum >= 0)
331b57bc
SP
1955 if (gary[anum] == testgid) {
1956 rc = TRUE;
1957 break;
1958 }
1959
1960 Safefree(gary);
1961 return rc;
a687059c 1962 }
c685562b 1963#else
a687059c 1964 return FALSE;
cd39f2b6 1965#endif
a687059c 1966}
c2ab57d4 1967
fe14fcc3 1968#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
c2ab57d4 1969
79072805 1970I32
864dbfa3 1971Perl_do_ipcget(pTHX_ I32 optype, SV **mark, SV **sp)
c2ab57d4 1972{
97aff369 1973 dVAR;
0bcc34c2 1974 const key_t key = (key_t)SvNVx(*++mark);
c3312966 1975 SV *nsv = optype == OP_MSGGET ? NULL : *++mark;
6867be6d 1976 const I32 flags = SvIVx(*++mark);
294a48e9 1977
7918f24d 1978 PERL_ARGS_ASSERT_DO_IPCGET;
294a48e9 1979 PERL_UNUSED_ARG(sp);
c2ab57d4 1980
748a9306 1981 SETERRNO(0,0);
c2ab57d4
LW
1982 switch (optype)
1983 {
fe14fcc3 1984#ifdef HAS_MSG
79072805 1985 case OP_MSGGET:
c2ab57d4 1986 return msgget(key, flags);
e5d73d77 1987#endif
fe14fcc3 1988#ifdef HAS_SEM
79072805 1989 case OP_SEMGET:
c3312966 1990 return semget(key, (int) SvIV(nsv), flags);
e5d73d77 1991#endif
fe14fcc3 1992#ifdef HAS_SHM
79072805 1993 case OP_SHMGET:
c3312966 1994 return shmget(key, (size_t) SvUV(nsv), flags);
e5d73d77 1995#endif
fe14fcc3 1996#if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
e5d73d77 1997 default:
fe13d51d 1998 /* diag_listed_as: msg%s not implemented */
cea2e8a9 1999 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
e5d73d77 2000#endif
c2ab57d4
LW
2001 }
2002 return -1; /* should never happen */
2003}
2004
79072805 2005I32
864dbfa3 2006Perl_do_ipcctl(pTHX_ I32 optype, SV **mark, SV **sp)
c2ab57d4 2007{
97aff369 2008 dVAR;
c2ab57d4 2009 char *a;
a0d0e21e 2010 I32 ret = -1;
6867be6d 2011 const I32 id = SvIVx(*++mark);
95b63a38 2012#ifdef Semctl
6867be6d 2013 const I32 n = (optype == OP_SEMCTL) ? SvIVx(*++mark) : 0;
95b63a38 2014#endif
6867be6d 2015 const I32 cmd = SvIVx(*++mark);
0bcc34c2
AL
2016 SV * const astr = *++mark;
2017 STRLEN infosize = 0;
2018 I32 getinfo = (cmd == IPC_STAT);
c2ab57d4 2019
7918f24d 2020 PERL_ARGS_ASSERT_DO_IPCCTL;
0bcc34c2 2021 PERL_UNUSED_ARG(sp);
c2ab57d4
LW
2022
2023 switch (optype)
2024 {
fe14fcc3 2025#ifdef HAS_MSG
79072805 2026 case OP_MSGCTL:
c2ab57d4
LW
2027 if (cmd == IPC_STAT || cmd == IPC_SET)
2028 infosize = sizeof(struct msqid_ds);
2029 break;
e5d73d77 2030#endif
fe14fcc3 2031#ifdef HAS_SHM
79072805 2032 case OP_SHMCTL:
c2ab57d4
LW
2033 if (cmd == IPC_STAT || cmd == IPC_SET)
2034 infosize = sizeof(struct shmid_ds);
2035 break;
e5d73d77 2036#endif
fe14fcc3 2037#ifdef HAS_SEM
79072805 2038 case OP_SEMCTL:
39398f3f 2039#ifdef Semctl
c2ab57d4
LW
2040 if (cmd == IPC_STAT || cmd == IPC_SET)
2041 infosize = sizeof(struct semid_ds);
2042 else if (cmd == GETALL || cmd == SETALL)
2043 {
8e591e46 2044 struct semid_ds semds;
bd89102f 2045 union semun semun;
e6f0bdd6
GS
2046#ifdef EXTRA_F_IN_SEMUN_BUF
2047 semun.buff = &semds;
2048#else
84902520 2049 semun.buf = &semds;
e6f0bdd6 2050#endif
c2ab57d4 2051 getinfo = (cmd == GETALL);
9b89d93d
GB
2052 if (Semctl(id, 0, IPC_STAT, semun) == -1)
2053 return -1;
6e21c824
LW
2054 infosize = semds.sem_nsems * sizeof(short);
2055 /* "short" is technically wrong but much more portable
2056 than guessing about u_?short(_t)? */
c2ab57d4 2057 }
39398f3f 2058#else
fe13d51d 2059 /* diag_listed_as: sem%s not implemented */
cea2e8a9 2060 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
39398f3f 2061#endif
c2ab57d4 2062 break;
e5d73d77 2063#endif
fe14fcc3 2064#if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
e5d73d77 2065 default:
fe13d51d 2066 /* diag_listed_as: shm%s not implemented */
cea2e8a9 2067 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
e5d73d77 2068#endif
c2ab57d4
LW
2069 }
2070
2071 if (infosize)
2072 {
2073 if (getinfo)
2074 {
93524f2b 2075 SvPV_force_nolen(astr);
a0d0e21e 2076 a = SvGROW(astr, infosize+1);
c2ab57d4
LW
2077 }
2078 else
2079 {
93524f2b 2080 STRLEN len;
463ee0b2
LW
2081 a = SvPV(astr, len);
2082 if (len != infosize)
cea2e8a9 2083 Perl_croak(aTHX_ "Bad arg length for %s, is %lu, should be %ld",
4ec43091
JH
2084 PL_op_desc[optype],
2085 (unsigned long)len,
2086 (long)infosize);
c2ab57d4
LW
2087 }
2088 }
2089 else
2090 {
0bcc34c2 2091 const IV i = SvIV(astr);
56431972 2092 a = INT2PTR(char *,i); /* ouch */
c2ab57d4 2093 }
748a9306 2094 SETERRNO(0,0);
c2ab57d4
LW
2095 switch (optype)
2096 {
fe14fcc3 2097#ifdef HAS_MSG
79072805 2098 case OP_MSGCTL:
bee1dbe2 2099 ret = msgctl(id, cmd, (struct msqid_ds *)a);
c2ab57d4 2100 break;
e5d73d77 2101#endif
fe14fcc3 2102#ifdef HAS_SEM
bd89102f 2103 case OP_SEMCTL: {
39398f3f 2104#ifdef Semctl
bd89102f
AD
2105 union semun unsemds;
2106
e6f0bdd6
GS
2107#ifdef EXTRA_F_IN_SEMUN_BUF
2108 unsemds.buff = (struct semid_ds *)a;
2109#else
bd89102f 2110 unsemds.buf = (struct semid_ds *)a;
e6f0bdd6 2111#endif
bd89102f 2112 ret = Semctl(id, n, cmd, unsemds);
39398f3f 2113#else
fe13d51d 2114 /* diag_listed_as: sem%s not implemented */
cea2e8a9 2115 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
39398f3f 2116#endif
bd89102f 2117 }
c2ab57d4 2118 break;
e5d73d77 2119#endif
fe14fcc3 2120#ifdef HAS_SHM
79072805 2121 case OP_SHMCTL:
bee1dbe2 2122 ret = shmctl(id, cmd, (struct shmid_ds *)a);
c2ab57d4 2123 break;
e5d73d77 2124#endif
c2ab57d4
LW
2125 }
2126 if (getinfo && ret >= 0) {
79072805
LW
2127 SvCUR_set(astr, infosize);
2128 *SvEND(astr) = '\0';
a0d0e21e 2129 SvSETMAGIC(astr);
c2ab57d4
LW
2130 }
2131 return ret;
2132}
2133
79072805 2134I32
864dbfa3 2135Perl_do_msgsnd(pTHX_ SV **mark, SV **sp)
c2ab57d4 2136{
97aff369 2137 dVAR;
fe14fcc3 2138#ifdef HAS_MSG
463ee0b2 2139 STRLEN len;
6867be6d 2140 const I32 id = SvIVx(*++mark);
0bcc34c2
AL
2141 SV * const mstr = *++mark;
2142 const I32 flags = SvIVx(*++mark);
2143 const char * const mbuf = SvPV_const(mstr, len);
2144 const I32 msize = len - sizeof(long);
2145
7918f24d 2146 PERL_ARGS_ASSERT_DO_MSGSND;
890ce7af 2147 PERL_UNUSED_ARG(sp);
c2ab57d4 2148
0bcc34c2 2149 if (msize < 0)
cea2e8a9 2150 Perl_croak(aTHX_ "Arg too short for msgsnd");
748a9306 2151 SETERRNO(0,0);
bee1dbe2 2152 return msgsnd(id, (struct msgbuf *)mbuf, msize, flags);
e5d73d77 2153#else
2d51fa4d
RGS
2154 PERL_UNUSED_ARG(sp);
2155 PERL_UNUSED_ARG(mark);
fe13d51d 2156 /* diag_listed_as: msg%s not implemented */
cea2e8a9 2157 Perl_croak(aTHX_ "msgsnd not implemented");
e5d73d77 2158#endif
c2ab57d4
LW
2159}
2160
79072805 2161I32
864dbfa3 2162Perl_do_msgrcv(pTHX_ SV **mark, SV **sp)
c2ab57d4 2163{
fe14fcc3 2164#ifdef HAS_MSG
97aff369 2165 dVAR;
c2ab57d4
LW
2166 char *mbuf;
2167 long mtype;
6867be6d 2168 I32 msize, flags, ret;
6867be6d 2169 const I32 id = SvIVx(*++mark);
0bcc34c2 2170 SV * const mstr = *++mark;
7918f24d
NC
2171
2172 PERL_ARGS_ASSERT_DO_MSGRCV;
890ce7af 2173 PERL_UNUSED_ARG(sp);
79072805 2174
c2e66d9e
GS
2175 /* suppress warning when reading into undef var --jhi */
2176 if (! SvOK(mstr))
76f68e9b 2177 sv_setpvs(mstr, "");
463ee0b2
LW
2178 msize = SvIVx(*++mark);
2179 mtype = (long)SvIVx(*++mark);
2180 flags = SvIVx(*++mark);
93524f2b 2181 SvPV_force_nolen(mstr);
a0d0e21e 2182 mbuf = SvGROW(mstr, sizeof(long)+msize+1);
a1d180c4 2183
748a9306 2184 SETERRNO(0,0);
bee1dbe2 2185 ret = msgrcv(id, (struct msgbuf *)mbuf, msize, mtype, flags);
c2ab57d4 2186 if (ret >= 0) {
79072805
LW
2187 SvCUR_set(mstr, sizeof(long)+ret);
2188 *SvEND(mstr) = '\0';
41d6edb2
JH
2189#ifndef INCOMPLETE_TAINTS
2190 /* who knows who has been playing with this message? */
2191 SvTAINTED_on(mstr);
2192#endif
c2ab57d4
LW
2193 }
2194 return ret;
e5d73d77 2195#else
2d51fa4d
RGS
2196 PERL_UNUSED_ARG(sp);
2197 PERL_UNUSED_ARG(mark);
fe13d51d 2198 /* diag_listed_as: msg%s not implemented */
cea2e8a9 2199 Perl_croak(aTHX_ "msgrcv not implemented");
e5d73d77 2200#endif
c2ab57d4
LW
2201}
2202
79072805 2203I32
864dbfa3 2204Perl_do_semop(pTHX_ SV **mark, SV **sp)
c2ab57d4 2205{
fe14fcc3 2206#ifdef HAS_SEM
97aff369 2207 dVAR;
463ee0b2 2208 STRLEN opsize;
6867be6d 2209 const I32 id = SvIVx(*++mark);
0bcc34c2
AL
2210 SV * const opstr = *++mark;
2211 const char * const opbuf = SvPV_const(opstr, opsize);
7918f24d
NC
2212
2213 PERL_ARGS_ASSERT_DO_SEMOP;
890ce7af 2214 PERL_UNUSED_ARG(sp);
c2ab57d4 2215
248ff010
NC
2216 if (opsize < 3 * SHORTSIZE
2217 || (opsize % (3 * SHORTSIZE))) {
93189314 2218 SETERRNO(EINVAL,LIB_INVARG);
c2ab57d4
LW
2219 return -1;
2220 }
748a9306 2221 SETERRNO(0,0);
248ff010
NC
2222 /* We can't assume that sizeof(struct sembuf) == 3 * sizeof(short). */
2223 {
6867be6d 2224 const int nsops = opsize / (3 * sizeof (short));
248ff010 2225 int i = nsops;
0bcc34c2 2226 short * const ops = (short *) opbuf;
248ff010
NC
2227 short *o = ops;
2228 struct sembuf *temps, *t;
2229 I32 result;
2230
a02a5408 2231 Newx (temps, nsops, struct sembuf);
248ff010
NC
2232 t = temps;
2233 while (i--) {
2234 t->sem_num = *o++;
2235 t->sem_op = *o++;
2236 t->sem_flg = *o++;
2237 t++;
2238 }
2239 result = semop(id, temps, nsops);
2240 t = temps;
2241 o = ops;
2242 i = nsops;
2243 while (i--) {
2244 *o++ = t->sem_num;
2245 *o++ = t->sem_op;
2246 *o++ = t->sem_flg;
2247 t++;
2248 }
2249 Safefree(temps);
2250 return result;
2251 }
e5d73d77 2252#else
fe13d51d 2253 /* diag_listed_as: sem%s not implemented */
cea2e8a9 2254 Perl_croak(aTHX_ "semop not implemented");
e5d73d77 2255#endif
c2ab57d4
LW
2256}
2257
79072805 2258I32
864dbfa3 2259Perl_do_shmio(pTHX_ I32 optype, SV **mark, SV **sp)
c2ab57d4 2260{
fe14fcc3 2261#ifdef HAS_SHM
97aff369 2262 dVAR;
4373e329 2263 char *shm;
c2ab57d4 2264 struct shmid_ds shmds;
6867be6d 2265 const I32 id = SvIVx(*++mark);
0bcc34c2
AL
2266 SV * const mstr = *++mark;
2267 const I32 mpos = SvIVx(*++mark);
2268 const I32 msize = SvIVx(*++mark);
7918f24d
NC
2269
2270 PERL_ARGS_ASSERT_DO_SHMIO;
890ce7af 2271 PERL_UNUSED_ARG(sp);
c2ab57d4 2272
748a9306 2273 SETERRNO(0,0);
c2ab57d4
LW
2274 if (shmctl(id, IPC_STAT, &shmds) == -1)
2275 return -1;
7f39519f
NC
2276 if (mpos < 0 || msize < 0
2277 || (size_t)mpos + msize > (size_t)shmds.shm_segsz) {
93189314 2278 SETERRNO(EFAULT,SS_ACCVIO); /* can't do as caller requested */
c2ab57d4
LW
2279 return -1;
2280 }
d4c19fe8 2281 shm = (char *)shmat(id, NULL, (optype == OP_SHMREAD) ? SHM_RDONLY : 0);
c2ab57d4
LW
2282 if (shm == (char *)-1) /* I hate System V IPC, I really do */
2283 return -1;
79072805 2284 if (optype == OP_SHMREAD) {
c8ae91a8 2285 char *mbuf;
9f538c04 2286 /* suppress warning when reading into undef var (tchrist 3/Mar/00) */
b399897d
CS
2287 SvGETMAGIC(mstr);
2288 SvUPGRADE(mstr, SVt_PV);
9f538c04 2289 if (! SvOK(mstr))
76f68e9b 2290 sv_setpvs(mstr, "");
af8ff727 2291 SvPOK_only(mstr);
bb7a0f54 2292 mbuf = SvGROW(mstr, (STRLEN)msize+1);
a0d0e21e 2293
bee1dbe2 2294 Copy(shm + mpos, mbuf, msize, char);
79072805
LW
2295 SvCUR_set(mstr, msize);
2296 *SvEND(mstr) = '\0';
a0d0e21e 2297 SvSETMAGIC(mstr);
d929ce6f
JH
2298#ifndef INCOMPLETE_TAINTS
2299 /* who knows who has been playing with this shared memory? */
2300 SvTAINTED_on(mstr);
2301#endif
c2ab57d4
LW
2302 }
2303 else {
93524f2b 2304 STRLEN len;
c2ab57d4 2305
93524f2b 2306 const char *mbuf = SvPV_const(mstr, len);
027aa12d 2307 const I32 n = ((I32)len > msize) ? msize : (I32)len;
bee1dbe2 2308 Copy(mbuf, shm + mpos, n, char);
c2ab57d4 2309 if (n < msize)
bee1dbe2 2310 memzero(shm + mpos + n, msize - n);
c2ab57d4
LW
2311 }
2312 return shmdt(shm);
e5d73d77 2313#else
fe13d51d 2314 /* diag_listed_as: shm%s not implemented */
cea2e8a9 2315 Perl_croak(aTHX_ "shm I/O not implemented");
e5d73d77 2316#endif
c2ab57d4
LW
2317}
2318
fe14fcc3 2319#endif /* SYSV IPC */
4e35701f 2320
0d44d22b 2321/*
ccfc67b7
JH
2322=head1 IO Functions
2323
0d44d22b
NC
2324=for apidoc start_glob
2325
2326Function called by C<do_readline> to spawn a glob (or do the glob inside
2327perl on VMS). This code used to be inline, but now perl uses C<File::Glob>
210b36aa 2328this glob starter is only used by miniperl during the build process.
0d44d22b 2329Moving it away shrinks pp_hot.c; shrinking pp_hot.c helps speed perl up.
fab3f3a7 2330
0d44d22b
NC
2331=cut
2332*/
2333
2334PerlIO *
2335Perl_start_glob (pTHX_ SV *tmpglob, IO *io)
2336{
27da23d5 2337 dVAR;
561b68a9 2338 SV * const tmpcmd = newSV(0);
0d44d22b 2339 PerlIO *fp;
7918f24d
NC
2340
2341 PERL_ARGS_ASSERT_START_GLOB;
2342
0d44d22b
NC
2343 ENTER;
2344 SAVEFREESV(tmpcmd);
2345#ifdef VMS /* expand the wildcards right here, rather than opening a pipe, */
2346 /* since spawning off a process is a real performance hit */
dca5a913
JM
2347
2348PerlIO *
2349Perl_vms_start_glob
2350 (pTHX_ SV *tmpglob,
2351 IO *io);
2352
49a7a762 2353 fp = Perl_vms_start_glob(aTHX_ tmpglob, io);
dca5a913 2354
0d44d22b 2355#else /* !VMS */
0d44d22b
NC
2356#ifdef DOSISH
2357#ifdef OS2
2358 sv_setpv(tmpcmd, "for a in ");
2359 sv_catsv(tmpcmd, tmpglob);
2360 sv_catpv(tmpcmd, "; do echo \"$a\\0\\c\"; done |");
2361#else
2362#ifdef DJGPP
2363 sv_setpv(tmpcmd, "/dev/dosglob/"); /* File System Extension */
2364 sv_catsv(tmpcmd, tmpglob);
2365#else
2366 sv_setpv(tmpcmd, "perlglob ");
2367 sv_catsv(tmpcmd, tmpglob);
2368 sv_catpv(tmpcmd, " |");
2369#endif /* !DJGPP */
2370#endif /* !OS2 */
2371#else /* !DOSISH */
2372#if defined(CSH)
2373 sv_setpvn(tmpcmd, PL_cshname, PL_cshlen);
2374 sv_catpv(tmpcmd, " -cf 'set nonomatch; glob ");
2375 sv_catsv(tmpcmd, tmpglob);
2376 sv_catpv(tmpcmd, "' 2>/dev/null |");
2377#else
2378 sv_setpv(tmpcmd, "echo ");
2379 sv_catsv(tmpcmd, tmpglob);
2380#if 'z' - 'a' == 25
2381 sv_catpv(tmpcmd, "|tr -s ' \t\f\r' '\\012\\012\\012\\012'|");
2382#else
2383 sv_catpv(tmpcmd, "|tr -s ' \t\f\r' '\\n\\n\\n\\n'|");
2384#endif
2385#endif /* !CSH */
2386#endif /* !DOSISH */
93b2dae1
FC
2387 {
2388 GV * const envgv = gv_fetchpvs("ENV", 0, SVt_PVHV);
2389 SV ** const home = hv_fetchs(GvHV(envgv), "HOME", 0);
25018358 2390 SV ** const path = hv_fetchs(GvHV(envgv), "PATH", 0);
93b2dae1 2391 if (home && *home) SvGETMAGIC(*home);
25018358 2392 if (path && *path) SvGETMAGIC(*path);
93b2dae1
FC
2393 save_hash(gv_fetchpvs("ENV", 0, SVt_PVHV));
2394 if (home && *home) SvSETMAGIC(*home);
25018358 2395 if (path && *path) SvSETMAGIC(*path);
93b2dae1 2396 }
93524f2b 2397 (void)do_open(PL_last_in_gv, (char*)SvPVX_const(tmpcmd), SvCUR(tmpcmd),
4608196e 2398 FALSE, O_RDONLY, 0, NULL);
0d44d22b
NC
2399 fp = IoIFP(io);
2400#endif /* !VMS */
2401 LEAVE;
2402 return fp;
2403}
66610fdd
RGS
2404
2405/*
2406 * Local variables:
2407 * c-indentation-style: bsd
2408 * c-basic-offset: 4
14d04a33 2409 * indent-tabs-mode: nil
66610fdd
RGS
2410 * End:
2411 *
14d04a33 2412 * ex: set ts=8 sts=4 sw=4 et:
37442d52 2413 */