This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Basic tweaks to do_open() type parsing to allow layer/discipline
[perl5.git] / doio.c
CommitLineData
a0d0e21e 1/* doio.c
a687059c 2 *
3818b22b 3 * Copyright (c) 1991-2000, Larry Wall
a687059c 4 *
6e21c824
LW
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
a687059c 7 *
a0d0e21e
LW
8 */
9
10/*
11 * "Far below them they saw the white waters pour into a foaming bowl, and
12 * then swirl darkly about a deep oval basin in the rocks, until they found
13 * their way out again through a narrow gate, and flowed away, fuming and
14 * chattering, into calmer and more level reaches."
a687059c
LW
15 */
16
17#include "EXTERN.h"
864dbfa3 18#define PERL_IN_DOIO_C
a687059c
LW
19#include "perl.h"
20
fe14fcc3 21#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
aec308ec 22#ifndef HAS_SEM
c2ab57d4 23#include <sys/ipc.h>
aec308ec 24#endif
fe14fcc3 25#ifdef HAS_MSG
c2ab57d4 26#include <sys/msg.h>
e5d73d77 27#endif
fe14fcc3 28#ifdef HAS_SHM
c2ab57d4 29#include <sys/shm.h>
a0d0e21e 30# ifndef HAS_SHMAT_PROTOTYPE
20ce7b12 31 extern Shmat_t shmat (int, char *, int);
a0d0e21e 32# endif
c2ab57d4 33#endif
e5d73d77 34#endif
c2ab57d4 35
663a0e37 36#ifdef I_UTIME
3730b96e 37# if defined(_MSC_VER) || defined(__MINGW32__)
3fe9a6f1
PP
38# include <sys/utime.h>
39# else
40# include <utime.h>
41# endif
663a0e37 42#endif
85aff577 43
85aff577
CS
44#ifdef O_EXCL
45# define OPEN_EXCL O_EXCL
46#else
47# define OPEN_EXCL 0
48#endif
a687059c 49
76121258
PP
50#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
51#include <signal.h>
52#endif
53
54/* XXX If this causes problems, set i_unistd=undef in the hint file. */
55#ifdef I_UNISTD
56# include <unistd.h>
57#endif
58
a687059c 59bool
6170680b
IZ
60Perl_do_open(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
61 int rawmode, int rawperm, PerlIO *supplied_fp)
62{
63 return do_open9(gv, name, len, as_raw, rawmode, rawperm,
64 supplied_fp, Nullsv, 0);
65}
66
67bool
68Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
69 int rawmode, int rawperm, PerlIO *supplied_fp, SV *svs,
70 I32 num_svs)
a687059c 71{
a0d0e21e 72 register IO *io = GvIOn(gv);
760ac839
LW
73 PerlIO *saveifp = Nullfp;
74 PerlIO *saveofp = Nullfp;
9f37169a 75 char savetype = IoTYPE_CLOSED;
c07a80fd 76 int writing = 0;
760ac839 77 PerlIO *fp;
c07a80fd
PP
78 int fd;
79 int result;
3500f679 80 bool was_fdopen = FALSE;
16fe6d59 81 bool in_raw = 0, in_crlf = 0, out_raw = 0, out_crlf = 0;
b931b1d9
NIS
82 char *type = NULL;
83 char *deftype = NULL;
84 char mode[4]; /* stdio file mode ("r\0", "rb\0", "r+b\0" etc.) */
a687059c 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
GS
90 if (PL_op && PL_op->op_type == OP_OPEN) {
91 /* set up disciplines */
92 U8 flags = PL_op->op_private;
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));
50952442 102 if (IoTYPE(io) == IoTYPE_STD)
c2ab57d4 103 result = 0;
3280af22 104 else if (fd <= PL_maxsysfd) {
8990e307
LW
105 saveifp = IoIFP(io);
106 saveofp = IoOFP(io);
107 savetype = IoTYPE(io);
6e21c824
LW
108 result = 0;
109 }
50952442 110 else if (IoTYPE(io) == IoTYPE_PIPE)
3028581b 111 result = PerlProc_pclose(IoIFP(io));
8990e307
LW
112 else if (IoIFP(io) != IoOFP(io)) {
113 if (IoOFP(io)) {
760ac839 114 result = PerlIO_close(IoOFP(io));
6170680b 115 PerlIO_close(IoIFP(io)); /* clear stdio, fd already closed */
c2ab57d4
LW
116 }
117 else
760ac839 118 result = PerlIO_close(IoIFP(io));
a687059c 119 }
a687059c 120 else
760ac839 121 result = PerlIO_close(IoIFP(io));
3280af22 122 if (result == EOF && fd > PL_maxsysfd)
bf49b057 123 PerlIO_printf(Perl_error_log,
6170680b
IZ
124 "Warning: unable to close filehandle %s properly.\n",
125 GvENAME(gv));
8990e307 126 IoOFP(io) = IoIFP(io) = Nullfp;
a687059c 127 }
c07a80fd
PP
128
129 if (as_raw) {
b931b1d9
NIS
130 /* sysopen style args, i.e. integer mode and permissions */
131
09458382 132#if defined(USE_64_BIT_RAWIO) && defined(O_LARGEFILE)
5ff3f7a4
GS
133 rawmode |= O_LARGEFILE;
134#endif
135
9d116dd7
JH
136#ifndef O_ACCMODE
137#define O_ACCMODE 3 /* Assume traditional implementation */
138#endif
5ff3f7a4 139
9d116dd7
JH
140 switch (result = rawmode & O_ACCMODE) {
141 case O_RDONLY:
50952442 142 IoTYPE(io) = IoTYPE_RDONLY;
9d116dd7
JH
143 break;
144 case O_WRONLY:
50952442 145 IoTYPE(io) = IoTYPE_WRONLY;
9d116dd7
JH
146 break;
147 case O_RDWR:
148 default:
50952442 149 IoTYPE(io) = IoTYPE_RDWR;
9d116dd7
JH
150 break;
151 }
152
c07a80fd 153 writing = (result > 0);
3028581b 154 fd = PerlLIO_open3(name, rawmode, rawperm);
9d116dd7 155
c07a80fd
PP
156 if (fd == -1)
157 fp = NULL;
158 else {
16fe6d59 159 STRLEN ix = 0;
b931b1d9
NIS
160 if (result == O_RDONLY) {
161 mode[ix++] = 'r';
162 }
360e5741 163#ifdef O_APPEND
16fe6d59 164 else if (rawmode & O_APPEND) {
b931b1d9 165 mode[ix++] = 'a';
16fe6d59 166 if (result != O_WRONLY)
b931b1d9 167 mode[ix++] = '+';
16fe6d59 168 }
360e5741 169#endif
16fe6d59
GS
170 else {
171 if (result == O_WRONLY)
b931b1d9 172 mode[ix++] = 'w';
16fe6d59 173 else {
b931b1d9
NIS
174 mode[ix++] = 'r';
175 mode[ix++] = '+';
16fe6d59
GS
176 }
177 }
178 if (rawmode & O_BINARY)
b931b1d9
NIS
179 mode[ix++] = 'b';
180 mode[ix] = '\0';
181 fp = PerlIO_fdopen(fd, mode);
c07a80fd 182 if (!fp)
3028581b 183 PerlLIO_close(fd);
c07a80fd 184 }
a687059c 185 }
c07a80fd 186 else {
b931b1d9 187 /* Regular (non-sys) open */
faecd977 188 char *oname = name;
faecd977 189 STRLEN olen = len;
b931b1d9
NIS
190 char *tend;
191 int dodup = 0;
c07a80fd 192
faecd977 193 type = savepvn(name, len);
b931b1d9 194 tend = type+len;
faecd977 195 SAVEFREEPV(type);
b931b1d9
NIS
196 /* Loose trailing white space */
197 while (tend > type && isSPACE(tend[-1]))
198 *tend-- = '\0';
6170680b 199 if (num_svs) {
b931b1d9 200 /* New style explict name, type is just mode and discipline/layer info */
faecd977
GS
201 STRLEN l;
202 name = SvPV(svs, l) ;
203 len = (I32)l;
204 name = savepvn(name, len);
205 SAVEFREEPV(name);
b931b1d9
NIS
206 /*SUPPRESS 530*/
207 for (; isSPACE(*type); type++) ;
6170680b 208 }
faecd977 209 else {
faecd977 210 name = type;
b931b1d9 211 len = tend-type;
faecd977 212 }
6170680b 213 IoTYPE(io) = *type;
b931b1d9 214 if (*type == IoTYPE_RDWR && (!num_svs || tend > type+1 && tend[-1] != IoTYPE_PIPE)) { /* scary */
6170680b 215 mode[1] = *type++;
c07a80fd 216 writing = 1;
a687059c 217 }
c07a80fd 218
9f37169a 219 if (*type == IoTYPE_PIPE) {
b931b1d9
NIS
220 if (num_svs) {
221 if (type[1] != IoTYPE_STD) {
222 unknown_desr:
223 Perl_croak(aTHX_ "Unknown open() mode '%.*s'", (int)olen, oname);
224 }
225 type++;
6170680b 226 }
c07a80fd 227 /*SUPPRESS 530*/
b931b1d9 228 for (type++; isSPACE(*type); type++) ;
faecd977 229 if (!num_svs) {
6170680b 230 name = type;
b931b1d9 231 len = tend-type;
faecd977 232 }
06eaf0bc
GS
233 if (*name == '\0') { /* command is missing 19990114 */
234 dTHR;
235 if (ckWARN(WARN_PIPE))
cea2e8a9 236 Perl_warner(aTHX_ WARN_PIPE, "Missing command in piped open");
06eaf0bc
GS
237 errno = EPIPE;
238 goto say_false;
239 }
6170680b 240 if (strNE(name,"-") || num_svs)
c07a80fd
PP
241 TAINT_ENV();
242 TAINT_PROPER("piped open");
b931b1d9 243 if (!num_svs && name[len-1] == '|') {
d008e5eb 244 dTHR;
faecd977 245 name[--len] = '\0' ;
599cee73 246 if (ckWARN(WARN_PIPE))
9a7dcd9c 247 Perl_warner(aTHX_ WARN_PIPE, "Can't open bidirectional pipe");
7b8d334a 248 }
a1d180c4 249 mode[0] = 'w';
c07a80fd 250 writing = 1;
a1d180c4
NIS
251 if (out_raw)
252 strcat(mode, "b");
253 else if (out_crlf)
254 strcat(mode, "t");
255 fp = PerlProc_popen(name,mode);
c07a80fd 256 }
9f37169a 257 else if (*type == IoTYPE_WRONLY) {
c07a80fd 258 TAINT_PROPER("open");
6170680b 259 type++;
9f37169a
JH
260 if (*type == IoTYPE_WRONLY) {
261 /* Two IoTYPE_WRONLYs in a row make for an IoTYPE_APPEND. */
50952442 262 mode[0] = IoTYPE(io) = IoTYPE_APPEND;
6170680b 263 type++;
a0d0e21e 264 }
c07a80fd
PP
265 else
266 mode[0] = 'w';
267 writing = 1;
268
16fe6d59
GS
269 if (out_raw)
270 strcat(mode, "b");
271 else if (out_crlf)
272 strcat(mode, "t");
273
6170680b
IZ
274 if (*type == '&') {
275 name = type;
c07a80fd 276 duplicity:
b931b1d9
NIS
277 if (num_svs)
278 goto unknown_desr;
c07a80fd
PP
279 dodup = 1;
280 name++;
281 if (*name == '=') {
282 dodup = 0;
a0d0e21e 283 name++;
c07a80fd
PP
284 }
285 if (!*name && supplied_fp)
286 fp = supplied_fp;
a0d0e21e 287 else {
c07a80fd
PP
288 /*SUPPRESS 530*/
289 for (; isSPACE(*name); name++) ;
290 if (isDIGIT(*name))
291 fd = atoi(name);
292 else {
293 IO* thatio;
294 gv = gv_fetchpv(name,FALSE,SVt_PVIO);
295 thatio = GvIO(gv);
296 if (!thatio) {
6e21c824 297#ifdef EINVAL
c07a80fd 298 SETERRNO(EINVAL,SS$_IVCHAN);
6e21c824 299#endif
c07a80fd
PP
300 goto say_false;
301 }
302 if (IoIFP(thatio)) {
54195c32 303 PerlIO *fp = IoIFP(thatio);
7211d486
JH
304 /* Flush stdio buffer before dup. --mjd
305 * Unfortunately SEEK_CURing 0 seems to
306 * be optimized away on most platforms;
307 * only Solaris and Linux seem to flush
308 * on that. --jhi */
2c534a3f
NC
309#ifdef USE_SFIO
310 /* sfio fails to clear error on next
311 sfwrite, contrary to documentation.
312 -- Nick Clark */
313 if (PerlIO_seek(fp, 0, SEEK_CUR) == -1)
314 PerlIO_clearerr(fp);
315#endif
7211d486
JH
316 /* On the other hand, do all platforms
317 * take gracefully to flushing a read-only
318 * filehandle? Perhaps we should do
319 * fsetpos(src)+fgetpos(dst)? --nik */
320 PerlIO_flush(fp);
54195c32 321 fd = PerlIO_fileno(fp);
0759c907
JH
322 /* When dup()ing STDIN, STDOUT or STDERR
323 * explicitly set appropriate access mode */
324 if (IoIFP(thatio) == PerlIO_stdout()
325 || IoIFP(thatio) == PerlIO_stderr())
326 IoTYPE(io) = IoTYPE_WRONLY;
327 else if (IoIFP(thatio) == PerlIO_stdin())
328 IoTYPE(io) = IoTYPE_RDONLY;
329 /* When dup()ing a socket, say result is
330 * one as well */
331 else if (IoTYPE(thatio) == IoTYPE_SOCKET)
50952442 332 IoTYPE(io) = IoTYPE_SOCKET;
c07a80fd
PP
333 }
334 else
335 fd = -1;
a0d0e21e 336 }
fec02dd3 337 if (dodup)
3028581b 338 fd = PerlLIO_dup(fd);
3500f679
RS
339 else
340 was_fdopen = TRUE;
760ac839 341 if (!(fp = PerlIO_fdopen(fd,mode))) {
c07a80fd 342 if (dodup)
3028581b 343 PerlLIO_close(fd);
faecd977 344 }
c07a80fd 345 }
bf38876a 346 }
c07a80fd
PP
347 else {
348 /*SUPPRESS 530*/
6170680b 349 for (; isSPACE(*type); type++) ;
b931b1d9
NIS
350 if (*type == IoTYPE_STD && (!type[1] || isSPACE(type[1]) || type[1] == ':')) {
351 /*SUPPRESS 530*/
352 type++;
760ac839 353 fp = PerlIO_stdout();
50952442 354 IoTYPE(io) = IoTYPE_STD;
c07a80fd
PP
355 }
356 else {
6170680b 357 fp = PerlIO_open((num_svs ? name : type), mode);
c07a80fd 358 }
bf38876a
LW
359 }
360 }
9f37169a 361 else if (*type == IoTYPE_RDONLY) {
c07a80fd 362 /*SUPPRESS 530*/
6170680b 363 for (type++; isSPACE(*type); type++) ;
bf38876a 364 mode[0] = 'r';
16fe6d59
GS
365 if (in_raw)
366 strcat(mode, "b");
367 else if (in_crlf)
368 strcat(mode, "t");
369
6170680b
IZ
370 if (*type == '&') {
371 name = type;
bf38876a 372 goto duplicity;
6170680b 373 }
b931b1d9
NIS
374 if (*type == IoTYPE_STD && (!type[1] || isSPACE(type[1]) || type[1] == ':')) {
375 /*SUPPRESS 530*/
376 type++;
760ac839 377 fp = PerlIO_stdin();
50952442 378 IoTYPE(io) = IoTYPE_STD;
a687059c 379 }
bf38876a 380 else
6170680b 381 fp = PerlIO_open((num_svs ? name : type), mode);
a687059c 382 }
b931b1d9
NIS
383 else if ((num_svs && type[0] == IoTYPE_STD && type[1] == IoTYPE_PIPE) ||
384 (!num_svs && tend > type+1 && tend[-1] == IoTYPE_PIPE)) {
6170680b 385 if (num_svs) {
b931b1d9 386 type += 2; /* skip over '-|' */
6170680b
IZ
387 }
388 else {
b931b1d9
NIS
389 *--tend = '\0';
390 while (tend > type && isSPACE(tend[-1]))
391 *--tend = '\0';
6170680b
IZ
392 /*SUPPRESS 530*/
393 for (; isSPACE(*type); type++) ;
394 name = type;
b931b1d9 395 len = tend-type;
6170680b 396 }
06eaf0bc
GS
397 if (*name == '\0') { /* command is missing 19990114 */
398 dTHR;
399 if (ckWARN(WARN_PIPE))
cea2e8a9 400 Perl_warner(aTHX_ WARN_PIPE, "Missing command in piped open");
06eaf0bc
GS
401 errno = EPIPE;
402 goto say_false;
403 }
6170680b 404 if (strNE(name,"-") || num_svs)
79072805
LW
405 TAINT_ENV();
406 TAINT_PROPER("piped open");
a1d180c4
NIS
407 mode[0] = 'r';
408 if (in_raw)
409 strcat(mode, "b");
410 else if (in_crlf)
411 strcat(mode, "t");
412 fp = PerlProc_popen(name,mode);
50952442 413 IoTYPE(io) = IoTYPE_PIPE;
a687059c
LW
414 }
415 else {
6170680b
IZ
416 if (num_svs)
417 goto unknown_desr;
418 name = type;
50952442 419 IoTYPE(io) = IoTYPE_RDONLY;
99b89507
LW
420 /*SUPPRESS 530*/
421 for (; isSPACE(*name); name++) ;
a687059c 422 if (strEQ(name,"-")) {
760ac839 423 fp = PerlIO_stdin();
50952442 424 IoTYPE(io) = IoTYPE_STD;
a687059c 425 }
16fe6d59 426 else {
a1d180c4 427 mode[0] = 'r';
16fe6d59 428 if (in_raw)
a1d180c4 429 strcat(mode, "b");
16fe6d59 430 else if (in_crlf)
a1d180c4 431 strcat(mode, "t");
16fe6d59
GS
432 fp = PerlIO_open(name,mode);
433 }
a687059c
LW
434 }
435 }
bee1dbe2 436 if (!fp) {
d008e5eb 437 dTHR;
50952442 438 if (ckWARN(WARN_NEWLINE) && IoTYPE(io) == IoTYPE_RDONLY && strchr(name, '\n'))
cea2e8a9 439 Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "open");
6e21c824 440 goto say_false;
bee1dbe2 441 }
8990e307 442 if (IoTYPE(io) &&
50952442 443 IoTYPE(io) != IoTYPE_PIPE && IoTYPE(io) != IoTYPE_STD) {
96827780 444 dTHR;
3280af22 445 if (PerlLIO_fstat(PerlIO_fileno(fp),&PL_statbuf) < 0) {
760ac839 446 (void)PerlIO_close(fp);
6e21c824 447 goto say_false;
a687059c 448 }
3280af22 449 if (S_ISSOCK(PL_statbuf.st_mode))
50952442 450 IoTYPE(io) = IoTYPE_SOCKET; /* in case a socket was passed in to us */
99b89507
LW
451#ifdef HAS_SOCKET
452 else if (
c623bd54 453#ifdef S_IFMT
3280af22 454 !(PL_statbuf.st_mode & S_IFMT)
99b89507 455#else
b28d0864 456 !PL_statbuf.st_mode
99b89507 457#endif
0759c907
JH
458 && IoTYPE(io) != IoTYPE_WRONLY /* Dups of STD* filehandles already have */
459 && IoTYPE(io) != IoTYPE_RDONLY /* type so they aren't marked as sockets */
460 ) { /* on OS's that return 0 on fstat()ed pipe */
96827780
MB
461 char tmpbuf[256];
462 Sock_size_t buflen = sizeof tmpbuf;
3028581b 463 if (PerlSock_getsockname(PerlIO_fileno(fp), (struct sockaddr *)tmpbuf,
d574b85e
CS
464 &buflen) >= 0
465 || errno != ENOTSOCK)
50952442 466 IoTYPE(io) = IoTYPE_SOCKET; /* some OS's return 0 on fstat()ed socket */
99b89507
LW
467 /* but some return 0 for streams too, sigh */
468 }
bf38876a 469#endif
a687059c 470 }
6e21c824 471 if (saveifp) { /* must use old fp? */
760ac839 472 fd = PerlIO_fileno(saveifp);
6e21c824 473 if (saveofp) {
760ac839 474 PerlIO_flush(saveofp); /* emulate PerlIO_close() */
6e21c824 475 if (saveofp != saveifp) { /* was a socket? */
760ac839 476 PerlIO_close(saveofp);
99b89507
LW
477 if (fd > 2)
478 Safefree(saveofp);
6e21c824
LW
479 }
480 }
760ac839 481 if (fd != PerlIO_fileno(fp)) {
d8a83dd3 482 Pid_t pid;
79072805 483 SV *sv;
bee1dbe2 484
3028581b 485 PerlLIO_dup2(PerlIO_fileno(fp), fd);
4755096e 486 LOCK_FDPID_MUTEX;
3280af22 487 sv = *av_fetch(PL_fdpid,PerlIO_fileno(fp),TRUE);
a0d0e21e 488 (void)SvUPGRADE(sv, SVt_IV);
463ee0b2
LW
489 pid = SvIVX(sv);
490 SvIVX(sv) = 0;
3280af22 491 sv = *av_fetch(PL_fdpid,fd,TRUE);
4755096e 492 UNLOCK_FDPID_MUTEX;
a0d0e21e 493 (void)SvUPGRADE(sv, SVt_IV);
463ee0b2 494 SvIVX(sv) = pid;
3500f679
RS
495 if (!was_fdopen)
496 PerlIO_close(fp);
bee1dbe2 497
6e21c824
LW
498 }
499 fp = saveifp;
760ac839 500 PerlIO_clearerr(fp);
6e21c824 501 }
a0d0e21e 502#if defined(HAS_FCNTL) && defined(F_SETFD)
a8710ca1
GS
503 {
504 int save_errno = errno;
505 fd = PerlIO_fileno(fp);
506 fcntl(fd,F_SETFD,fd > PL_maxsysfd); /* can change errno */
507 errno = save_errno;
508 }
1462b684 509#endif
8990e307 510 IoIFP(io) = fp;
b931b1d9
NIS
511 if (!num_svs) {
512 /* Need to supply default type info from open.pm */
513 type = NULL;
514 }
515 if (type) {
516 while (isSPACE(*type)) type++;
517 if (*type) {
518 }
519 }
520
684bef36 521 IoFLAGS(io) &= ~IOf_NOLINE;
bf38876a 522 if (writing) {
96827780 523 dTHR;
50952442
JH
524 if (IoTYPE(io) == IoTYPE_SOCKET
525 || (IoTYPE(io) == IoTYPE_WRONLY && S_ISCHR(PL_statbuf.st_mode)) )
16fe6d59 526 {
b931b1d9 527 mode[0] = 'w';
16fe6d59 528 if (!(IoOFP(io) = PerlIO_fdopen(PerlIO_fileno(fp),mode))) {
760ac839 529 PerlIO_close(fp);
8990e307 530 IoIFP(io) = Nullfp;
6e21c824 531 goto say_false;
fe14fcc3 532 }
1462b684
LW
533 }
534 else
8990e307 535 IoOFP(io) = fp;
bf38876a 536 }
a687059c 537 return TRUE;
6e21c824
LW
538
539say_false:
8990e307
LW
540 IoIFP(io) = saveifp;
541 IoOFP(io) = saveofp;
542 IoTYPE(io) = savetype;
6e21c824 543 return FALSE;
a687059c
LW
544}
545
760ac839 546PerlIO *
864dbfa3 547Perl_nextargv(pTHX_ register GV *gv)
a687059c 548{
79072805 549 register SV *sv;
99b89507 550#ifndef FLEXFILENAMES
c623bd54
LW
551 int filedev;
552 int fileino;
99b89507 553#endif
761237fe
JB
554 Uid_t fileuid;
555 Gid_t filegid;
18708f5a 556 IO *io = GvIOp(gv);
fe14fcc3 557
3280af22
NIS
558 if (!PL_argvoutgv)
559 PL_argvoutgv = gv_fetchpv("ARGVOUT",TRUE,SVt_PVIO);
18708f5a
GS
560 if (io && (IoFLAGS(io) & IOf_ARGV) && (IoFLAGS(io) & IOf_START)) {
561 IoFLAGS(io) &= ~IOf_START;
7a1c5554
GS
562 if (PL_inplace) {
563 if (!PL_argvout_stack)
564 PL_argvout_stack = newAV();
18708f5a 565 av_push(PL_argvout_stack, SvREFCNT_inc(PL_defoutgv));
7a1c5554 566 }
18708f5a 567 }
3280af22
NIS
568 if (PL_filemode & (S_ISUID|S_ISGID)) {
569 PerlIO_flush(IoIFP(GvIOn(PL_argvoutgv))); /* chmod must follow last write */
fe14fcc3 570#ifdef HAS_FCHMOD
3280af22 571 (void)fchmod(PL_lastfd,PL_filemode);
fe14fcc3 572#else
b28d0864 573 (void)PerlLIO_chmod(PL_oldname,PL_filemode);
fe14fcc3
LW
574#endif
575 }
3280af22 576 PL_filemode = 0;
79072805 577 while (av_len(GvAV(gv)) >= 0) {
11343788 578 dTHR;
85aff577 579 STRLEN oldlen;
79072805 580 sv = av_shift(GvAV(gv));
8990e307 581 SAVEFREESV(sv);
79072805
LW
582 sv_setsv(GvSV(gv),sv);
583 SvSETMAGIC(GvSV(gv));
3280af22 584 PL_oldname = SvPVx(GvSV(gv), oldlen);
9d116dd7 585 if (do_open(gv,PL_oldname,oldlen,PL_inplace!=0,O_RDONLY,0,Nullfp)) {
3280af22 586 if (PL_inplace) {
79072805 587 TAINT_PROPER("inplace open");
3280af22 588 if (oldlen == 1 && *PL_oldname == '-') {
4633a7c4 589 setdefout(gv_fetchpv("STDOUT",TRUE,SVt_PVIO));
a0d0e21e 590 return IoIFP(GvIOp(gv));
c623bd54 591 }
99b89507 592#ifndef FLEXFILENAMES
b28d0864
NIS
593 filedev = PL_statbuf.st_dev;
594 fileino = PL_statbuf.st_ino;
99b89507 595#endif
3280af22
NIS
596 PL_filemode = PL_statbuf.st_mode;
597 fileuid = PL_statbuf.st_uid;
598 filegid = PL_statbuf.st_gid;
599 if (!S_ISREG(PL_filemode)) {
0453d815
PM
600 if (ckWARN_d(WARN_INPLACE))
601 Perl_warner(aTHX_ WARN_INPLACE,
602 "Can't do inplace edit: %s is not a regular file",
603 PL_oldname );
79072805 604 do_close(gv,FALSE);
c623bd54
LW
605 continue;
606 }
3280af22
NIS
607 if (*PL_inplace) {
608 char *star = strchr(PL_inplace, '*');
2d259d92 609 if (star) {
3280af22 610 char *begin = PL_inplace;
2d259d92
CK
611 sv_setpvn(sv, "", 0);
612 do {
613 sv_catpvn(sv, begin, star - begin);
3280af22 614 sv_catpvn(sv, PL_oldname, oldlen);
2d259d92
CK
615 begin = ++star;
616 } while ((star = strchr(begin, '*')));
3d66d7bb
GS
617 if (*begin)
618 sv_catpv(sv,begin);
2d259d92
CK
619 }
620 else {
3280af22 621 sv_catpv(sv,PL_inplace);
2d259d92 622 }
c623bd54 623#ifndef FLEXFILENAMES
b28d0864
NIS
624 if (PerlLIO_stat(SvPVX(sv),&PL_statbuf) >= 0
625 && PL_statbuf.st_dev == filedev
626 && PL_statbuf.st_ino == fileino
39e571d4
ML
627#ifdef DJGPP
628 || (_djstat_fail_bits & _STFAIL_TRUENAME)!=0
629#endif
f248d071
GS
630 )
631 {
632 if (ckWARN_d(WARN_INPLACE))
633 Perl_warner(aTHX_ WARN_INPLACE,
634 "Can't do inplace edit: %s would not be unique",
635 SvPVX(sv));
79072805 636 do_close(gv,FALSE);
c623bd54
LW
637 continue;
638 }
639#endif
fe14fcc3 640#ifdef HAS_RENAME
d308986b 641#if !defined(DOSISH) && !defined(__CYGWIN__)
3280af22 642 if (PerlLIO_rename(PL_oldname,SvPVX(sv)) < 0) {
0453d815 643 if (ckWARN_d(WARN_INPLACE))
a1d180c4 644 Perl_warner(aTHX_ WARN_INPLACE,
0453d815
PM
645 "Can't rename %s to %s: %s, skipping file",
646 PL_oldname, SvPVX(sv), Strerror(errno) );
79072805 647 do_close(gv,FALSE);
c623bd54
LW
648 continue;
649 }
a687059c 650#else
79072805 651 do_close(gv,FALSE);
3028581b 652 (void)PerlLIO_unlink(SvPVX(sv));
b28d0864 653 (void)PerlLIO_rename(PL_oldname,SvPVX(sv));
9d116dd7 654 do_open(gv,SvPVX(sv),SvCUR(sv),PL_inplace!=0,O_RDONLY,0,Nullfp);
55497cff 655#endif /* DOSISH */
ff8e2863 656#else
463ee0b2 657 (void)UNLINK(SvPVX(sv));
b28d0864 658 if (link(PL_oldname,SvPVX(sv)) < 0) {
0453d815
PM
659 if (ckWARN_d(WARN_INPLACE))
660 Perl_warner(aTHX_ WARN_INPLACE,
661 "Can't rename %s to %s: %s, skipping file",
662 PL_oldname, SvPVX(sv), Strerror(errno) );
79072805 663 do_close(gv,FALSE);
c623bd54
LW
664 continue;
665 }
b28d0864 666 (void)UNLINK(PL_oldname);
a687059c
LW
667#endif
668 }
669 else {
a8c18271 670#if !defined(DOSISH) && !defined(AMIGAOS)
edc7bc49 671# ifndef VMS /* Don't delete; use automatic file versioning */
3280af22 672 if (UNLINK(PL_oldname) < 0) {
0453d815
PM
673 if (ckWARN_d(WARN_INPLACE))
674 Perl_warner(aTHX_ WARN_INPLACE,
675 "Can't remove %s: %s, skipping file",
676 PL_oldname, Strerror(errno) );
79072805 677 do_close(gv,FALSE);
fe14fcc3
LW
678 continue;
679 }
edc7bc49 680# endif
ff8e2863 681#else
cea2e8a9 682 Perl_croak(aTHX_ "Can't do inplace edit without backup");
ff8e2863 683#endif
a687059c
LW
684 }
685
3280af22
NIS
686 sv_setpvn(sv,">",!PL_inplace);
687 sv_catpvn(sv,PL_oldname,oldlen);
748a9306 688 SETERRNO(0,0); /* in case sprintf set errno */
4119ab01
HM
689#ifdef VMS
690 if (!do_open(PL_argvoutgv,SvPVX(sv),SvCUR(sv),PL_inplace!=0,
18708f5a 691 O_WRONLY|O_CREAT|O_TRUNC,0,Nullfp))
4119ab01 692#else
3280af22 693 if (!do_open(PL_argvoutgv,SvPVX(sv),SvCUR(sv),PL_inplace!=0,
18708f5a 694 O_WRONLY|O_CREAT|OPEN_EXCL,0666,Nullfp))
4119ab01 695#endif
18708f5a 696 {
0453d815
PM
697 if (ckWARN_d(WARN_INPLACE))
698 Perl_warner(aTHX_ WARN_INPLACE, "Can't do inplace edit on %s: %s",
699 PL_oldname, Strerror(errno) );
79072805 700 do_close(gv,FALSE);
fe14fcc3
LW
701 continue;
702 }
3280af22
NIS
703 setdefout(PL_argvoutgv);
704 PL_lastfd = PerlIO_fileno(IoIFP(GvIOp(PL_argvoutgv)));
705 (void)PerlLIO_fstat(PL_lastfd,&PL_statbuf);
fe14fcc3 706#ifdef HAS_FCHMOD
3280af22 707 (void)fchmod(PL_lastfd,PL_filemode);
a687059c 708#else
3e3baf6d
TB
709# if !(defined(WIN32) && defined(__BORLANDC__))
710 /* Borland runtime creates a readonly file! */
b28d0864 711 (void)PerlLIO_chmod(PL_oldname,PL_filemode);
3e3baf6d 712# endif
a687059c 713#endif
3280af22 714 if (fileuid != PL_statbuf.st_uid || filegid != PL_statbuf.st_gid) {
fe14fcc3 715#ifdef HAS_FCHOWN
3280af22 716 (void)fchown(PL_lastfd,fileuid,filegid);
a687059c 717#else
fe14fcc3 718#ifdef HAS_CHOWN
b28d0864 719 (void)PerlLIO_chown(PL_oldname,fileuid,filegid);
a687059c 720#endif
b1248f16 721#endif
fe14fcc3 722 }
a687059c 723 }
a0d0e21e 724 return IoIFP(GvIOp(gv));
a687059c 725 }
4d61ec05
GS
726 else {
727 dTHR;
728 if (ckWARN_d(WARN_INPLACE)) {
6af84f9f
GS
729 int eno = errno;
730 if (PerlLIO_stat(PL_oldname, &PL_statbuf) >= 0
731 && !S_ISREG(PL_statbuf.st_mode))
732 {
4d61ec05
GS
733 Perl_warner(aTHX_ WARN_INPLACE,
734 "Can't do inplace edit: %s is not a regular file",
9a7dcd9c 735 PL_oldname);
6af84f9f 736 }
4d61ec05 737 else
9a7dcd9c 738 Perl_warner(aTHX_ WARN_INPLACE, "Can't open %s: %s",
6af84f9f 739 PL_oldname, Strerror(eno));
4d61ec05
GS
740 }
741 }
a687059c 742 }
18708f5a
GS
743 if (io && (IoFLAGS(io) & IOf_ARGV))
744 IoFLAGS(io) |= IOf_START;
3280af22
NIS
745 if (PL_inplace) {
746 (void)do_close(PL_argvoutgv,FALSE);
7a1c5554
GS
747 if (io && (IoFLAGS(io) & IOf_ARGV)
748 && PL_argvout_stack && AvFILLp(PL_argvout_stack) >= 0)
749 {
18708f5a
GS
750 GV *oldout = (GV*)av_pop(PL_argvout_stack);
751 setdefout(oldout);
752 SvREFCNT_dec(oldout);
753 return Nullfp;
754 }
4633a7c4 755 setdefout(gv_fetchpv("STDOUT",TRUE,SVt_PVIO));
a687059c
LW
756 }
757 return Nullfp;
758}
759
fe14fcc3 760#ifdef HAS_PIPE
afd9f252 761void
864dbfa3 762Perl_do_pipe(pTHX_ SV *sv, GV *rgv, GV *wgv)
afd9f252 763{
79072805
LW
764 register IO *rstio;
765 register IO *wstio;
afd9f252
LW
766 int fd[2];
767
79072805 768 if (!rgv)
afd9f252 769 goto badexit;
79072805 770 if (!wgv)
afd9f252
LW
771 goto badexit;
772
a0d0e21e
LW
773 rstio = GvIOn(rgv);
774 wstio = GvIOn(wgv);
afd9f252 775
a0d0e21e 776 if (IoIFP(rstio))
79072805 777 do_close(rgv,FALSE);
a0d0e21e 778 if (IoIFP(wstio))
79072805 779 do_close(wgv,FALSE);
afd9f252 780
3028581b 781 if (PerlProc_pipe(fd) < 0)
afd9f252 782 goto badexit;
760ac839
LW
783 IoIFP(rstio) = PerlIO_fdopen(fd[0], "r");
784 IoOFP(wstio) = PerlIO_fdopen(fd[1], "w");
8990e307 785 IoIFP(wstio) = IoOFP(wstio);
50952442
JH
786 IoTYPE(rstio) = IoTYPE_RDONLY;
787 IoTYPE(wstio) = IoTYPE_WRONLY;
8990e307 788 if (!IoIFP(rstio) || !IoOFP(wstio)) {
760ac839 789 if (IoIFP(rstio)) PerlIO_close(IoIFP(rstio));
3028581b 790 else PerlLIO_close(fd[0]);
760ac839 791 if (IoOFP(wstio)) PerlIO_close(IoOFP(wstio));
3028581b 792 else PerlLIO_close(fd[1]);
fe14fcc3
LW
793 goto badexit;
794 }
afd9f252 795
3280af22 796 sv_setsv(sv,&PL_sv_yes);
afd9f252
LW
797 return;
798
799badexit:
3280af22 800 sv_setsv(sv,&PL_sv_undef);
afd9f252
LW
801 return;
802}
b1248f16 803#endif
afd9f252 804
517844ec 805/* explicit renamed to avoid C++ conflict -- kja */
a687059c 806bool
864dbfa3 807Perl_do_close(pTHX_ GV *gv, bool not_implicit)
a687059c 808{
1193dd27
IZ
809 bool retval;
810 IO *io;
a687059c 811
79072805 812 if (!gv)
3280af22 813 gv = PL_argvgv;
a0d0e21e 814 if (!gv || SvTYPE(gv) != SVt_PVGV) {
1d2dff63
GS
815 if (not_implicit)
816 SETERRNO(EBADF,SS$_IVCHAN);
c2ab57d4 817 return FALSE;
99b89507 818 }
79072805
LW
819 io = GvIO(gv);
820 if (!io) { /* never opened */
1d2dff63 821 if (not_implicit) {
d008e5eb 822 dTHR;
2dd78f96
JH
823 if (ckWARN(WARN_UNOPENED)) /* no check for closed here */
824 report_evil_fh(gv, io, PL_op->op_type);
1d2dff63
GS
825 SETERRNO(EBADF,SS$_IVCHAN);
826 }
a687059c
LW
827 return FALSE;
828 }
f2b5be74 829 retval = io_close(io, not_implicit);
517844ec 830 if (not_implicit) {
1193dd27
IZ
831 IoLINES(io) = 0;
832 IoPAGE(io) = 0;
833 IoLINES_LEFT(io) = IoPAGE_LEN(io);
834 }
50952442 835 IoTYPE(io) = IoTYPE_CLOSED;
1193dd27
IZ
836 return retval;
837}
838
839bool
f2b5be74 840Perl_io_close(pTHX_ IO *io, bool not_implicit)
1193dd27
IZ
841{
842 bool retval = FALSE;
843 int status;
844
8990e307 845 if (IoIFP(io)) {
50952442 846 if (IoTYPE(io) == IoTYPE_PIPE) {
3028581b 847 status = PerlProc_pclose(IoIFP(io));
f2b5be74
GS
848 if (not_implicit) {
849 STATUS_NATIVE_SET(status);
850 retval = (STATUS_POSIX == 0);
851 }
852 else {
853 retval = (status != -1);
854 }
a687059c 855 }
50952442 856 else if (IoTYPE(io) == IoTYPE_STD)
a687059c
LW
857 retval = TRUE;
858 else {
8990e307 859 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) { /* a socket */
760ac839
LW
860 retval = (PerlIO_close(IoOFP(io)) != EOF);
861 PerlIO_close(IoIFP(io)); /* clear stdio, fd already closed */
c2ab57d4
LW
862 }
863 else
760ac839 864 retval = (PerlIO_close(IoIFP(io)) != EOF);
a687059c 865 }
8990e307 866 IoOFP(io) = IoIFP(io) = Nullfp;
79072805 867 }
f2b5be74 868 else if (not_implicit) {
20408e3c
GS
869 SETERRNO(EBADF,SS$_IVCHAN);
870 }
1193dd27 871
a687059c
LW
872 return retval;
873}
874
875bool
864dbfa3 876Perl_do_eof(pTHX_ GV *gv)
a687059c 877{
11343788 878 dTHR;
79072805 879 register IO *io;
a687059c
LW
880 int ch;
881
79072805 882 io = GvIO(gv);
a687059c 883
79072805 884 if (!io)
a687059c 885 return TRUE;
af8c498a 886 else if (ckWARN(WARN_IO)
50952442 887 && (IoTYPE(io) == IoTYPE_WRONLY || IoIFP(io) == PerlIO_stdout()
af8c498a
GS
888 || IoIFP(io) == PerlIO_stderr()))
889 {
2dd78f96 890 /* integrate to report_evil_fh()? */
a1d180c4 891 char *name = NULL;
2dd78f96
JH
892 if (isGV(gv)) {
893 SV* sv = sv_newmortal();
894 gv_efullname4(sv, gv, Nullch, FALSE);
895 name = SvPV_nolen(sv);
896 }
897 if (name && *name)
898 Perl_warner(aTHX_ WARN_IO,
899 "Filehandle %s opened only for output", name);
900 else
901 Perl_warner(aTHX_ WARN_IO,
902 "Filehandle opened only for output");
af8c498a 903 }
a687059c 904
8990e307 905 while (IoIFP(io)) {
a687059c 906
760ac839 907 if (PerlIO_has_cntptr(IoIFP(io))) { /* (the code works without this) */
a20bf0c3 908 if (PerlIO_get_cnt(IoIFP(io)) > 0) /* cheat a little, since */
760ac839
LW
909 return FALSE; /* this is the most usual case */
910 }
a687059c 911
760ac839 912 ch = PerlIO_getc(IoIFP(io));
a687059c 913 if (ch != EOF) {
760ac839 914 (void)PerlIO_ungetc(IoIFP(io),ch);
a687059c
LW
915 return FALSE;
916 }
760ac839 917 if (PerlIO_has_cntptr(IoIFP(io)) && PerlIO_canset_cnt(IoIFP(io))) {
a20bf0c3
JH
918 if (PerlIO_get_cnt(IoIFP(io)) < -1)
919 PerlIO_set_cnt(IoIFP(io),-1);
760ac839 920 }
533c011a 921 if (PL_op->op_flags & OPf_SPECIAL) { /* not necessarily a real EOF yet? */
3280af22 922 if (!nextargv(PL_argvgv)) /* get another fp handy */
a687059c
LW
923 return TRUE;
924 }
925 else
926 return TRUE; /* normal fp, definitely end of file */
927 }
928 return TRUE;
929}
930
5ff3f7a4 931Off_t
864dbfa3 932Perl_do_tell(pTHX_ GV *gv)
a687059c 933{
79072805 934 register IO *io;
96e4d5b1 935 register PerlIO *fp;
a687059c 936
96e4d5b1 937 if (gv && (io = GvIO(gv)) && (fp = IoIFP(io))) {
bee1dbe2 938#ifdef ULTRIX_STDIO_BOTCH
96e4d5b1
PP
939 if (PerlIO_eof(fp))
940 (void)PerlIO_seek(fp, 0L, 2); /* ultrix 1.2 workaround */
bee1dbe2 941#endif
8903cb82 942 return PerlIO_tell(fp);
96e4d5b1 943 }
d008e5eb
GS
944 {
945 dTHR;
2dd78f96
JH
946 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
947 report_evil_fh(gv, io, PL_op->op_type);
d008e5eb 948 }
748a9306 949 SETERRNO(EBADF,RMS$_IFI);
5ff3f7a4 950 return (Off_t)-1;
a687059c
LW
951}
952
953bool
864dbfa3 954Perl_do_seek(pTHX_ GV *gv, Off_t pos, int whence)
a687059c 955{
79072805 956 register IO *io;
137443ea 957 register PerlIO *fp;
a687059c 958
137443ea 959 if (gv && (io = GvIO(gv)) && (fp = IoIFP(io))) {
bee1dbe2 960#ifdef ULTRIX_STDIO_BOTCH
137443ea
PP
961 if (PerlIO_eof(fp))
962 (void)PerlIO_seek(fp, 0L, 2); /* ultrix 1.2 workaround */
bee1dbe2 963#endif
8903cb82 964 return PerlIO_seek(fp, pos, whence) >= 0;
137443ea 965 }
d008e5eb
GS
966 {
967 dTHR;
2dd78f96
JH
968 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
969 report_evil_fh(gv, io, PL_op->op_type);
d008e5eb 970 }
748a9306 971 SETERRNO(EBADF,RMS$_IFI);
a687059c
LW
972 return FALSE;
973}
974
97cc44eb 975Off_t
864dbfa3 976Perl_do_sysseek(pTHX_ GV *gv, Off_t pos, int whence)
8903cb82
PP
977{
978 register IO *io;
979 register PerlIO *fp;
980
981 if (gv && (io = GvIO(gv)) && (fp = IoIFP(io)))
3028581b 982 return PerlLIO_lseek(PerlIO_fileno(fp), pos, whence);
d008e5eb
GS
983 {
984 dTHR;
2dd78f96
JH
985 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
986 report_evil_fh(gv, io, PL_op->op_type);
d008e5eb 987 }
8903cb82 988 SETERRNO(EBADF,RMS$_IFI);
d9b3e12d 989 return (Off_t)-1;
8903cb82
PP
990}
991
6ff81951 992int
16fe6d59
GS
993Perl_mode_from_discipline(pTHX_ SV *discp)
994{
995 int mode = O_BINARY;
996 if (discp) {
997 STRLEN len;
998 char *s = SvPV(discp,len);
999 while (*s) {
1000 if (*s == ':') {
1001 switch (s[1]) {
1002 case 'r':
1003 if (len > 3 && strnEQ(s+1, "raw", 3)
1004 && (!s[4] || s[4] == ':' || isSPACE(s[4])))
1005 {
1006 mode = O_BINARY;
1007 s += 4;
1008 len -= 4;
1009 break;
1010 }
1011 /* FALL THROUGH */
1012 case 'c':
1013 if (len > 4 && strnEQ(s+1, "crlf", 4)
1014 && (!s[5] || s[5] == ':' || isSPACE(s[5])))
1015 {
1016 mode = O_TEXT;
1017 s += 5;
1018 len -= 5;
1019 break;
1020 }
1021 /* FALL THROUGH */
1022 default:
1023 goto fail_discipline;
1024 }
1025 }
1026 else if (isSPACE(*s)) {
1027 ++s;
1028 --len;
1029 }
1030 else {
1031 char *end;
1032fail_discipline:
1033 end = strchr(s+1, ':');
1034 if (!end)
1035 end = s+len;
1036 Perl_croak(aTHX_ "Unknown discipline '%.*s'", end-s, s);
1037 }
1038 }
1039 }
1040 return mode;
1041}
1042
1043int
1044Perl_do_binmode(pTHX_ PerlIO *fp, int iotype, int mode)
6ff81951 1045{
6ff81951 1046#ifdef DOSISH
16fe6d59
GS
1047# if defined(atarist) || defined(__MINT__)
1048 if (!PerlIO_flush(fp)) {
1049 if (mode & O_BINARY)
1050 ((FILE*)fp)->_flag |= _IOBIN;
1051 else
1052 ((FILE*)fp)->_flag &= ~ _IOBIN;
6ff81951 1053 return 1;
16fe6d59
GS
1054 }
1055 return 0;
1056# else
1057 if (PerlLIO_setmode(PerlIO_fileno(fp), mode) != -1) {
1058# if defined(WIN32) && defined(__BORLANDC__)
6ff81951
GS
1059 /* The translation mode of the stream is maintained independent
1060 * of the translation mode of the fd in the Borland RTL (heavy
1061 * digging through their runtime sources reveal). User has to
1062 * set the mode explicitly for the stream (though they don't
1063 * document this anywhere). GSAR 97-5-24
1064 */
1065 PerlIO_seek(fp,0L,0);
16fe6d59
GS
1066 if (mode & O_BINARY)
1067 ((FILE*)fp)->flags |= _F_BIN;
1068 else
1069 ((FILE*)fp)->flags &= ~ _F_BIN;
1070# endif
6ff81951
GS
1071 return 1;
1072 }
1073 else
1074 return 0;
16fe6d59 1075# endif
6ff81951 1076#else
16fe6d59
GS
1077# if defined(USEMYBINMODE)
1078 if (my_binmode(fp, iotype, mode) != FALSE)
6ff81951
GS
1079 return 1;
1080 else
1081 return 0;
16fe6d59 1082# else
6ff81951 1083 return 1;
16fe6d59 1084# endif
6ff81951
GS
1085#endif
1086}
1087
a0d0e21e 1088#if !defined(HAS_TRUNCATE) && !defined(HAS_CHSIZE) && defined(F_FREESP)
c2ab57d4 1089 /* code courtesy of William Kucharski */
fe14fcc3 1090#define HAS_CHSIZE
6eb13c3b 1091
517844ec 1092I32 my_chsize(fd, length)
79072805 1093I32 fd; /* file descriptor */
85e6fe83 1094Off_t length; /* length to set file to */
6eb13c3b 1095{
6eb13c3b
LW
1096 struct flock fl;
1097 struct stat filebuf;
1098
3028581b 1099 if (PerlLIO_fstat(fd, &filebuf) < 0)
6eb13c3b
LW
1100 return -1;
1101
1102 if (filebuf.st_size < length) {
1103
1104 /* extend file length */
1105
3028581b 1106 if ((PerlLIO_lseek(fd, (length - 1), 0)) < 0)
6eb13c3b
LW
1107 return -1;
1108
1109 /* write a "0" byte */
1110
3028581b 1111 if ((PerlLIO_write(fd, "", 1)) != 1)
6eb13c3b
LW
1112 return -1;
1113 }
1114 else {
1115 /* truncate length */
1116
1117 fl.l_whence = 0;
1118 fl.l_len = 0;
1119 fl.l_start = length;
a0d0e21e 1120 fl.l_type = F_WRLCK; /* write lock on file space */
6eb13c3b
LW
1121
1122 /*
a0d0e21e 1123 * This relies on the UNDOCUMENTED F_FREESP argument to
6eb13c3b
LW
1124 * fcntl(2), which truncates the file so that it ends at the
1125 * position indicated by fl.l_start.
1126 *
1127 * Will minor miracles never cease?
1128 */
1129
a0d0e21e 1130 if (fcntl(fd, F_FREESP, &fl) < 0)
6eb13c3b
LW
1131 return -1;
1132
1133 }
1134
1135 return 0;
1136}
a0d0e21e 1137#endif /* F_FREESP */
ff8e2863 1138
a687059c 1139bool
864dbfa3 1140Perl_do_print(pTHX_ register SV *sv, PerlIO *fp)
a687059c
LW
1141{
1142 register char *tmps;
463ee0b2 1143 STRLEN len;
a687059c 1144
79072805
LW
1145 /* assuming fp is checked earlier */
1146 if (!sv)
1147 return TRUE;
3280af22 1148 if (PL_ofmt) {
8990e307 1149 if (SvGMAGICAL(sv))
79072805 1150 mg_get(sv);
463ee0b2 1151 if (SvIOK(sv) && SvIVX(sv) != 0) {
65202027 1152 PerlIO_printf(fp, PL_ofmt, (NV)SvIVX(sv));
760ac839 1153 return !PerlIO_error(fp);
79072805 1154 }
463ee0b2 1155 if ( (SvNOK(sv) && SvNVX(sv) != 0.0)
79072805 1156 || (looks_like_number(sv) && sv_2nv(sv) != 0.0) ) {
3280af22 1157 PerlIO_printf(fp, PL_ofmt, SvNVX(sv));
760ac839 1158 return !PerlIO_error(fp);
79072805 1159 }
a687059c 1160 }
79072805
LW
1161 switch (SvTYPE(sv)) {
1162 case SVt_NULL:
d008e5eb
GS
1163 {
1164 dTHR;
1165 if (ckWARN(WARN_UNINITIALIZED))
b89fed5f 1166 report_uninit();
d008e5eb 1167 }
ff8e2863 1168 return TRUE;
79072805 1169 case SVt_IV:
a0d0e21e
LW
1170 if (SvIOK(sv)) {
1171 if (SvGMAGICAL(sv))
1172 mg_get(sv);
cf2093f6 1173 if (SvIsUV(sv))
57def98f 1174 PerlIO_printf(fp, "%"UVuf, (UV)SvUVX(sv));
cf2093f6 1175 else
57def98f 1176 PerlIO_printf(fp, "%"IVdf, (IV)SvIVX(sv));
760ac839 1177 return !PerlIO_error(fp);
a0d0e21e
LW
1178 }
1179 /* FALL THROUGH */
79072805 1180 default:
fba9e08b 1181#if 0
4b3603a4
JH
1182 /* XXX Fix this when the I/O disciplines arrive. XXX */
1183 if (DO_UTF8(sv))
1184 sv_utf8_downgrade(sv, FALSE);
fba9e08b 1185#endif
463ee0b2 1186 tmps = SvPV(sv, len);
79072805 1187 break;
ff8e2863 1188 }
94e4c244
JH
1189 /* To detect whether the process is about to overstep its
1190 * filesize limit we would need getrlimit(). We could then
1191 * also transparently raise the limit with setrlimit() --
1192 * but only until the system hard limit/the filesystem limit,
c5dd3cdd
JH
1193 * at which we would get EPERM. Note that when using buffered
1194 * io the write failure can be delayed until the flush/close. --jhi */
a21ac455 1195 if (len && (PerlIO_write(fp,tmps,len) == 0))
a687059c 1196 return FALSE;
760ac839 1197 return !PerlIO_error(fp);
a687059c
LW
1198}
1199
79072805 1200I32
cea2e8a9 1201Perl_my_stat(pTHX)
a687059c 1202{
4e35701f 1203 djSP;
79072805 1204 IO *io;
2dd78f96 1205 GV* gv;
79072805 1206
533c011a 1207 if (PL_op->op_flags & OPf_REF) {
924508f0 1208 EXTEND(SP,1);
2dd78f96 1209 gv = cGVOP_gv;
748a9306 1210 do_fstat:
2dd78f96 1211 io = GvIO(gv);
8990e307 1212 if (io && IoIFP(io)) {
2dd78f96 1213 PL_statgv = gv;
3280af22
NIS
1214 sv_setpv(PL_statname,"");
1215 PL_laststype = OP_STAT;
1216 return (PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache));
a687059c
LW
1217 }
1218 else {
2dd78f96 1219 if (gv == PL_defgv)
3280af22 1220 return PL_laststatval;
2dd78f96
JH
1221 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1222 report_evil_fh(gv, io, PL_op->op_type);
3280af22
NIS
1223 PL_statgv = Nullgv;
1224 sv_setpv(PL_statname,"");
1225 return (PL_laststatval = -1);
a687059c
LW
1226 }
1227 }
1228 else {
748a9306 1229 SV* sv = POPs;
4b74e3fb 1230 char *s;
2d8e6c8d 1231 STRLEN n_a;
79072805 1232 PUTBACK;
748a9306 1233 if (SvTYPE(sv) == SVt_PVGV) {
2dd78f96 1234 gv = (GV*)sv;
748a9306
LW
1235 goto do_fstat;
1236 }
1237 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2dd78f96 1238 gv = (GV*)SvRV(sv);
748a9306
LW
1239 goto do_fstat;
1240 }
1241
2d8e6c8d 1242 s = SvPV(sv, n_a);
3280af22
NIS
1243 PL_statgv = Nullgv;
1244 sv_setpv(PL_statname, s);
1245 PL_laststype = OP_STAT;
1246 PL_laststatval = PerlLIO_stat(s, &PL_statcache);
599cee73 1247 if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && strchr(s, '\n'))
cea2e8a9 1248 Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "stat");
3280af22 1249 return PL_laststatval;
a687059c
LW
1250 }
1251}
1252
79072805 1253I32
cea2e8a9 1254Perl_my_lstat(pTHX)
c623bd54 1255{
4e35701f 1256 djSP;
79072805 1257 SV *sv;
2d8e6c8d 1258 STRLEN n_a;
533c011a 1259 if (PL_op->op_flags & OPf_REF) {
924508f0 1260 EXTEND(SP,1);
638eceb6 1261 if (cGVOP_gv == PL_defgv) {
3280af22 1262 if (PL_laststype != OP_LSTAT)
cea2e8a9 1263 Perl_croak(aTHX_ "The stat preceding -l _ wasn't an lstat");
3280af22 1264 return PL_laststatval;
fe14fcc3 1265 }
cea2e8a9 1266 Perl_croak(aTHX_ "You can't use -l on a filehandle");
fe14fcc3 1267 }
c623bd54 1268
3280af22
NIS
1269 PL_laststype = OP_LSTAT;
1270 PL_statgv = Nullgv;
79072805
LW
1271 sv = POPs;
1272 PUTBACK;
2d8e6c8d 1273 sv_setpv(PL_statname,SvPV(sv, n_a));
2d8e6c8d 1274 PL_laststatval = PerlLIO_lstat(SvPV(sv, n_a),&PL_statcache);
2d8e6c8d 1275 if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, n_a), '\n'))
cea2e8a9 1276 Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "lstat");
3280af22 1277 return PL_laststatval;
c623bd54
LW
1278}
1279
a687059c 1280bool
864dbfa3 1281Perl_do_aexec(pTHX_ SV *really, register SV **mark, register SV **sp)
a687059c 1282{
d5a9bfb0
IZ
1283 return do_aexec5(really, mark, sp, 0, 0);
1284}
1285
1286bool
2aa1486d
GS
1287Perl_do_aexec5(pTHX_ SV *really, register SV **mark, register SV **sp,
1288 int fd, int do_report)
d5a9bfb0 1289{
cd39f2b6
JH
1290#ifdef MACOS_TRADITIONAL
1291 Perl_croak(aTHX_ "exec? I'm not *that* kind of operating system");
1292#else
a687059c 1293 register char **a;
a687059c 1294 char *tmps;
2d8e6c8d 1295 STRLEN n_a;
a687059c 1296
79072805 1297 if (sp > mark) {
11343788 1298 dTHR;
3280af22
NIS
1299 New(401,PL_Argv, sp - mark + 1, char*);
1300 a = PL_Argv;
79072805
LW
1301 while (++mark <= sp) {
1302 if (*mark)
2d8e6c8d 1303 *a++ = SvPVx(*mark, n_a);
a687059c
LW
1304 else
1305 *a++ = "";
1306 }
1307 *a = Nullch;
3280af22 1308 if (*PL_Argv[0] != '/') /* will execvp use PATH? */
79072805 1309 TAINT_ENV(); /* testing IFS here is overkill, probably */
2d8e6c8d 1310 if (really && *(tmps = SvPV(really, n_a)))
3280af22 1311 PerlProc_execvp(tmps,PL_Argv);
a687059c 1312 else
3280af22 1313 PerlProc_execvp(PL_Argv[0],PL_Argv);
599cee73 1314 if (ckWARN(WARN_EXEC))
a1d180c4 1315 Perl_warner(aTHX_ WARN_EXEC, "Can't exec \"%s\": %s",
599cee73 1316 PL_Argv[0], Strerror(errno));
d5a9bfb0
IZ
1317 if (do_report) {
1318 int e = errno;
1319
1320 PerlLIO_write(fd, (void*)&e, sizeof(int));
1321 PerlLIO_close(fd);
1322 }
a687059c 1323 }
bee1dbe2 1324 do_execfree();
cd39f2b6 1325#endif
a687059c
LW
1326 return FALSE;
1327}
1328
fe14fcc3 1329void
864dbfa3 1330Perl_do_execfree(pTHX)
ff8e2863 1331{
3280af22
NIS
1332 if (PL_Argv) {
1333 Safefree(PL_Argv);
1334 PL_Argv = Null(char **);
ff8e2863 1335 }
3280af22
NIS
1336 if (PL_Cmd) {
1337 Safefree(PL_Cmd);
1338 PL_Cmd = Nullch;
ff8e2863
LW
1339 }
1340}
1341
cd39f2b6 1342#if !defined(OS2) && !defined(WIN32) && !defined(DJGPP) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
760ac839 1343
a687059c 1344bool
864dbfa3 1345Perl_do_exec(pTHX_ char *cmd)
a687059c 1346{
e446cec8
IZ
1347 return do_exec3(cmd,0,0);
1348}
1349
1350bool
864dbfa3 1351Perl_do_exec3(pTHX_ char *cmd, int fd, int do_report)
e446cec8 1352{
a687059c
LW
1353 register char **a;
1354 register char *s;
a687059c
LW
1355 char flags[10];
1356
748a9306
LW
1357 while (*cmd && isSPACE(*cmd))
1358 cmd++;
1359
a687059c
LW
1360 /* save an extra exec if possible */
1361
bf38876a 1362#ifdef CSH
3280af22 1363 if (strnEQ(cmd,PL_cshname,PL_cshlen) && strnEQ(cmd+PL_cshlen," -c",3)) {
a687059c 1364 strcpy(flags,"-c");
3280af22 1365 s = cmd+PL_cshlen+3;
a687059c
LW
1366 if (*s == 'f') {
1367 s++;
1368 strcat(flags,"f");
1369 }
1370 if (*s == ' ')
1371 s++;
1372 if (*s++ == '\'') {
1373 char *ncmd = s;
1374
1375 while (*s)
1376 s++;
1377 if (s[-1] == '\n')
1378 *--s = '\0';
1379 if (s[-1] == '\'') {
1380 *--s = '\0';
3280af22 1381 PerlProc_execl(PL_cshname,"csh", flags,ncmd,(char*)0);
a687059c
LW
1382 *s = '\'';
1383 return FALSE;
1384 }
1385 }
1386 }
bf38876a 1387#endif /* CSH */
a687059c
LW
1388
1389 /* see if there are shell metacharacters in it */
1390
748a9306
LW
1391 if (*cmd == '.' && isSPACE(cmd[1]))
1392 goto doshell;
1393
1394 if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
1395 goto doshell;
1396
c170e444 1397 for (s = cmd; *s && isALNUM(*s); s++) ; /* catch VAR=val gizmo */
63f2c1e1
LW
1398 if (*s == '=')
1399 goto doshell;
748a9306 1400
a687059c 1401 for (s = cmd; *s; s++) {
93a17b20 1402 if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
a687059c
LW
1403 if (*s == '\n' && !s[1]) {
1404 *s = '\0';
1405 break;
1406 }
603a98b0
IZ
1407 /* handle the 2>&1 construct at the end */
1408 if (*s == '>' && s[1] == '&' && s[2] == '1'
1409 && s > cmd + 1 && s[-1] == '2' && isSPACE(s[-2])
1410 && (!s[3] || isSPACE(s[3])))
1411 {
1412 char *t = s + 3;
1413
1414 while (*t && isSPACE(*t))
1415 ++t;
1416 if (!*t && (dup2(1,2) != -1)) {
1417 s[-2] = '\0';
1418 break;
1419 }
1420 }
a687059c 1421 doshell:
3280af22 1422 PerlProc_execl(PL_sh_path, "sh", "-c", cmd, (char*)0);
a687059c
LW
1423 return FALSE;
1424 }
1425 }
748a9306 1426
3280af22
NIS
1427 New(402,PL_Argv, (s - cmd) / 2 + 2, char*);
1428 PL_Cmd = savepvn(cmd, s-cmd);
1429 a = PL_Argv;
1430 for (s = PL_Cmd; *s;) {
99b89507 1431 while (*s && isSPACE(*s)) s++;
a687059c
LW
1432 if (*s)
1433 *(a++) = s;
99b89507 1434 while (*s && !isSPACE(*s)) s++;
a687059c
LW
1435 if (*s)
1436 *s++ = '\0';
1437 }
1438 *a = Nullch;
3280af22
NIS
1439 if (PL_Argv[0]) {
1440 PerlProc_execvp(PL_Argv[0],PL_Argv);
b1248f16 1441 if (errno == ENOEXEC) { /* for system V NIH syndrome */
ff8e2863 1442 do_execfree();
a687059c 1443 goto doshell;
b1248f16 1444 }
d008e5eb
GS
1445 {
1446 dTHR;
e446cec8
IZ
1447 int e = errno;
1448
d008e5eb 1449 if (ckWARN(WARN_EXEC))
a1d180c4 1450 Perl_warner(aTHX_ WARN_EXEC, "Can't exec \"%s\": %s",
d008e5eb 1451 PL_Argv[0], Strerror(errno));
e446cec8
IZ
1452 if (do_report) {
1453 PerlLIO_write(fd, (void*)&e, sizeof(int));
1454 PerlLIO_close(fd);
1455 }
d008e5eb 1456 }
a687059c 1457 }
ff8e2863 1458 do_execfree();
a687059c
LW
1459 return FALSE;
1460}
1461
6890e559 1462#endif /* OS2 || WIN32 */
760ac839 1463
79072805 1464I32
864dbfa3 1465Perl_apply(pTHX_ I32 type, register SV **mark, register SV **sp)
a687059c 1466{
11343788 1467 dTHR;
79072805
LW
1468 register I32 val;
1469 register I32 val2;
1470 register I32 tot = 0;
20408e3c 1471 char *what;
a687059c 1472 char *s;
79072805 1473 SV **oldmark = mark;
2d8e6c8d 1474 STRLEN n_a;
a687059c 1475
20408e3c 1476#define APPLY_TAINT_PROPER() \
3280af22 1477 STMT_START { \
17406bd6 1478 if (PL_tainted) { TAINT_PROPER(what); } \
873ef191 1479 } STMT_END
20408e3c
GS
1480
1481 /* This is a first heuristic; it doesn't catch tainting magic. */
3280af22 1482 if (PL_tainting) {
463ee0b2 1483 while (++mark <= sp) {
bbce6d69
PP
1484 if (SvTAINTED(*mark)) {
1485 TAINT;
1486 break;
1487 }
463ee0b2
LW
1488 }
1489 mark = oldmark;
1490 }
a687059c 1491 switch (type) {
79072805 1492 case OP_CHMOD:
20408e3c
GS
1493 what = "chmod";
1494 APPLY_TAINT_PROPER();
79072805 1495 if (++mark <= sp) {
463ee0b2 1496 val = SvIVx(*mark);
20408e3c
GS
1497 APPLY_TAINT_PROPER();
1498 tot = sp - mark;
79072805 1499 while (++mark <= sp) {
2d8e6c8d 1500 char *name = SvPVx(*mark, n_a);
20408e3c
GS
1501 APPLY_TAINT_PROPER();
1502 if (PerlLIO_chmod(name, val))
a687059c
LW
1503 tot--;
1504 }
1505 }
1506 break;
fe14fcc3 1507#ifdef HAS_CHOWN
79072805 1508 case OP_CHOWN:
20408e3c
GS
1509 what = "chown";
1510 APPLY_TAINT_PROPER();
79072805 1511 if (sp - mark > 2) {
463ee0b2
LW
1512 val = SvIVx(*++mark);
1513 val2 = SvIVx(*++mark);
20408e3c 1514 APPLY_TAINT_PROPER();
a0d0e21e 1515 tot = sp - mark;
79072805 1516 while (++mark <= sp) {
2d8e6c8d 1517 char *name = SvPVx(*mark, n_a);
20408e3c 1518 APPLY_TAINT_PROPER();
36660982 1519 if (PerlLIO_chown(name, val, val2))
a687059c
LW
1520 tot--;
1521 }
1522 }
1523 break;
b1248f16 1524#endif
a1d180c4 1525/*
dd64f1c3
AD
1526XXX Should we make lchown() directly available from perl?
1527For now, we'll let Configure test for HAS_LCHOWN, but do
1528nothing in the core.
1529 --AD 5/1998
1530*/
fe14fcc3 1531#ifdef HAS_KILL
79072805 1532 case OP_KILL:
20408e3c
GS
1533 what = "kill";
1534 APPLY_TAINT_PROPER();
55497cff
PP
1535 if (mark == sp)
1536 break;
2d8e6c8d 1537 s = SvPVx(*++mark, n_a);
79072805
LW
1538 if (isUPPER(*s)) {
1539 if (*s == 'S' && s[1] == 'I' && s[2] == 'G')
1540 s += 3;
1541 if (!(val = whichsig(s)))
cea2e8a9 1542 Perl_croak(aTHX_ "Unrecognized signal name \"%s\"",s);
79072805
LW
1543 }
1544 else
463ee0b2 1545 val = SvIVx(*mark);
20408e3c
GS
1546 APPLY_TAINT_PROPER();
1547 tot = sp - mark;
3595fcef
PP
1548#ifdef VMS
1549 /* kill() doesn't do process groups (job trees?) under VMS */
1550 if (val < 0) val = -val;
1551 if (val == SIGKILL) {
1552# include <starlet.h>
1553 /* Use native sys$delprc() to insure that target process is
1554 * deleted; supervisor-mode images don't pay attention to
1555 * CRTL's emulation of Unix-style signals and kill()
1556 */
1557 while (++mark <= sp) {
1558 I32 proc = SvIVx(*mark);
1559 register unsigned long int __vmssts;
20408e3c 1560 APPLY_TAINT_PROPER();
3595fcef
PP
1561 if (!((__vmssts = sys$delprc(&proc,0)) & 1)) {
1562 tot--;
1563 switch (__vmssts) {
1564 case SS$_NONEXPR:
1565 case SS$_NOSUCHNODE:
1566 SETERRNO(ESRCH,__vmssts);
1567 break;
1568 case SS$_NOPRIV:
1569 SETERRNO(EPERM,__vmssts);
1570 break;
1571 default:
1572 SETERRNO(EVMSERR,__vmssts);
1573 }
1574 }
1575 }
1576 break;
1577 }
1578#endif
79072805
LW
1579 if (val < 0) {
1580 val = -val;
1581 while (++mark <= sp) {
463ee0b2 1582 I32 proc = SvIVx(*mark);
20408e3c 1583 APPLY_TAINT_PROPER();
fe14fcc3 1584#ifdef HAS_KILLPG
3028581b 1585 if (PerlProc_killpg(proc,val)) /* BSD */
a687059c 1586#else
3028581b 1587 if (PerlProc_kill(-proc,val)) /* SYSV */
a687059c 1588#endif
79072805 1589 tot--;
a687059c 1590 }
79072805
LW
1591 }
1592 else {
1593 while (++mark <= sp) {
20408e3c
GS
1594 I32 proc = SvIVx(*mark);
1595 APPLY_TAINT_PROPER();
1596 if (PerlProc_kill(proc, val))
79072805 1597 tot--;
a687059c
LW
1598 }
1599 }
1600 break;
b1248f16 1601#endif
79072805 1602 case OP_UNLINK:
20408e3c
GS
1603 what = "unlink";
1604 APPLY_TAINT_PROPER();
79072805
LW
1605 tot = sp - mark;
1606 while (++mark <= sp) {
2d8e6c8d 1607 s = SvPVx(*mark, n_a);
20408e3c 1608 APPLY_TAINT_PROPER();
3280af22 1609 if (PL_euid || PL_unsafe) {
a687059c
LW
1610 if (UNLINK(s))
1611 tot--;
1612 }
1613 else { /* don't let root wipe out directories without -U */
3280af22 1614 if (PerlLIO_lstat(s,&PL_statbuf) < 0 || S_ISDIR(PL_statbuf.st_mode))
a687059c
LW
1615 tot--;
1616 else {
1617 if (UNLINK(s))
1618 tot--;
1619 }
1620 }
1621 }
1622 break;
a0d0e21e 1623#ifdef HAS_UTIME
79072805 1624 case OP_UTIME:
20408e3c
GS
1625 what = "utime";
1626 APPLY_TAINT_PROPER();
79072805 1627 if (sp - mark > 2) {
748a9306 1628#if defined(I_UTIME) || defined(VMS)
663a0e37
LW
1629 struct utimbuf utbuf;
1630#else
a687059c 1631 struct {
dd2821f6
GS
1632 Time_t actime;
1633 Time_t modtime;
a687059c 1634 } utbuf;
663a0e37 1635#endif
a687059c 1636
afd9f252 1637 Zero(&utbuf, sizeof utbuf, char);
517844ec 1638#ifdef BIG_TIME
dd2821f6
GS
1639 utbuf.actime = (Time_t)SvNVx(*++mark); /* time accessed */
1640 utbuf.modtime = (Time_t)SvNVx(*++mark); /* time modified */
517844ec 1641#else
dd2821f6
GS
1642 utbuf.actime = (Time_t)SvIVx(*++mark); /* time accessed */
1643 utbuf.modtime = (Time_t)SvIVx(*++mark); /* time modified */
517844ec 1644#endif
20408e3c 1645 APPLY_TAINT_PROPER();
79072805
LW
1646 tot = sp - mark;
1647 while (++mark <= sp) {
2d8e6c8d 1648 char *name = SvPVx(*mark, n_a);
20408e3c
GS
1649 APPLY_TAINT_PROPER();
1650 if (PerlLIO_utime(name, &utbuf))
a687059c
LW
1651 tot--;
1652 }
a687059c
LW
1653 }
1654 else
79072805 1655 tot = 0;
a687059c 1656 break;
a0d0e21e 1657#endif
a687059c
LW
1658 }
1659 return tot;
20408e3c 1660
20408e3c 1661#undef APPLY_TAINT_PROPER
a687059c
LW
1662}
1663
1664/* Do the permissions allow some operation? Assumes statcache already set. */
a0d0e21e 1665#ifndef VMS /* VMS' cando is in vms.c */
7f4774ae
JH
1666bool
1667Perl_cando(pTHX_ Mode_t mode, Uid_t effective, register Stat_t *statbufp)
1668/* Note: we use `effective' both for uids and gids.
1669 * Here we are betting on Uid_t being equal or wider than Gid_t. */
a687059c 1670{
bee1dbe2 1671#ifdef DOSISH
fe14fcc3
LW
1672 /* [Comments and code from Len Reed]
1673 * MS-DOS "user" is similar to UNIX's "superuser," but can't write
1674 * to write-protected files. The execute permission bit is set
1675 * by the Miscrosoft C library stat() function for the following:
1676 * .exe files
1677 * .com files
1678 * .bat files
1679 * directories
1680 * All files and directories are readable.
1681 * Directories and special files, e.g. "CON", cannot be
1682 * write-protected.
1683 * [Comment by Tom Dinger -- a directory can have the write-protect
1684 * bit set in the file system, but DOS permits changes to
1685 * the directory anyway. In addition, all bets are off
1686 * here for networked software, such as Novell and
1687 * Sun's PC-NFS.]
1688 */
1689
bee1dbe2
LW
1690 /* Atari stat() does pretty much the same thing. we set x_bit_set_in_stat
1691 * too so it will actually look into the files for magic numbers
1692 */
7f4774ae 1693 return (mode & statbufp->st_mode) ? TRUE : FALSE;
fe14fcc3 1694
55497cff 1695#else /* ! DOSISH */
3280af22 1696 if ((effective ? PL_euid : PL_uid) == 0) { /* root is special */
7f4774ae 1697 if (mode == S_IXUSR) {
c623bd54 1698 if (statbufp->st_mode & 0111 || S_ISDIR(statbufp->st_mode))
a687059c
LW
1699 return TRUE;
1700 }
1701 else
1702 return TRUE; /* root reads and writes anything */
1703 return FALSE;
1704 }
3280af22 1705 if (statbufp->st_uid == (effective ? PL_euid : PL_uid) ) {
7f4774ae 1706 if (statbufp->st_mode & mode)
a687059c
LW
1707 return TRUE; /* ok as "user" */
1708 }
d8eceb89 1709 else if (ingroup(statbufp->st_gid,effective)) {
7f4774ae 1710 if (statbufp->st_mode & mode >> 3)
a687059c
LW
1711 return TRUE; /* ok as "group" */
1712 }
7f4774ae 1713 else if (statbufp->st_mode & mode >> 6)
a687059c
LW
1714 return TRUE; /* ok as "other" */
1715 return FALSE;
55497cff 1716#endif /* ! DOSISH */
a687059c 1717}
a0d0e21e 1718#endif /* ! VMS */
a687059c 1719
d8eceb89
JH
1720bool
1721Perl_ingroup(pTHX_ Gid_t testgid, Uid_t effective)
a687059c 1722{
cd39f2b6
JH
1723#ifdef MACOS_TRADITIONAL
1724 /* This is simply not correct for AppleShare, but fix it yerself. */
1725 return TRUE;
1726#else
3280af22 1727 if (testgid == (effective ? PL_egid : PL_gid))
a687059c 1728 return TRUE;
fe14fcc3 1729#ifdef HAS_GETGROUPS
a687059c
LW
1730#ifndef NGROUPS
1731#define NGROUPS 32
1732#endif
1733 {
a0d0e21e 1734 Groups_t gary[NGROUPS];
79072805 1735 I32 anum;
a687059c
LW
1736
1737 anum = getgroups(NGROUPS,gary);
1738 while (--anum >= 0)
1739 if (gary[anum] == testgid)
1740 return TRUE;
1741 }
1742#endif
1743 return FALSE;
cd39f2b6 1744#endif
a687059c 1745}
c2ab57d4 1746
fe14fcc3 1747#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
c2ab57d4 1748
79072805 1749I32
864dbfa3 1750Perl_do_ipcget(pTHX_ I32 optype, SV **mark, SV **sp)
c2ab57d4 1751{
11343788 1752 dTHR;
c2ab57d4 1753 key_t key;
79072805 1754 I32 n, flags;
c2ab57d4 1755
463ee0b2
LW
1756 key = (key_t)SvNVx(*++mark);
1757 n = (optype == OP_MSGGET) ? 0 : SvIVx(*++mark);
1758 flags = SvIVx(*++mark);
748a9306 1759 SETERRNO(0,0);
c2ab57d4
LW
1760 switch (optype)
1761 {
fe14fcc3 1762#ifdef HAS_MSG
79072805 1763 case OP_MSGGET:
c2ab57d4 1764 return msgget(key, flags);
e5d73d77 1765#endif
fe14fcc3 1766#ifdef HAS_SEM
79072805 1767 case OP_SEMGET:
c2ab57d4 1768 return semget(key, n, flags);
e5d73d77 1769#endif
fe14fcc3 1770#ifdef HAS_SHM
79072805 1771 case OP_SHMGET:
c2ab57d4 1772 return shmget(key, n, flags);
e5d73d77 1773#endif
fe14fcc3 1774#if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
e5d73d77 1775 default:
cea2e8a9 1776 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
e5d73d77 1777#endif
c2ab57d4
LW
1778 }
1779 return -1; /* should never happen */
1780}
1781
79072805 1782I32
864dbfa3 1783Perl_do_ipcctl(pTHX_ I32 optype, SV **mark, SV **sp)
c2ab57d4 1784{
11343788 1785 dTHR;
79072805 1786 SV *astr;
c2ab57d4 1787 char *a;
a0d0e21e
LW
1788 I32 id, n, cmd, infosize, getinfo;
1789 I32 ret = -1;
c2ab57d4 1790
463ee0b2
LW
1791 id = SvIVx(*++mark);
1792 n = (optype == OP_SEMCTL) ? SvIVx(*++mark) : 0;
1793 cmd = SvIVx(*++mark);
79072805 1794 astr = *++mark;
c2ab57d4
LW
1795 infosize = 0;
1796 getinfo = (cmd == IPC_STAT);
1797
1798 switch (optype)
1799 {
fe14fcc3 1800#ifdef HAS_MSG
79072805 1801 case OP_MSGCTL:
c2ab57d4
LW
1802 if (cmd == IPC_STAT || cmd == IPC_SET)
1803 infosize = sizeof(struct msqid_ds);
1804 break;
e5d73d77 1805#endif
fe14fcc3 1806#ifdef HAS_SHM
79072805 1807 case OP_SHMCTL:
c2ab57d4
LW
1808 if (cmd == IPC_STAT || cmd == IPC_SET)
1809 infosize = sizeof(struct shmid_ds);
1810 break;
e5d73d77 1811#endif
fe14fcc3 1812#ifdef HAS_SEM
79072805 1813 case OP_SEMCTL:
39398f3f 1814#ifdef Semctl
c2ab57d4
LW
1815 if (cmd == IPC_STAT || cmd == IPC_SET)
1816 infosize = sizeof(struct semid_ds);
1817 else if (cmd == GETALL || cmd == SETALL)
1818 {
8e591e46 1819 struct semid_ds semds;
bd89102f 1820 union semun semun;
e6f0bdd6
GS
1821#ifdef EXTRA_F_IN_SEMUN_BUF
1822 semun.buff = &semds;
1823#else
84902520 1824 semun.buf = &semds;
e6f0bdd6 1825#endif
c2ab57d4 1826 getinfo = (cmd == GETALL);
9b89d93d
GB
1827 if (Semctl(id, 0, IPC_STAT, semun) == -1)
1828 return -1;
6e21c824
LW
1829 infosize = semds.sem_nsems * sizeof(short);
1830 /* "short" is technically wrong but much more portable
1831 than guessing about u_?short(_t)? */
c2ab57d4 1832 }
39398f3f 1833#else
cea2e8a9 1834 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
39398f3f 1835#endif
c2ab57d4 1836 break;
e5d73d77 1837#endif
fe14fcc3 1838#if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
e5d73d77 1839 default:
cea2e8a9 1840 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
e5d73d77 1841#endif
c2ab57d4
LW
1842 }
1843
1844 if (infosize)
1845 {
a0d0e21e 1846 STRLEN len;
c2ab57d4
LW
1847 if (getinfo)
1848 {
a0d0e21e
LW
1849 SvPV_force(astr, len);
1850 a = SvGROW(astr, infosize+1);
c2ab57d4
LW
1851 }
1852 else
1853 {
463ee0b2
LW
1854 a = SvPV(astr, len);
1855 if (len != infosize)
cea2e8a9 1856 Perl_croak(aTHX_ "Bad arg length for %s, is %lu, should be %ld",
4ec43091
JH
1857 PL_op_desc[optype],
1858 (unsigned long)len,
1859 (long)infosize);
c2ab57d4
LW
1860 }
1861 }
1862 else
1863 {
c030ccd9 1864 IV i = SvIV(astr);
56431972 1865 a = INT2PTR(char *,i); /* ouch */
c2ab57d4 1866 }
748a9306 1867 SETERRNO(0,0);
c2ab57d4
LW
1868 switch (optype)
1869 {
fe14fcc3 1870#ifdef HAS_MSG
79072805 1871 case OP_MSGCTL:
bee1dbe2 1872 ret = msgctl(id, cmd, (struct msqid_ds *)a);
c2ab57d4 1873 break;
e5d73d77 1874#endif
fe14fcc3 1875#ifdef HAS_SEM
bd89102f 1876 case OP_SEMCTL: {
39398f3f 1877#ifdef Semctl
bd89102f
AD
1878 union semun unsemds;
1879
e6f0bdd6
GS
1880#ifdef EXTRA_F_IN_SEMUN_BUF
1881 unsemds.buff = (struct semid_ds *)a;
1882#else
bd89102f 1883 unsemds.buf = (struct semid_ds *)a;
e6f0bdd6 1884#endif
bd89102f 1885 ret = Semctl(id, n, cmd, unsemds);
39398f3f 1886#else
cea2e8a9 1887 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
39398f3f 1888#endif
bd89102f 1889 }
c2ab57d4 1890 break;
e5d73d77 1891#endif
fe14fcc3 1892#ifdef HAS_SHM
79072805 1893 case OP_SHMCTL:
bee1dbe2 1894 ret = shmctl(id, cmd, (struct shmid_ds *)a);
c2ab57d4 1895 break;
e5d73d77 1896#endif
c2ab57d4
LW
1897 }
1898 if (getinfo && ret >= 0) {
79072805
LW
1899 SvCUR_set(astr, infosize);
1900 *SvEND(astr) = '\0';
a0d0e21e 1901 SvSETMAGIC(astr);
c2ab57d4
LW
1902 }
1903 return ret;
1904}
1905
79072805 1906I32
864dbfa3 1907Perl_do_msgsnd(pTHX_ SV **mark, SV **sp)
c2ab57d4 1908{
fe14fcc3 1909#ifdef HAS_MSG
11343788 1910 dTHR;
79072805 1911 SV *mstr;
c2ab57d4 1912 char *mbuf;
79072805 1913 I32 id, msize, flags;
463ee0b2 1914 STRLEN len;
c2ab57d4 1915
463ee0b2 1916 id = SvIVx(*++mark);
79072805 1917 mstr = *++mark;
463ee0b2
LW
1918 flags = SvIVx(*++mark);
1919 mbuf = SvPV(mstr, len);
1920 if ((msize = len - sizeof(long)) < 0)
cea2e8a9 1921 Perl_croak(aTHX_ "Arg too short for msgsnd");
748a9306 1922 SETERRNO(0,0);
bee1dbe2 1923 return msgsnd(id, (struct msgbuf *)mbuf, msize, flags);
e5d73d77 1924#else
cea2e8a9 1925 Perl_croak(aTHX_ "msgsnd not implemented");
e5d73d77 1926#endif
c2ab57d4
LW
1927}
1928
79072805 1929I32
864dbfa3 1930Perl_do_msgrcv(pTHX_ SV **mark, SV **sp)
c2ab57d4 1931{
fe14fcc3 1932#ifdef HAS_MSG
11343788 1933 dTHR;
79072805 1934 SV *mstr;
c2ab57d4
LW
1935 char *mbuf;
1936 long mtype;
79072805 1937 I32 id, msize, flags, ret;
463ee0b2 1938 STRLEN len;
79072805 1939
463ee0b2 1940 id = SvIVx(*++mark);
79072805 1941 mstr = *++mark;
c2e66d9e
GS
1942 /* suppress warning when reading into undef var --jhi */
1943 if (! SvOK(mstr))
1944 sv_setpvn(mstr, "", 0);
463ee0b2
LW
1945 msize = SvIVx(*++mark);
1946 mtype = (long)SvIVx(*++mark);
1947 flags = SvIVx(*++mark);
a0d0e21e
LW
1948 SvPV_force(mstr, len);
1949 mbuf = SvGROW(mstr, sizeof(long)+msize+1);
a1d180c4 1950
748a9306 1951 SETERRNO(0,0);
bee1dbe2 1952 ret = msgrcv(id, (struct msgbuf *)mbuf, msize, mtype, flags);
c2ab57d4 1953 if (ret >= 0) {
79072805
LW
1954 SvCUR_set(mstr, sizeof(long)+ret);
1955 *SvEND(mstr) = '\0';
41d6edb2
JH
1956#ifndef INCOMPLETE_TAINTS
1957 /* who knows who has been playing with this message? */
1958 SvTAINTED_on(mstr);
1959#endif
c2ab57d4
LW
1960 }
1961 return ret;
e5d73d77 1962#else
cea2e8a9 1963 Perl_croak(aTHX_ "msgrcv not implemented");
e5d73d77 1964#endif
c2ab57d4
LW
1965}
1966
79072805 1967I32
864dbfa3 1968Perl_do_semop(pTHX_ SV **mark, SV **sp)
c2ab57d4 1969{
fe14fcc3 1970#ifdef HAS_SEM
11343788 1971 dTHR;
79072805 1972 SV *opstr;
c2ab57d4 1973 char *opbuf;
463ee0b2
LW
1974 I32 id;
1975 STRLEN opsize;
c2ab57d4 1976
463ee0b2 1977 id = SvIVx(*++mark);
79072805 1978 opstr = *++mark;
463ee0b2 1979 opbuf = SvPV(opstr, opsize);
c2ab57d4
LW
1980 if (opsize < sizeof(struct sembuf)
1981 || (opsize % sizeof(struct sembuf)) != 0) {
748a9306 1982 SETERRNO(EINVAL,LIB$_INVARG);
c2ab57d4
LW
1983 return -1;
1984 }
748a9306 1985 SETERRNO(0,0);
6e21c824 1986 return semop(id, (struct sembuf *)opbuf, opsize/sizeof(struct sembuf));
e5d73d77 1987#else
cea2e8a9 1988 Perl_croak(aTHX_ "semop not implemented");
e5d73d77 1989#endif
c2ab57d4
LW
1990}
1991
79072805 1992I32
864dbfa3 1993Perl_do_shmio(pTHX_ I32 optype, SV **mark, SV **sp)
c2ab57d4 1994{
fe14fcc3 1995#ifdef HAS_SHM
11343788 1996 dTHR;
79072805 1997 SV *mstr;
c2ab57d4 1998 char *mbuf, *shm;
79072805 1999 I32 id, mpos, msize;
463ee0b2 2000 STRLEN len;
c2ab57d4 2001 struct shmid_ds shmds;
c2ab57d4 2002
463ee0b2 2003 id = SvIVx(*++mark);
79072805 2004 mstr = *++mark;
463ee0b2
LW
2005 mpos = SvIVx(*++mark);
2006 msize = SvIVx(*++mark);
748a9306 2007 SETERRNO(0,0);
c2ab57d4
LW
2008 if (shmctl(id, IPC_STAT, &shmds) == -1)
2009 return -1;
2010 if (mpos < 0 || msize < 0 || mpos + msize > shmds.shm_segsz) {
748a9306 2011 SETERRNO(EFAULT,SS$_ACCVIO); /* can't do as caller requested */
c2ab57d4
LW
2012 return -1;
2013 }
8ac85365 2014 shm = (char *)shmat(id, (char*)NULL, (optype == OP_SHMREAD) ? SHM_RDONLY : 0);
c2ab57d4
LW
2015 if (shm == (char *)-1) /* I hate System V IPC, I really do */
2016 return -1;
79072805 2017 if (optype == OP_SHMREAD) {
9f538c04
GS
2018 /* suppress warning when reading into undef var (tchrist 3/Mar/00) */
2019 if (! SvOK(mstr))
2020 sv_setpvn(mstr, "", 0);
a0d0e21e
LW
2021 SvPV_force(mstr, len);
2022 mbuf = SvGROW(mstr, msize+1);
2023
bee1dbe2 2024 Copy(shm + mpos, mbuf, msize, char);
79072805
LW
2025 SvCUR_set(mstr, msize);
2026 *SvEND(mstr) = '\0';
a0d0e21e 2027 SvSETMAGIC(mstr);
d929ce6f
JH
2028#ifndef INCOMPLETE_TAINTS
2029 /* who knows who has been playing with this shared memory? */
2030 SvTAINTED_on(mstr);
2031#endif
c2ab57d4
LW
2032 }
2033 else {
79072805 2034 I32 n;
c2ab57d4 2035
a0d0e21e 2036 mbuf = SvPV(mstr, len);
463ee0b2 2037 if ((n = len) > msize)
c2ab57d4 2038 n = msize;
bee1dbe2 2039 Copy(mbuf, shm + mpos, n, char);
c2ab57d4 2040 if (n < msize)
bee1dbe2 2041 memzero(shm + mpos + n, msize - n);
c2ab57d4
LW
2042 }
2043 return shmdt(shm);
e5d73d77 2044#else
cea2e8a9 2045 Perl_croak(aTHX_ "shm I/O not implemented");
e5d73d77 2046#endif
c2ab57d4
LW
2047}
2048
fe14fcc3 2049#endif /* SYSV IPC */
4e35701f 2050