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