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
Promote v5.36 usage and feature bundles doc
[perl5.git] / doio.c
CommitLineData
a0d0e21e 1/* doio.c
a687059c 2 *
1129b882
NC		 3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
a687059c 5 *
6e21c824
LW		 6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
a687059c 8 *
a0d0e21e
LW		 9 */
10
11/*
4ac71550
TC		 12 * Far below them they saw the white waters pour into a foaming bowl, and
13 * then swirl darkly about a deep oval basin in the rocks, until they found
14 * their way out again through a narrow gate, and flowed away, fuming and
15 * chattering, into calmer and more level reaches.
16 *
17 * [p.684 of _The Lord of the Rings_, IV/vi: "The Forbidden Pool"]
a687059c
LW		 18 */
19
166f8a29
DM		 20/* This file contains functions that do the actual I/O on behalf of ops.
21 * For example, pp_print() calls the do_print() function in this file for
22 * each argument needing printing.
23 */
24
a687059c 25#include "EXTERN.h"
864dbfa3 26#define PERL_IN_DOIO_C
a687059c
LW		 27#include "perl.h"
28
fe14fcc3 29#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
aec308ec 30#ifndef HAS_SEM
c2ab57d4 31#include <sys/ipc.h>
aec308ec 32#endif
fe14fcc3 33#ifdef HAS_MSG
c2ab57d4 34#include <sys/msg.h>
e5d73d77 35#endif
fe14fcc3 36#ifdef HAS_SHM
c2ab57d4 37#include <sys/shm.h>
a0d0e21e 38# ifndef HAS_SHMAT_PROTOTYPE
20ce7b12 39 extern Shmat_t shmat (int, char *, int);
a0d0e21e 40# endif
c2ab57d4 41#endif
e5d73d77 42#endif
c2ab57d4 43
663a0e37 44#ifdef I_UTIME
3730b96e 45# if defined(_MSC_VER) || defined(__MINGW32__)
3fe9a6f1 46# include <sys/utime.h>
47# else
48# include <utime.h>
49# endif
663a0e37 50#endif
85aff577 51
85aff577
CS		 52#ifdef O_EXCL
53# define OPEN_EXCL O_EXCL
54#else
55# define OPEN_EXCL 0
56#endif
a687059c 57
0c19750d
SP		 58#define PERL_MODE_MAX 8
59#define PERL_FLAGS_MAX 10
60
76121258 61#include <signal.h>
76121258 62
74df577f 63void
1cdb2692 64Perl_setfd_cloexec(int fd)
74df577f
Z		 65{
66 assert(fd >= 0);
f9821aff 67#if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
74df577f 68 (void) fcntl(fd, F_SETFD, FD_CLOEXEC);
f9821aff 69#endif
74df577f
Z		 70}
71
72void
1cdb2692 73Perl_setfd_inhexec(int fd)
74df577f
Z		 74{
75 assert(fd >= 0);
76#if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
77 (void) fcntl(fd, F_SETFD, 0);
78#endif
79}
80
81void
884fc2d3
Z		 82Perl_setfd_cloexec_for_nonsysfd(pTHX_ int fd)
83{
84 assert(fd >= 0);
85 if(fd > PL_maxsysfd)
1604cfb0 86 setfd_cloexec(fd);
884fc2d3
Z		 87}
88
89void
74df577f
Z		 90Perl_setfd_inhexec_for_sysfd(pTHX_ int fd)
91{
92 assert(fd >= 0);
93 if(fd <= PL_maxsysfd)
1604cfb0 94 setfd_inhexec(fd);
74df577f 95}
884fc2d3
Z		 96void
97Perl_setfd_cloexec_or_inhexec_by_sysfdness(pTHX_ int fd)
98{
99 assert(fd >= 0);
100 if(fd <= PL_maxsysfd)
1604cfb0 101 setfd_inhexec(fd);
884fc2d3 102 else
1604cfb0 103 setfd_cloexec(fd);
884fc2d3
Z		 104}
105
74df577f
Z		 106
107#define DO_GENOPEN_THEN_CLOEXEC(GENOPEN_NORMAL, GENSETFD_CLOEXEC) \
1604cfb0
MS		 108 do { \
109 int res = (GENOPEN_NORMAL); \
110 if(LIKELY(res != -1)) GENSETFD_CLOEXEC; \
111 return res; \
112 } while(0)
f9821aff 113#if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC) && \
1604cfb0 114 defined(F_GETFD)
999d65ed
DM		 115enum { CLOEXEC_EXPERIMENT = 0, CLOEXEC_AT_OPEN, CLOEXEC_AFTER_OPEN };
116# define DO_GENOPEN_EXPERIMENTING_CLOEXEC(strategy, TESTFD, GENOPEN_CLOEXEC, \
1604cfb0
MS		 117 GENOPEN_NORMAL, GENSETFD_CLOEXEC) \
118 do { \
119 switch (strategy) { \
120 case CLOEXEC_EXPERIMENT: default: { \
121 int res = (GENOPEN_CLOEXEC), eno; \
122 if (LIKELY(res != -1)) { \
123 int fdflags = fcntl((TESTFD), F_GETFD); \
124 if (LIKELY(fdflags != -1) && \
125 LIKELY(fdflags & FD_CLOEXEC)) { \
126 strategy = CLOEXEC_AT_OPEN; \
127 } else { \
128 strategy = CLOEXEC_AFTER_OPEN; \
129 GENSETFD_CLOEXEC; \
130 } \
131 } else if (UNLIKELY((eno = errno) == EINVAL || \
132 eno == ENOSYS)) { \
133 res = (GENOPEN_NORMAL); \
134 if (LIKELY(res != -1)) { \
135 strategy = CLOEXEC_AFTER_OPEN; \
136 GENSETFD_CLOEXEC; \
137 } else if (!LIKELY((eno = errno) == EINVAL || \
138 eno == ENOSYS)) { \
139 strategy = CLOEXEC_AFTER_OPEN; \
140 } \
141 } \
142 return res; \
143 } \
144 case CLOEXEC_AT_OPEN: \
145 return (GENOPEN_CLOEXEC); \
146 case CLOEXEC_AFTER_OPEN: \
147 DO_GENOPEN_THEN_CLOEXEC(GENOPEN_NORMAL, GENSETFD_CLOEXEC); \
148 } \
149 } while(0)
f9821aff 150#else
999d65ed 151# define DO_GENOPEN_EXPERIMENTING_CLOEXEC(strategy, TESTFD, GENOPEN_CLOEXEC, \
1604cfb0
MS		 152 GENOPEN_NORMAL, GENSETFD_CLOEXEC) \
153 DO_GENOPEN_THEN_CLOEXEC(GENOPEN_NORMAL, GENSETFD_CLOEXEC)
f9821aff
Z		 154#endif
155
156#define DO_ONEOPEN_THEN_CLOEXEC(ONEOPEN_NORMAL) \
1604cfb0
MS		 157 do { \
158 int fd; \
159 DO_GENOPEN_THEN_CLOEXEC(fd = (ONEOPEN_NORMAL), \
160 setfd_cloexec(fd)); \
161 } while(0)
999d65ed
DM		 162#define DO_ONEOPEN_EXPERIMENTING_CLOEXEC(strategy, \
163 ONEOPEN_CLOEXEC, ONEOPEN_NORMAL) \
1604cfb0
MS		 164 do { \
165 int fd; \
166 DO_GENOPEN_EXPERIMENTING_CLOEXEC(strategy, \
999d65ed
DM		 167 fd, \
168 fd = (ONEOPEN_CLOEXEC), \
1604cfb0
MS		 169 fd = (ONEOPEN_NORMAL), setfd_cloexec(fd)); \
170 } while(0)
f9821aff 171
74df577f 172#define DO_PIPESETFD_CLOEXEC(PIPEFD) \
1604cfb0
MS		 173 do { \
174 setfd_cloexec((PIPEFD)[0]); \
175 setfd_cloexec((PIPEFD)[1]); \
176 } while(0)
f9821aff 177#define DO_PIPEOPEN_THEN_CLOEXEC(PIPEFD, PIPEOPEN_NORMAL) \
1604cfb0 178 DO_GENOPEN_THEN_CLOEXEC(PIPEOPEN_NORMAL, DO_PIPESETFD_CLOEXEC(PIPEFD))
999d65ed 179#define DO_PIPEOPEN_EXPERIMENTING_CLOEXEC(strategy, PIPEFD, PIPEOPEN_CLOEXEC, \
1604cfb0
MS		 180 PIPEOPEN_NORMAL) \
181 DO_GENOPEN_EXPERIMENTING_CLOEXEC(strategy, \
999d65ed 182 (PIPEFD)[0], PIPEOPEN_CLOEXEC, \
1604cfb0 183 PIPEOPEN_NORMAL, DO_PIPESETFD_CLOEXEC(PIPEFD))
f9821aff
Z		 184
185int
186Perl_PerlLIO_dup_cloexec(pTHX_ int oldfd)
187{
188#if !defined(PERL_IMPLICIT_SYS) && defined(F_DUPFD_CLOEXEC)
189 /*
190 * struct IPerlLIO doesn't cover fcntl(), and there's no clear way
191 * to extend it, so for the time being this just isn't available on
192 * PERL_IMPLICIT_SYS builds.
193 */
194 DO_ONEOPEN_EXPERIMENTING_CLOEXEC(
999d65ed 195 PL_strategy_dup,
1604cfb0
MS		 196 fcntl(oldfd, F_DUPFD_CLOEXEC, 0),
197 PerlLIO_dup(oldfd));
f9821aff
Z		 198#else
199 DO_ONEOPEN_THEN_CLOEXEC(PerlLIO_dup(oldfd));
200#endif
201}
202
203int
204Perl_PerlLIO_dup2_cloexec(pTHX_ int oldfd, int newfd)
205{
206#if !defined(PERL_IMPLICIT_SYS) && defined(HAS_DUP3) && defined(O_CLOEXEC)
207 /*
208 * struct IPerlLIO doesn't cover dup3(), and there's no clear way
209 * to extend it, so for the time being this just isn't available on
210 * PERL_IMPLICIT_SYS builds.
211 */
212 DO_ONEOPEN_EXPERIMENTING_CLOEXEC(
999d65ed 213 PL_strategy_dup2,
1604cfb0
MS		 214 dup3(oldfd, newfd, O_CLOEXEC),
215 PerlLIO_dup2(oldfd, newfd));
f9821aff
Z		 216#else
217 DO_ONEOPEN_THEN_CLOEXEC(PerlLIO_dup2(oldfd, newfd));
218#endif
219}
220
1c267c88
MF		 221#if defined(OEMVS)
222 #if (__CHARSET_LIB == 1)
223# include <stdio.h>
224# include <stdlib.h>
225
226 static int setccsid(int fd, int ccsid)
227 {
228 attrib_t attr;
229 int rc;
230
231 memset(&attr, 0, sizeof(attr));
232 attr.att_filetagchg = 1;
233 attr.att_filetag.ft_ccsid = ccsid;
234 attr.att_filetag.ft_txtflag = 1;
235
236 rc = __fchattr(fd, &attr, sizeof(attr));
237 return rc;
238 }
239
240 static void updateccsid(int fd, const char* path, int oflag, int perm)
241 {
242 int rc;
243 if (oflag & O_CREAT) {
244 rc = setccsid(fd, 819);
245 }
246 }
247
248 int asciiopen(const char* path, int oflag)
249 {
250 int rc;
251 int fd = open(path, oflag);
252 if (fd == -1) {
253 return fd;
254 }
255 updateccsid(fd, path, oflag, -1);
256 return fd;
257 }
258
259 int asciiopen3(const char* path, int oflag, int perm)
260 {
261 int rc;
262 int fd = open(path, oflag, perm);
263 if (fd == -1) {
264 return fd;
265 }
266 updateccsid(fd, path, oflag, perm);
267 return fd;
268 }
269 #endif
270#endif
271
f9821aff
Z		 272int
273Perl_PerlLIO_open_cloexec(pTHX_ const char *file, int flag)
274{
275 PERL_ARGS_ASSERT_PERLLIO_OPEN_CLOEXEC;
276#if defined(O_CLOEXEC)
277 DO_ONEOPEN_EXPERIMENTING_CLOEXEC(
999d65ed 278 PL_strategy_open,
1604cfb0
MS		 279 PerlLIO_open(file, flag | O_CLOEXEC),
280 PerlLIO_open(file, flag));
f9821aff
Z		 281#else
282 DO_ONEOPEN_THEN_CLOEXEC(PerlLIO_open(file, flag));
283#endif
284}
285
286int
287Perl_PerlLIO_open3_cloexec(pTHX_ const char *file, int flag, int perm)
288{
289 PERL_ARGS_ASSERT_PERLLIO_OPEN3_CLOEXEC;
290#if defined(O_CLOEXEC)
291 DO_ONEOPEN_EXPERIMENTING_CLOEXEC(
999d65ed 292 PL_strategy_open3,
1604cfb0
MS		 293 PerlLIO_open3(file, flag | O_CLOEXEC, perm),
294 PerlLIO_open3(file, flag, perm));
f9821aff
Z		 295#else
296 DO_ONEOPEN_THEN_CLOEXEC(PerlLIO_open3(file, flag, perm));
297#endif
298}
299
1c267c88
MF		 300#if defined(OEMVS)
301 #if (__CHARSET_LIB == 1)
302 #define TEMP_CCSID 819
303 #endif
304static int Internal_Perl_my_mkstemp_cloexec(char *templte)
305{
306 PERL_ARGS_ASSERT_MY_MKSTEMP_CLOEXEC;
703a5fb0 307# if defined(O_CLOEXEC)
1c267c88
MF		 308 DO_ONEOPEN_EXPERIMENTING_CLOEXEC(
309 PL_strategy_mkstemp,
310 Perl_my_mkostemp(templte, O_CLOEXEC),
311 Perl_my_mkstemp(templte));
703a5fb0 312# else
1c267c88 313 DO_ONEOPEN_THEN_CLOEXEC(Perl_my_mkstemp(templte));
703a5fb0 314# endif
1c267c88 315}
1cdb2692 316int
1c267c88
MF		 317Perl_my_mkstemp_cloexec(char *templte)
318{
319 int tempfd = Internal_Perl_my_mkstemp_cloexec(templte);
703a5fb0 320# if defined(TEMP_CCSID)
1c267c88 321 setccsid(tempfd, TEMP_CCSID);
703a5fb0 322# endif
1c267c88
MF		 323 return tempfd;
324}
325
703a5fb0 326# else /* Below is ! OEMVS */
2c05b8b9 327int
1c267c88 328Perl_my_mkstemp_cloexec(char *templte)
1cdb2692
Z		 329{
330 PERL_ARGS_ASSERT_MY_MKSTEMP_CLOEXEC;
703a5fb0 331# if defined(O_CLOEXEC)
1cdb2692 332 DO_ONEOPEN_EXPERIMENTING_CLOEXEC(
999d65ed 333 PL_strategy_mkstemp,
1604cfb0
MS		 334 Perl_my_mkostemp(templte, O_CLOEXEC),
335 Perl_my_mkstemp(templte));
703a5fb0 336# else
1cdb2692 337 DO_ONEOPEN_THEN_CLOEXEC(Perl_my_mkstemp(templte));
703a5fb0 338# endif
1cdb2692 339}
1c267c88 340#endif
1cdb2692 341
ae73d7ec
TC		 342int
343Perl_my_mkostemp_cloexec(char *templte, int flags)
344{
ae73d7ec
TC		 345 PERL_ARGS_ASSERT_MY_MKOSTEMP_CLOEXEC;
346#if defined(O_CLOEXEC)
347 DO_ONEOPEN_EXPERIMENTING_CLOEXEC(
348 PL_strategy_mkstemp,
1604cfb0
MS		 349 Perl_my_mkostemp(templte, flags | O_CLOEXEC),
350 Perl_my_mkostemp(templte, flags));
ae73d7ec
TC		 351#else
352 DO_ONEOPEN_THEN_CLOEXEC(Perl_my_mkostemp(templte, flags));
353#endif
354}
355
f9821aff
Z		 356#ifdef HAS_PIPE
357int
358Perl_PerlProc_pipe_cloexec(pTHX_ int *pipefd)
359{
360 PERL_ARGS_ASSERT_PERLPROC_PIPE_CLOEXEC;
361 /*
362 * struct IPerlProc doesn't cover pipe2(), and there's no clear way
363 * to extend it, so for the time being this just isn't available on
364 * PERL_IMPLICIT_SYS builds.
365 */
366# if !defined(PERL_IMPLICIT_SYS) && defined(HAS_PIPE2) && defined(O_CLOEXEC)
999d65ed 367 DO_PIPEOPEN_EXPERIMENTING_CLOEXEC(PL_strategy_pipe, pipefd,
1604cfb0
MS		 368 pipe2(pipefd, O_CLOEXEC),
369 PerlProc_pipe(pipefd));
f9821aff
Z		 370# else
371 DO_PIPEOPEN_THEN_CLOEXEC(pipefd, PerlProc_pipe(pipefd));
372# endif
373}
374#endif
375
376#ifdef HAS_SOCKET
377
378int
379Perl_PerlSock_socket_cloexec(pTHX_ int domain, int type, int protocol)
380{
381# if defined(SOCK_CLOEXEC)
382 DO_ONEOPEN_EXPERIMENTING_CLOEXEC(
999d65ed 383 PL_strategy_socket,
1604cfb0
MS		 384 PerlSock_socket(domain, type | SOCK_CLOEXEC, protocol),
385 PerlSock_socket(domain, type, protocol));
f9821aff
Z		 386# else
387 DO_ONEOPEN_THEN_CLOEXEC(PerlSock_socket(domain, type, protocol));
388# endif
389}
390
391int
392Perl_PerlSock_accept_cloexec(pTHX_ int listenfd, struct sockaddr *addr,
393 Sock_size_t *addrlen)
394{
395# if !defined(PERL_IMPLICIT_SYS) && \
1604cfb0 396 defined(HAS_ACCEPT4) && defined(SOCK_CLOEXEC)
f9821aff
Z		 397 /*
398 * struct IPerlSock doesn't cover accept4(), and there's no clear
399 * way to extend it, so for the time being this just isn't available
400 * on PERL_IMPLICIT_SYS builds.
401 */
402 DO_ONEOPEN_EXPERIMENTING_CLOEXEC(
999d65ed 403 PL_strategy_accept,
1604cfb0
MS		 404 accept4(listenfd, addr, addrlen, SOCK_CLOEXEC),
405 PerlSock_accept(listenfd, addr, addrlen));
f9821aff
Z		 406# else
407 DO_ONEOPEN_THEN_CLOEXEC(PerlSock_accept(listenfd, addr, addrlen));
408# endif
409}
410
411#endif
412
413#if defined (HAS_SOCKETPAIR) || \
414 (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && \
1604cfb0 415 defined(AF_INET) && defined(PF_INET))
f9821aff
Z		 416int
417Perl_PerlSock_socketpair_cloexec(pTHX_ int domain, int type, int protocol,
418 int *pairfd)
419{
420 PERL_ARGS_ASSERT_PERLSOCK_SOCKETPAIR_CLOEXEC;
421# ifdef SOCK_CLOEXEC
999d65ed 422 DO_PIPEOPEN_EXPERIMENTING_CLOEXEC(PL_strategy_socketpair, pairfd,
1604cfb0
MS		 423 PerlSock_socketpair(domain, type | SOCK_CLOEXEC, protocol, pairfd),
424 PerlSock_socketpair(domain, type, protocol, pairfd));
f9821aff
Z		 425# else
426 DO_PIPEOPEN_THEN_CLOEXEC(pairfd,
1604cfb0 427 PerlSock_socketpair(domain, type, protocol, pairfd));
f9821aff
Z		 428# endif
429}
430#endif
431
a2b41d5c
NC		 432static IO *
433S_openn_setup(pTHX_ GV *gv, char *mode, PerlIO **saveifp, PerlIO **saveofp,
434 int *savefd, char *savetype)
a567e93b 435{
eb578fdb 436 IO * const io = GvIOn(gv);
a687059c 437
a2b41d5c
NC		 438 PERL_ARGS_ASSERT_OPENN_SETUP;
439
440 *saveifp = NULL;
441 *saveofp = NULL;
442 *savefd = -1;
443 *savetype = IoTYPE_CLOSED;
7918f24d 444
b931b1d9 445 Zero(mode,sizeof(mode),char);
3280af22 446 PL_forkprocess = 1; /* assume true if no fork */
c07a80fd 447
b931b1d9 448 /* If currently open - close before we re-open */
a0d0e21e 449 if (IoIFP(io)) {
1604cfb0
MS		 450 if (IoTYPE(io) == IoTYPE_STD) {
451 /* This is a clone of one of STD* handles */
452 }
453 else {
26297fe9
NC		 454 const int old_fd = PerlIO_fileno(IoIFP(io));
455
25faa0d3 456 if (inRANGE(old_fd, 0, PL_maxsysfd)) {
26297fe9 457 /* This is one of the original STD* handles */
a2b41d5c
NC		 458 *saveifp = IoIFP(io);
459 *saveofp = IoOFP(io);
460 *savetype = IoTYPE(io);
461 *savefd = old_fd;
26297fe9
NC		 462 }
463 else {
464 int result;
465
466 if (IoTYPE(io) == IoTYPE_PIPE)
467 result = PerlProc_pclose(IoIFP(io));
468 else if (IoIFP(io) != IoOFP(io)) {
469 if (IoOFP(io)) {
470 result = PerlIO_close(IoOFP(io));
471 PerlIO_close(IoIFP(io)); /* clear stdio, fd already closed */
472 }
473 else
474 result = PerlIO_close(IoIFP(io));
475 }
476 else
477 result = PerlIO_close(IoIFP(io));
478
479 if (result == EOF && old_fd > PL_maxsysfd) {
480 /* Why is this not Perl_warn*() call ? */
481 PerlIO_printf(Perl_error_log,
147e3846
KW		 482 "Warning: unable to close filehandle %" HEKf
483 " properly.\n",
26297fe9
NC		 484 HEKfARG(GvENAME_HEK(gv))
485 );
486 }
487 }
488 }
1604cfb0 489 IoOFP(io) = IoIFP(io) = NULL;
a687059c 490 }
a2b41d5c
NC		 491 return io;
492}
493
494bool
495Perl_do_openn(pTHX_ GV *gv, const char *oname, I32 len, int as_raw,
1604cfb0
MS		 496 int rawmode, int rawperm, PerlIO *supplied_fp, SV **svp,
497 I32 num_svs)
a2b41d5c 498{
4b451737
NC		 499 PERL_ARGS_ASSERT_DO_OPENN;
500
501 if (as_raw) {
502 /* sysopen style args, i.e. integer mode and permissions */
503
1604cfb0
MS		 504 if (num_svs != 0) {
505 Perl_croak(aTHX_ "panic: sysopen with multiple args, num_svs=%ld",
506 (long) num_svs);
507 }
7e30e49f 508 return do_open_raw(gv, oname, len, rawmode, rawperm, NULL);
4b451737
NC		 509 }
510 return do_open6(gv, oname, len, supplied_fp, svp, num_svs);
511}
512
513bool
514Perl_do_open_raw(pTHX_ GV *gv, const char *oname, STRLEN len,
7e30e49f 515 int rawmode, int rawperm, Stat_t *statbufp)
4b451737 516{
a2b41d5c
NC		 517 PerlIO *saveifp;
518 PerlIO *saveofp;
519 int savefd;
520 char savetype;
521 char mode[PERL_MODE_MAX]; /* file mode ("r\0", "rb\0", "ab\0" etc.) */
522 IO * const io = openn_setup(gv, mode, &saveifp, &saveofp, &savefd, &savetype);
523 int writing = 0;
524 PerlIO *fp;
a2b41d5c 525
4b451737 526 PERL_ARGS_ASSERT_DO_OPEN_RAW;
c07a80fd 527
4b451737
NC		 528 /* For ease of blame back to 5.000, keep the existing indenting. */
529 {
b931b1d9 530 /* sysopen style args, i.e. integer mode and permissions */
1604cfb0
MS		 531 STRLEN ix = 0;
532 const int appendtrunc =
533 0
d1da7611 534#ifdef O_APPEND /* Not fully portable. */
1604cfb0 535 |O_APPEND
d1da7611
JH		 536#endif
537#ifdef O_TRUNC /* Not fully portable. */
1604cfb0 538 |O_TRUNC
d1da7611 539#endif
1604cfb0
MS		 540 ;
541 const int modifyingmode = O_WRONLY|O_RDWR|O_CREAT|appendtrunc;
542 int ismodifying;
9229bf8d 543 SV *namesv;
3dccc55c 544
1604cfb0 545 /* It's not always
3dccc55c 546
1604cfb0
MS		 547 O_RDONLY 0
548 O_WRONLY 1
549 O_RDWR 2
3dccc55c 550
1604cfb0 551 It might be (in OS/390 and Mac OS Classic it is)
3dccc55c 552
1604cfb0
MS		 553 O_WRONLY 1
554 O_RDONLY 2
555 O_RDWR 3
3dccc55c 556
1604cfb0
MS		 557 This means that simple & with O_RDWR would look
558 like O_RDONLY is present. Therefore we have to
559 be more careful.
560 */
561 if ((ismodifying = (rawmode & modifyingmode))) {
562 if ((ismodifying & O_WRONLY) == O_WRONLY ||
563 (ismodifying & O_RDWR) == O_RDWR ||
564 (ismodifying & (O_CREAT|appendtrunc)))
565 TAINT_PROPER("sysopen");
566 }
567 mode[ix++] = IoTYPE_NUMERIC; /* Marker to openn to use numeric "sysopen" */
b931b1d9 568
09458382 569#if defined(USE_64_BIT_RAWIO) && defined(O_LARGEFILE)
1604cfb0 570 rawmode |= O_LARGEFILE; /* Transparently largefiley. */
5ff3f7a4
GS		 571#endif
572
06c7082d 573 IoTYPE(io) = PerlIO_intmode2str(rawmode, &mode[ix], &writing);
ee518936 574
1604cfb0
MS		 575 namesv = newSVpvn_flags(oname, len, SVs_TEMP);
576 fp = PerlIO_openn(aTHX_ NULL, mode, -1, rawmode, rawperm, NULL, 1, &namesv);
a687059c 577 }
4b451737 578 return openn_cleanup(gv, io, fp, mode, oname, saveifp, saveofp, savefd,
7e30e49f 579 savetype, writing, 0, NULL, statbufp);
4b451737
NC		 580}
581
582bool
583Perl_do_open6(pTHX_ GV *gv, const char *oname, STRLEN len,
584 PerlIO *supplied_fp, SV **svp, U32 num_svs)
585{
4b451737
NC		 586 PerlIO *saveifp;
587 PerlIO *saveofp;
588 int savefd;
589 char savetype;
590 char mode[PERL_MODE_MAX]; /* file mode ("r\0", "rb\0", "ab\0" etc.) */
591 IO * const io = openn_setup(gv, mode, &saveifp, &saveofp, &savefd, &savetype);
592 int writing = 0;
593 PerlIO *fp;
594 bool was_fdopen = FALSE;
595 char *type = NULL;
596
597 PERL_ARGS_ASSERT_DO_OPEN6;
598
599 /* For ease of blame back to 5.000, keep the existing indenting. */
600 {
1604cfb0
MS		 601 /* Regular (non-sys) open */
602 char *name;
603 STRLEN olen = len;
604 char *tend;
605 int dodup = 0;
c564b489
NC		 606 bool in_raw = 0, in_crlf = 0, out_raw = 0, out_crlf = 0;
607
608 /* Collect default raw/crlf info from the op */
609 if (PL_op && PL_op->op_type == OP_OPEN) {
610 /* set up IO layers */
611 const U8 flags = PL_op->op_private;
612 in_raw = (flags & OPpOPEN_IN_RAW);
613 in_crlf = (flags & OPpOPEN_IN_CRLF);
614 out_raw = (flags & OPpOPEN_OUT_RAW);
615 out_crlf = (flags & OPpOPEN_OUT_CRLF);
616 }
c07a80fd 617
1604cfb0
MS		 618 type = savepvn(oname, len);
619 tend = type+len;
620 SAVEFREEPV(type);
eb649f83
AMS		 621
622 /* Lose leading and trailing white space */
1604cfb0
MS		 623 while (isSPACE(*type))
624 type++;
eb649f83 625 while (tend > type && isSPACE(tend[-1]))
1604cfb0 626 *--tend = '\0';
eb649f83 627
1604cfb0 628 if (num_svs) {
41188aa0
TC		 629 const char *p;
630 STRLEN nlen = 0;
1604cfb0 631 /* New style explicit name, type is just mode and layer info */
9a869a14 632#ifdef USE_STDIO
1604cfb0
MS		 633 if (SvROK(*svp) && !memchr(oname, '&', len)) {
634 if (ckWARN(WARN_IO))
635 Perl_warner(aTHX_ packWARN(WARN_IO),
636 "Can't open a reference");
637 SETERRNO(EINVAL, LIB_INVARG);
a6fc70e5 638 fp = NULL;
1604cfb0
MS		 639 goto say_false;
640 }
9a869a14 641#endif /* USE_STDIO */
41188aa0
TC		 642 p = (SvOK(*svp) || SvGMAGICAL(*svp)) ? SvPV(*svp, nlen) : NULL;
643
a6fc70e5
NC		 644 if (p && !IS_SAFE_PATHNAME(p, nlen, "open")) {
645 fp = NULL;
c8028aa6 646 goto say_false;
a6fc70e5 647 }
c8028aa6 648
1604cfb0 649 name = p ? savepvn(p, nlen) : savepvs("");
41188aa0 650
1604cfb0
MS		 651 SAVEFREEPV(name);
652 }
653 else {
654 name = type;
655 len = tend-type;
656 }
657 IoTYPE(io) = *type;
658 if ((*type == IoTYPE_RDWR) && /* scary */
01a8ea99 659 (*(type+1) == IoTYPE_RDONLY || *(type+1) == IoTYPE_WRONLY) &&
1604cfb0
MS		 660 ((!num_svs || (tend > type+1 && tend[-1] != IoTYPE_PIPE)))) {
661 TAINT_PROPER("open");
662 mode[1] = *type++;
663 writing = 1;
664 }
665
666 if (*type == IoTYPE_PIPE) {
667 if (num_svs) {
668 if (type[1] != IoTYPE_STD) {
669 unknown_open_mode:
670 Perl_croak(aTHX_ "Unknown open() mode '%.*s'", (int)olen, oname);
671 }
672 type++;
673 }
674 do {
675 type++;
676 } while (isSPACE(*type));
677 if (!num_svs) {
678 name = type;
679 len = tend-type;
680 }
681 if (*name == '\0') {
682 /* command is missing 19990114 */
683 if (ckWARN(WARN_PIPE))
684 Perl_warner(aTHX_ packWARN(WARN_PIPE), "Missing command in piped open");
685 errno = EPIPE;
a6fc70e5 686 fp = NULL;
1604cfb0
MS		 687 goto say_false;
688 }
689 if (!(*name == '-' && name[1] == '\0') || num_svs)
690 TAINT_ENV();
691 TAINT_PROPER("piped open");
692 if (!num_svs && name[len-1] == '|') {
693 name[--len] = '\0' ;
694 if (ckWARN(WARN_PIPE))
695 Perl_warner(aTHX_ packWARN(WARN_PIPE), "Can't open bidirectional pipe");
696 }
697 mode[0] = 'w';
698 writing = 1;
0c19750d 699 if (out_raw)
1604cfb0 700 mode[1] = 'b';
0c19750d 701 else if (out_crlf)
1604cfb0
MS		 702 mode[1] = 't';
703 if (num_svs > 1) {
704 fp = PerlProc_popen_list(mode, num_svs, svp);
705 }
706 else {
707 fp = PerlProc_popen(name,mode);
708 }
709 if (num_svs) {
710 if (*type) {
711 if (PerlIO_apply_layers(aTHX_ fp, mode, type) != 0) {
a6fc70e5 712 fp = NULL;
1604cfb0
MS		 713 goto say_false;
714 }
715 }
716 }
717 } /* IoTYPE_PIPE */
718 else if (*type == IoTYPE_WRONLY) {
719 TAINT_PROPER("open");
720 type++;
721 if (*type == IoTYPE_WRONLY) {
722 /* Two IoTYPE_WRONLYs in a row make for an IoTYPE_APPEND. */
723 mode[0] = IoTYPE(io) = IoTYPE_APPEND;
724 type++;
725 }
726 else {
727 mode[0] = 'w';
728 }
729 writing = 1;
c07a80fd 730
0c19750d 731 if (out_raw)
1604cfb0 732 mode[1] = 'b';
0c19750d 733 else if (out_crlf)
1604cfb0
MS		 734 mode[1] = 't';
735 if (*type == '&') {
736 duplicity:
737 dodup = PERLIO_DUP_FD;
738 type++;
739 if (*type == '=') {
740 dodup = 0;
741 type++;
742 }
743 if (!num_svs && !*type && supplied_fp) {
744 /* "<+&" etc. is used by typemaps */
745 fp = supplied_fp;
746 }
747 else {
748 PerlIO *that_fp = NULL;
b4464d55 749 int wanted_fd;
22ff3130 750 UV uv;
1604cfb0
MS		 751 if (num_svs > 1) {
752 /* diag_listed_as: More than one argument to '%s' open */
753 Perl_croak(aTHX_ "More than one argument to '%c&' open",IoTYPE(io));
754 }
755 while (isSPACE(*type))
756 type++;
757 if (num_svs && (
758 SvIOK(*svp)
759 || (SvPOKp(*svp) && looks_like_number(*svp))
760 )) {
b4464d55 761 wanted_fd = SvUV(*svp);
1604cfb0
MS		 762 num_svs = 0;
763 }
764 else if (isDIGIT(*type)
22ff3130
HS		 765 && grok_atoUV(type, &uv, NULL)
766 && uv <= INT_MAX
767 ) {
768 wanted_fd = (int)uv;
1604cfb0
MS		 769 }
770 else {
771 const IO* thatio;
772 if (num_svs) {
773 thatio = sv_2io(*svp);
774 }
775 else {
776 GV * const thatgv = gv_fetchpvn_flags(type, tend - type,
777 0, SVt_PVIO);
778 thatio = GvIO(thatgv);
779 }
780 if (!thatio) {
6e21c824 781#ifdef EINVAL
1604cfb0 782 SETERRNO(EINVAL,SS_IVCHAN);
6e21c824 783#endif
a6fc70e5 784 fp = NULL;
1604cfb0
MS		 785 goto say_false;
786 }
787 if ((that_fp = IoIFP(thatio))) {
788 /* Flush stdio buffer before dup. --mjd
789 * Unfortunately SEEK_CURing 0 seems to
790 * be optimized away on most platforms;
791 * only Solaris and Linux seem to flush
792 * on that. --jhi */
793 /* On the other hand, do all platforms
794 * take gracefully to flushing a read-only
795 * filehandle? Perhaps we should do
796 * fsetpos(src)+fgetpos(dst)? --nik */
797 PerlIO_flush(that_fp);
798 wanted_fd = PerlIO_fileno(that_fp);
799 /* When dup()ing STDIN, STDOUT or STDERR
800 * explicitly set appropriate access mode */
801 if (that_fp == PerlIO_stdout()
802 || that_fp == PerlIO_stderr())
803 IoTYPE(io) = IoTYPE_WRONLY;
804 else if (that_fp == PerlIO_stdin())
0759c907 805 IoTYPE(io) = IoTYPE_RDONLY;
1604cfb0
MS		 806 /* When dup()ing a socket, say result is
807 * one as well */
808 else if (IoTYPE(thatio) == IoTYPE_SOCKET)
809 IoTYPE(io) = IoTYPE_SOCKET;
810 }
0c9375a5
TC		 811 else {
812 SETERRNO(EBADF, RMS_IFI);
813 fp = NULL;
814 goto say_false;
815 }
1604cfb0
MS		 816 }
817 if (!num_svs)
818 type = NULL;
819 if (that_fp) {
820 fp = PerlIO_fdupopen(aTHX_ that_fp, NULL, dodup);
821 }
822 else {
823 if (dodup)
884fc2d3 824 wanted_fd = PerlLIO_dup_cloexec(wanted_fd);
1604cfb0
MS		 825 else
826 was_fdopen = TRUE;
b4464d55
NC		 827 if (!(fp = PerlIO_openn(aTHX_ type,mode,wanted_fd,0,0,NULL,num_svs,svp))) {
828 if (dodup && wanted_fd >= 0)
829 PerlLIO_close(wanted_fd);
1604cfb0
MS		 830 }
831 }
832 }
833 } /* & */
834 else {
835 while (isSPACE(*type))
836 type++;
837 if (*type == IoTYPE_STD && (!type[1] || isSPACE(type[1]) || type[1] == ':')) {
838 type++;
839 fp = PerlIO_stdout();
840 IoTYPE(io) = IoTYPE_STD;
841 if (num_svs > 1) {
842 /* diag_listed_as: More than one argument to '%s' open */
843 Perl_croak(aTHX_ "More than one argument to '>%c' open",IoTYPE_STD);
844 }
845 }
846 else {
847 if (num_svs) {
9229bf8d
NC		 848 fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,num_svs,svp);
849 }
850 else {
851 SV *namesv = newSVpvn_flags(type, tend - type, SVs_TEMP);
1604cfb0 852 type = NULL;
9229bf8d 853 fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,1,&namesv);
1604cfb0
MS		 854 }
855 }
856 } /* !& */
857 if (!fp && type && *type && *type != ':' && !isIDFIRST(*type))
858 goto unknown_open_mode;
859 } /* IoTYPE_WRONLY */
860 else if (*type == IoTYPE_RDONLY) {
861 do {
862 type++;
863 } while (isSPACE(*type));
864 mode[0] = 'r';
0c19750d 865 if (in_raw)
1604cfb0 866 mode[1] = 'b';
0c19750d 867 else if (in_crlf)
1604cfb0
MS		 868 mode[1] = 't';
869 if (*type == '&') {
870 goto duplicity;
871 }
872 if (*type == IoTYPE_STD && (!type[1] || isSPACE(type[1]) || type[1] == ':')) {
873 type++;
874 fp = PerlIO_stdin();
875 IoTYPE(io) = IoTYPE_STD;
876 if (num_svs > 1) {
877 /* diag_listed_as: More than one argument to '%s' open */
878 Perl_croak(aTHX_ "More than one argument to '<%c' open",IoTYPE_STD);
879 }
880 }
881 else {
882 if (num_svs) {
9229bf8d
NC		 883 fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,num_svs,svp);
884 }
885 else {
886 SV *namesv = newSVpvn_flags(type, tend - type, SVs_TEMP);
1604cfb0 887 type = NULL;
9229bf8d 888 fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,1,&namesv);
1604cfb0
MS		 889 }
890 }
891 if (!fp && type && *type && *type != ':' && !isIDFIRST(*type))
892 goto unknown_open_mode;
893 } /* IoTYPE_RDONLY */
894 else if ((num_svs && /* '-|...' or '...|' */
895 type[0] == IoTYPE_STD && type[1] == IoTYPE_PIPE) ||
896 (!num_svs && tend > type+1 && tend[-1] == IoTYPE_PIPE)) {
897 if (num_svs) {
898 type += 2; /* skip over '-|' */
899 }
900 else {
901 *--tend = '\0';
902 while (tend > type && isSPACE(tend[-1]))
903 *--tend = '\0';
904 for (; isSPACE(*type); type++)
905 ;
906 name = type;
907 len = tend-type;
908 }
909 if (*name == '\0') {
910 /* command is missing 19990114 */
911 if (ckWARN(WARN_PIPE))
912 Perl_warner(aTHX_ packWARN(WARN_PIPE), "Missing command in piped open");
913 errno = EPIPE;
a6fc70e5 914 fp = NULL;
1604cfb0
MS		 915 goto say_false;
916 }
917 if (!(*name == '-' && name[1] == '\0') || num_svs)
918 TAINT_ENV();
919 TAINT_PROPER("piped open");
920 mode[0] = 'r';
0c19750d 921
0c19750d 922 if (in_raw)
1604cfb0 923 mode[1] = 'b';
0c19750d 924 else if (in_crlf)
1604cfb0
MS		 925 mode[1] = 't';
926
927 if (num_svs > 1) {
928 fp = PerlProc_popen_list(mode,num_svs,svp);
929 }
930 else {
931 fp = PerlProc_popen(name,mode);
932 }
933 IoTYPE(io) = IoTYPE_PIPE;
934 if (num_svs) {
935 while (isSPACE(*type))
936 type++;
937 if (*type) {
938 if (PerlIO_apply_layers(aTHX_ fp, mode, type) != 0) {
a6fc70e5 939 fp = NULL;
1604cfb0
MS		 940 goto say_false;
941 }
942 }
943 }
944 }
945 else { /* layer(Args) */
946 if (num_svs)
947 goto unknown_open_mode;
948 name = type;
949 IoTYPE(io) = IoTYPE_RDONLY;
950 for (; isSPACE(*name); name++)
951 ;
952 mode[0] = 'r';
0c19750d 953
0c19750d 954 if (in_raw)
1604cfb0 955 mode[1] = 'b';
0c19750d 956 else if (in_crlf)
1604cfb0
MS		 957 mode[1] = 't';
958
959 if (*name == '-' && name[1] == '\0') {
960 fp = PerlIO_stdin();
961 IoTYPE(io) = IoTYPE_STD;
962 }
963 else {
964 if (num_svs) {
9229bf8d
NC		 965 fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,num_svs,svp);
966 }
967 else {
1604cfb0
MS		 968 SV *namesv = newSVpvn_flags(type, tend - type, SVs_TEMP);
969 type = NULL;
9229bf8d 970 fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,1,&namesv);
1604cfb0
MS		 971 }
972 }
973 }
a687059c 974 }
a6fc70e5
NC		 975
976 say_false:
977 return openn_cleanup(gv, io, fp, mode, oname, saveifp, saveofp, savefd,
7e30e49f 978 savetype, writing, was_fdopen, type, NULL);
a6fc70e5
NC		 979}
980
981/* Yes, this is ugly, but it's private, and I don't see a cleaner way to
982 simplify the two-headed public interface of do_openn. */
983static bool
984S_openn_cleanup(pTHX_ GV *gv, IO *io, PerlIO *fp, char *mode, const char *oname,
985 PerlIO *saveifp, PerlIO *saveofp, int savefd, char savetype,
7e30e49f 986 int writing, bool was_fdopen, const char *type, Stat_t *statbufp)
a6fc70e5
NC		 987{
988 int fd;
7e30e49f 989 Stat_t statbuf;
a6fc70e5
NC		 990
991 PERL_ARGS_ASSERT_OPENN_CLEANUP;
992
b1234259
JH		 993 Zero(&statbuf, 1, Stat_t);
994
bee1dbe2 995 if (!fp) {
1604cfb0
MS		 996 if (IoTYPE(io) == IoTYPE_RDONLY && ckWARN(WARN_NEWLINE)
997 && should_warn_nl(oname)
998
999 )
5d37acd6 1000 {
7347ee54 1001 GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral); /* PL_warn_nl is constant */
1604cfb0 1002 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
7347ee54 1003 GCC_DIAG_RESTORE_STMT;
5d37acd6 1004 }
1604cfb0 1005 goto say_false;
bee1dbe2 1006 }
a00b5bd3
NIS		 1007
1008 if (ckWARN(WARN_IO)) {
1604cfb0
MS		 1009 if ((IoTYPE(io) == IoTYPE_RDONLY) &&
1010 (fp == PerlIO_stdout() || fp == PerlIO_stderr())) {
1011 Perl_warner(aTHX_ packWARN(WARN_IO),
1012 "Filehandle STD%s reopened as %" HEKf
1013 " only for input",
1014 ((fp == PerlIO_stdout()) ? "OUT" : "ERR"),
1015 HEKfARG(GvENAME_HEK(gv)));
1016 }
1017 else if ((IoTYPE(io) == IoTYPE_WRONLY) && fp == PerlIO_stdin()) {
1018 Perl_warner(aTHX_ packWARN(WARN_IO),
1019 "Filehandle STDIN reopened as %" HEKf " only for output",
1020 HEKfARG(GvENAME_HEK(gv))
1021 );
1022 }
a00b5bd3
NIS		 1023 }
1024
e99cca91 1025 fd = PerlIO_fileno(fp);
375ed12a
JH		 1026 /* Do NOT do: "if (fd < 0) goto say_false;" here. If there is no
1027 * fd assume it isn't a socket - this covers PerlIO::scalar -
1028 * otherwise unless we "know" the type probe for socket-ness.
e99cca91
NIS		 1029 */
1030 if (IoTYPE(io) && IoTYPE(io) != IoTYPE_PIPE && IoTYPE(io) != IoTYPE_STD && fd >= 0) {
1604cfb0
MS		 1031 if (PerlLIO_fstat(fd,&statbuf) < 0) {
1032 /* If PerlIO claims to have fd we had better be able to fstat() it. */
1033 (void) PerlIO_close(fp);
1034 goto say_false;
1035 }
7114a2d2 1036#ifndef PERL_MICRO
1604cfb0
MS		 1037 if (S_ISSOCK(statbuf.st_mode))
1038 IoTYPE(io) = IoTYPE_SOCKET; /* in case a socket was passed in to us */
99b89507 1039#ifdef HAS_SOCKET
1604cfb0
MS		 1040 else if (
1041 !(statbuf.st_mode & S_IFMT)
1042 && IoTYPE(io) != IoTYPE_WRONLY /* Dups of STD* filehandles already have */
1043 && IoTYPE(io) != IoTYPE_RDONLY /* type so they aren't marked as sockets */
1044 ) { /* on OS's that return 0 on fstat()ed pipe */
1045 char tmpbuf[256];
1046 Sock_size_t buflen = sizeof tmpbuf;
1047 if (PerlSock_getsockname(fd, (struct sockaddr *)tmpbuf, &buflen) >= 0
1048 || errno != ENOTSOCK)
1049 IoTYPE(io) = IoTYPE_SOCKET; /* some OS's return 0 on fstat()ed socket */
1050 /* but some return 0 for streams too, sigh */
1051 }
e99cca91 1052#endif /* HAS_SOCKET */
7114a2d2 1053#endif /* !PERL_MICRO */
a687059c 1054 }
e99cca91
NIS		 1055
1056 /* Eeek - FIXME !!!
1057 * If this is a standard handle we discard all the layer stuff
1058 * and just dup the fd into whatever was on the handle before !
1059 */
1060
6e21c824 1061 if (saveifp) { /* must use old fp? */
f5b9d040 1062 /* If fd is less that PL_maxsysfd i.e. STDIN..STDERR
24c23ab4 1063 then dup the new fileno down
f5b9d040 1064 */
1604cfb0
MS		 1065 if (saveofp) {
1066 PerlIO_flush(saveofp); /* emulate PerlIO_close() */
1067 if (saveofp != saveifp) { /* was a socket? */
1068 PerlIO_close(saveofp);
1069 }
1070 }
1071 if (savefd != fd) {
1072 /* Still a small can-of-worms here if (say) PerlIO::scalar
1073 is assigned to (say) STDOUT - for now let dup2() fail
1074 and provide the error
1075 */
1076 if (fd < 0) {
375ed12a 1077 SETERRNO(EBADF,RMS_IFI);
1604cfb0 1078 goto say_false;
375ed12a 1079 } else if (PerlLIO_dup2(fd, savefd) < 0) {
1604cfb0
MS		 1080 (void)PerlIO_close(fp);
1081 goto say_false;
1082 }
d082dcd6 1083#ifdef VMS
1604cfb0 1084 if (savefd != PerlIO_fileno(PerlIO_stdin())) {
d0e2cf63
AMS		 1085 char newname[FILENAME_MAX+1];
1086 if (PerlIO_getname(fp, newname)) {
1087 if (fd == PerlIO_fileno(PerlIO_stdout()))
0db50132 1088 vmssetuserlnm("SYS$OUTPUT", newname);
d0e2cf63 1089 if (fd == PerlIO_fileno(PerlIO_stderr()))
0db50132 1090 vmssetuserlnm("SYS$ERROR", newname);
d0e2cf63 1091 }
1604cfb0 1092 }
d082dcd6 1093#endif
d0e2cf63
AMS		 1094
1095#if !defined(WIN32)
1096 /* PL_fdpid isn't used on Windows, so avoid this useless work.
1097 * XXX Probably the same for a lot of other places. */
1098 {
1099 Pid_t pid;
1100 SV *sv;
1101
d0e2cf63 1102 sv = *av_fetch(PL_fdpid,fd,TRUE);
862a34c6 1103 SvUPGRADE(sv, SVt_IV);
d0e2cf63 1104 pid = SvIVX(sv);
45977657 1105 SvIV_set(sv, 0);
d0e2cf63 1106 sv = *av_fetch(PL_fdpid,savefd,TRUE);
862a34c6 1107 SvUPGRADE(sv, SVt_IV);
45977657 1108 SvIV_set(sv, pid);
d0e2cf63
AMS		 1109 }
1110#endif
1111
1604cfb0 1112 if (was_fdopen) {
e212fc47
AMS		 1113 /* need to close fp without closing underlying fd */
1114 int ofd = PerlIO_fileno(fp);
884fc2d3 1115 int dupfd = ofd >= 0 ? PerlLIO_dup_cloexec(ofd) : -1;
375ed12a
JH		 1116 if (ofd < 0 || dupfd < 0) {
1117 if (dupfd >= 0)
1118 PerlLIO_close(dupfd);
1119 goto say_false;
1120 }
e212fc47 1121 PerlIO_close(fp);
884fc2d3
Z		 1122 PerlLIO_dup2_cloexec(dupfd, ofd);
1123 setfd_inhexec_for_sysfd(ofd);
e212fc47 1124 PerlLIO_close(dupfd);
1604cfb0 1125 }
e212fc47 1126 else
1604cfb0
MS		 1127 PerlIO_close(fp);
1128 }
1129 fp = saveifp;
1130 PerlIO_clearerr(fp);
1131 fd = PerlIO_fileno(fp);
6e21c824 1132 }
8990e307 1133 IoIFP(io) = fp;
b931b1d9 1134
684bef36 1135 IoFLAGS(io) &= ~IOf_NOLINE;
bf38876a 1136 if (writing) {
1604cfb0
MS		 1137 if (IoTYPE(io) == IoTYPE_SOCKET
1138 || (IoTYPE(io) == IoTYPE_WRONLY && fd >= 0 && S_ISCHR(statbuf.st_mode)) ) {
1139 char *s = mode;
1140 if (*s == IoTYPE_IMPLICIT || *s == IoTYPE_NUMERIC)
1141 s++;
1142 *s = 'w';
1143 if (!(IoOFP(io) = PerlIO_openn(aTHX_ type,s,fd,0,0,NULL,0,NULL))) {
1144 PerlIO_close(fp);
1145 goto say_false;
1146 }
1147 }
1148 else
1149 IoOFP(io) = fp;
bf38876a 1150 }
7e30e49f
DIM		 1151 if (statbufp)
1152 *statbufp = statbuf;
1153
a687059c 1154 return TRUE;
6e21c824 1155
7b52d656 1156 say_false:
8990e307
LW		 1157 IoIFP(io) = saveifp;
1158 IoOFP(io) = saveofp;
1159 IoTYPE(io) = savetype;
6e21c824 1160 return FALSE;
a687059c
LW		 1161}
1162
e0d4aead
TC		 1163/* Open a temp file in the same directory as an original name.
1164*/
1165
1166static bool
1167S_openindirtemp(pTHX_ GV *gv, SV *orig_name, SV *temp_out_name) {
1168 int fd;
1169 PerlIO *fp;
1170 const char *p = SvPV_nolen(orig_name);
1171 const char *sep;
1172
1173 /* look for the last directory separator */
1174 sep = strrchr(p, '/');
1175
1176#ifdef DOSISH
1177 {
1178 const char *sep2;
1179 if ((sep2 = strrchr(sep ? sep : p, '\\')))
1180 sep = sep2;
1181 }
1182#endif
1183#ifdef VMS
1184 if (!sep) {
1185 const char *openp = strchr(p, '[');
1186 if (openp)
1187 sep = strchr(openp, ']');
1188 else {
1189 sep = strchr(p, ':');
1190 }
1191 }
1192#endif
1193 if (sep) {
1194 sv_setpvn(temp_out_name, p, sep - p + 1);
1195 sv_catpvs(temp_out_name, "XXXXXXXX");
1196 }
1197 else
1198 sv_setpvs(temp_out_name, "XXXXXXXX");
1199
026633c6
JH		 1200 {
1201 int old_umask = umask(0177);
884fc2d3 1202 fd = Perl_my_mkstemp_cloexec(SvPVX(temp_out_name));
026633c6
JH		 1203 umask(old_umask);
1204 }
e0d4aead
TC		 1205
1206 if (fd < 0)
1207 return FALSE;
1208
1209 fp = PerlIO_fdopen(fd, "w+");
1210 if (!fp)
1211 return FALSE;
1212
1213 return do_openn(gv, "+>&", 3, 0, 0, 0, fp, NULL, 0);
1214}
1215
733612e0 1216#if defined(HAS_UNLINKAT) && defined(HAS_RENAMEAT) && defined(HAS_FCHMODAT) && \
c3fcee07
JK		 1217 (defined(HAS_DIRFD) || defined(HAS_DIR_DD_FD)) && !defined(NO_USE_ATFUNCTIONS) && \
1218 defined(HAS_LINKAT)
733612e0
TC		 1219# define ARGV_USE_ATFUNCTIONS
1220#endif
1221
1b4d0d79
TC		 1222/* Win32 doesn't necessarily return useful information
1223 * in st_dev, st_ino.
1224 */
184f90dc
TC		 1225#ifndef DOSISH
1226# define ARGV_USE_STAT_INO
1b4d0d79
TC		 1227#endif
1228
e0d4aead
TC		 1229#define ARGVMG_BACKUP_NAME 0
1230#define ARGVMG_TEMP_NAME 1
1231#define ARGVMG_ORIG_NAME 2
1232#define ARGVMG_ORIG_MODE 3
05df5c88 1233#define ARGVMG_ORIG_PID 4
bb082417 1234
bb082417
TC		 1235/* we store the entire stat_t since the ino_t and dev_t values might
1236 not fit in an IV. I could have created a new structure and
1237 transferred them across, but this seemed too much effort for very
1238 little win.
184f90dc
TC		 1239
1240 We store it even when the *at() functions are available, since
1241 while the C runtime might have definitions for these functions, the
1242 operating system or a specific filesystem might not implement them.
1243 eg. NetBSD 6 implements linkat() but only where the fds are AT_FDCWD.
bb082417 1244 */
184f90dc
TC		 1245#ifdef ARGV_USE_STAT_INO
1246# define ARGVMG_ORIG_CWD_STAT 5
1247#endif
1248
1249#ifdef ARGV_USE_ATFUNCTIONS
1250# define ARGVMG_ORIG_DIRP 6
1251#endif
1252
1253#ifdef ENOTSUP
1254#define NotSupported(e) ((e) == ENOSYS || (e) == ENOTSUP)
1255#else
1256#define NotSupported(e) ((e) == ENOSYS)
bb082417 1257#endif
e0d4aead
TC		 1258
1259static int
d0405818 1260S_argvout_free(pTHX_ SV *io, MAGIC *mg) {
d0405818 1261 PERL_UNUSED_ARG(io);
e0d4aead
TC		 1262
1263 /* note this can be entered once the file has been
1264 successfully deleted too */
d0405818
TC		 1265 assert(IoTYPE(io) != IoTYPE_PIPE);
1266
8ab93df0
TC		 1267 /* mg_obj can be NULL if a thread is created with the handle open, in which
1268 case we leave any clean up to the parent thread */
3d5e9c11 1269 if (mg->mg_obj) {
733612e0
TC		 1270#ifdef ARGV_USE_ATFUNCTIONS
1271 SV **dir_psv;
1272 DIR *dir;
3d5e9c11
TC		 1273
1274 dir_psv = av_fetch((AV*)mg->mg_obj, ARGVMG_ORIG_DIRP, FALSE);
1275 assert(dir_psv && *dir_psv && SvIOK(*dir_psv));
1276 dir = INT2PTR(DIR *, SvIV(*dir_psv));
733612e0 1277#endif
3d5e9c11 1278 if (IoIFP(io)) {
85d2f7ca
TC		 1279 if (PL_phase == PERL_PHASE_DESTRUCT && PL_statusvalue == 0) {
1280 (void)argvout_final(mg, (IO*)io, FALSE);
1281 }
1282 else {
1283 SV **pid_psv;
1284 PerlIO *iop = IoIFP(io);
05df5c88 1285
85d2f7ca 1286 assert(SvTYPE(mg->mg_obj) == SVt_PVAV);
05df5c88 1287
85d2f7ca 1288 pid_psv = av_fetch((AV*)mg->mg_obj, ARGVMG_ORIG_PID, FALSE);
05df5c88 1289
85d2f7ca 1290 assert(pid_psv && *pid_psv);
05df5c88 1291
85d2f7ca
TC		 1292 if (SvIV(*pid_psv) == (IV)PerlProc_getpid()) {
1293 /* if we get here the file hasn't been closed explicitly by the
1294 user and hadn't been closed implicitly by nextargv(), so
1295 abandon the edit */
1296 SV **temp_psv = av_fetch((AV*)mg->mg_obj, ARGVMG_TEMP_NAME, FALSE);
1297 const char *temp_pv = SvPVX(*temp_psv);
184f90dc 1298
85d2f7ca
TC		 1299 assert(temp_psv && *temp_psv && SvPOK(*temp_psv));
1300 (void)PerlIO_close(iop);
1301 IoIFP(io) = IoOFP(io) = NULL;
733612e0 1302#ifdef ARGV_USE_ATFUNCTIONS
85d2f7ca
TC		 1303 if (dir) {
1304 if (unlinkat(my_dirfd(dir), temp_pv, 0) < 0 &&
1305 NotSupported(errno))
1306 (void)UNLINK(temp_pv);
1307 }
733612e0 1308#else
85d2f7ca 1309 (void)UNLINK(temp_pv);
733612e0 1310#endif
85d2f7ca 1311 }
3d5e9c11 1312 }
05df5c88 1313 }
3d5e9c11
TC		 1314#ifdef ARGV_USE_ATFUNCTIONS
1315 if (dir)
1316 closedir(dir);
1317#endif
e0d4aead
TC		 1318 }
1319
1320 return 0;
1321}
1322
8ab93df0
TC		 1323static int
1324S_argvout_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param) {
1325 PERL_UNUSED_ARG(param);
1326
1327 /* ideally we could just remove the magic from the SV but we don't get the SV here */
1328 SvREFCNT_dec(mg->mg_obj);
1329 mg->mg_obj = NULL;
1330
1331 return 0;
1332}
1333
e0d4aead
TC		 1334/* Magic of this type has an AV containing the following:
1335 0: name of the backup file (if any)
1336 1: name of the temp output file
1337 2: name of the original file
1338 3: file mode of the original file
05df5c88
TC		 1339 4: pid of the process we opened at, to prevent doing the renaming
1340 etc in both the child and the parent after a fork
733612e0 1341
184f90dc
TC		 1342If we have useful inode/device ids in stat_t we also keep:
1343 5: a stat of the original current working directory
1344
733612e0 1345If we have unlinkat(), renameat(), fchmodat(), dirfd() we also keep:
184f90dc 1346 6: the DIR * for the current directory when we open the file, stored as an IV
e0d4aead
TC		 1347 */
1348
1349static const MGVTBL argvout_vtbl =
1350 {
1351 NULL, /* svt_get */
1352 NULL, /* svt_set */
1353 NULL, /* svt_len */
1354 NULL, /* svt_clear */
1355 S_argvout_free, /* svt_free */
1356 NULL, /* svt_copy */
8ab93df0
TC		 1357 S_argvout_dup, /* svt_dup */
1358 NULL /* svt_local */
e0d4aead
TC		 1359 };
1360
760ac839 1361PerlIO *
157fb5a1 1362Perl_nextargv(pTHX_ GV *gv, bool nomagicopen)
a687059c 1363{
2d03de9c 1364 IO * const io = GvIOp(gv);
502aca56 1365 SV *const old_out_name = PL_inplace ? newSVsv(GvSV(gv)) : NULL;
fe14fcc3 1366
7918f24d
NC		 1367 PERL_ARGS_ASSERT_NEXTARGV;
1368
502aca56
TC		 1369 if (old_out_name)
1370 SAVEFREESV(old_out_name);
1371
3280af22 1372 if (!PL_argvoutgv)
1604cfb0 1373 PL_argvoutgv = gv_fetchpvs("ARGVOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO);
5513c2cf 1374 if (io && (IoFLAGS(io) & (IOf_ARGV|IOf_START)) == (IOf_ARGV|IOf_START)) {
1604cfb0
MS		 1375 IoFLAGS(io) &= ~IOf_START;
1376 if (PL_inplace) {
1377 assert(PL_defoutgv);
1378 Perl_av_create_and_push(aTHX_ &PL_argvout_stack,
1379 SvREFCNT_inc_simple_NN(PL_defoutgv));
1380 }
18708f5a 1381 }
e0d4aead
TC		 1382
1383 {
1384 IO * const io = GvIOp(PL_argvoutgv);
1385 if (io && IoIFP(io) && old_out_name) {
1386 do_close(PL_argvoutgv, FALSE);
1387 }
fe14fcc3 1388 }
e0d4aead 1389
c797f2d8 1390 PL_lastfd = -1;
3280af22 1391 PL_filemode = 0;
5c501b37 1392 if (!GvAV(gv))
1604cfb0 1393 return NULL;
698ac381 1394 while (av_count(GvAV(gv)) > 0) {
1604cfb0 1395 STRLEN oldlen;
1fa0529f 1396 SV *const sv = av_shift(GvAV(gv));
1604cfb0
MS		 1397 SAVEFREESV(sv);
1398 SvTAINTED_off(GvSVn(gv)); /* previous tainting irrelevant */
1399 sv_setsv(GvSVn(gv),sv);
1400 SvSETMAGIC(GvSV(gv));
1401 PL_oldname = SvPVx(GvSV(gv), oldlen);
d8015975 1402 if (LIKELY(!PL_inplace)) {
157fb5a1
RGS		 1403 if (nomagicopen
1404 ? do_open6(gv, "<", 1, NULL, &GvSV(gv), 1)
1405 : do_open6(gv, PL_oldname, oldlen, NULL, NULL, 0)
1406 ) {
d8015975
NC		 1407 return IoIFP(GvIOp(gv));
1408 }
1409 }
1410 else {
7e30e49f 1411 Stat_t statbuf;
d8015975
NC		 1412 /* This very long block ends with return IoIFP(GvIOp(gv));
1413 Both this block and the block above fall through on open
1414 failure to the warning code, and then the while loop above tries
1415 the next entry. */
7e30e49f 1416 if (do_open_raw(gv, PL_oldname, oldlen, O_RDONLY, 0, &statbuf)) {
1fa0529f
NC		 1417#ifndef FLEXFILENAMES
1418 int filedev;
1419 int fileino;
1420#endif
733612e0
TC		 1421#ifdef ARGV_USE_ATFUNCTIONS
1422 DIR *curdir;
1423#endif
1fa0529f
NC		 1424 Uid_t fileuid;
1425 Gid_t filegid;
e0d4aead
TC		 1426 AV *magic_av = NULL;
1427 SV *temp_name_sv = NULL;
8ab93df0 1428 MAGIC *mg;
1fa0529f 1429
1604cfb0
MS		 1430 TAINT_PROPER("inplace open");
1431 if (oldlen == 1 && *PL_oldname == '-') {
1432 setdefout(gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL,
1433 SVt_PVIO));
1434 return IoIFP(GvIOp(gv));
1435 }
99b89507 1436#ifndef FLEXFILENAMES
1604cfb0
MS		 1437 filedev = statbuf.st_dev;
1438 fileino = statbuf.st_ino;
1439#endif
1440 PL_filemode = statbuf.st_mode;
1441 fileuid = statbuf.st_uid;
1442 filegid = statbuf.st_gid;
1443 if (!S_ISREG(PL_filemode)) {
1444 Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE),
1445 "Can't do inplace edit: %s is not a regular file",
1446 PL_oldname );
1447 do_close(gv,FALSE);
1448 continue;
1449 }
e0d4aead 1450 magic_av = newAV();
1604cfb0
MS		 1451 if (*PL_inplace && strNE(PL_inplace, "*")) {
1452 const char *star = strchr(PL_inplace, '*');
1453 if (star) {
1454 const char *begin = PL_inplace;
8062ff11 1455 SvPVCLEAR(sv);
1604cfb0
MS		 1456 do {
1457 sv_catpvn(sv, begin, star - begin);
1458 sv_catpvn(sv, PL_oldname, oldlen);
1459 begin = ++star;
1460 } while ((star = strchr(begin, '*')));
1461 if (*begin)
1462 sv_catpv(sv,begin);
1463 }
1464 else {
1465 sv_catpv(sv,PL_inplace);
1466 }
c623bd54 1467#ifndef FLEXFILENAMES
1604cfb0
MS		 1468 if ((PerlLIO_stat(SvPVX_const(sv),&statbuf) >= 0
1469 && statbuf.st_dev == filedev
1470 && statbuf.st_ino == fileino)
f248d071 1471 )
1604cfb0
MS		 1472 {
1473 Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE),
1474 "Can't do inplace edit: %"
147e3846 1475 SVf " would not be unique",
1604cfb0 1476 SVfARG(sv));
e0d4aead 1477 goto cleanup_argv;
1604cfb0 1478 }
ff8e2863 1479#endif
e0d4aead 1480 av_store(magic_av, ARGVMG_BACKUP_NAME, newSVsv(sv));
1604cfb0 1481 }
a687059c 1482
1604cfb0
MS		 1483 sv_setpvn(sv,PL_oldname,oldlen);
1484 SETERRNO(0,0); /* in case sprintf set errno */
e0d4aead
TC		 1485 temp_name_sv = newSV(0);
1486 if (!S_openindirtemp(aTHX_ PL_argvoutgv, GvSV(gv), temp_name_sv)) {
1487 SvREFCNT_dec(temp_name_sv);
1488 /* diag_listed_as: Can't do inplace edit on %s: %s */
1489 Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE), "Can't do inplace edit on %s: Cannot make temp name: %s",
1604cfb0 1490 PL_oldname, Strerror(errno) );
e0d4aead
TC		 1491#ifndef FLEXFILENAMES
1492 cleanup_argv:
1493#endif
1494 do_close(gv,FALSE);
1495 SvREFCNT_dec(magic_av);
1496 continue;
1604cfb0 1497 }
e0d4aead
TC		 1498 av_store(magic_av, ARGVMG_TEMP_NAME, temp_name_sv);
1499 av_store(magic_av, ARGVMG_ORIG_NAME, newSVsv(sv));
1500 av_store(magic_av, ARGVMG_ORIG_MODE, newSVuv(PL_filemode));
05df5c88 1501 av_store(magic_av, ARGVMG_ORIG_PID, newSViv((IV)PerlProc_getpid()));
1b4d0d79 1502#if defined(ARGV_USE_ATFUNCTIONS)
733612e0
TC		 1503 curdir = opendir(".");
1504 av_store(magic_av, ARGVMG_ORIG_DIRP, newSViv(PTR2IV(curdir)));
1b4d0d79 1505#elif defined(ARGV_USE_STAT_INO)
bb082417
TC		 1506 if (PerlLIO_stat(".", &statbuf) >= 0) {
1507 av_store(magic_av, ARGVMG_ORIG_CWD_STAT,
1508 newSVpvn((char *)&statbuf, sizeof(statbuf)));
1509 }
733612e0 1510#endif
1604cfb0 1511 setdefout(PL_argvoutgv);
dddabd86 1512 sv_setsv(GvSVn(PL_argvoutgv), temp_name_sv);
8ab93df0
TC		 1513 mg = sv_magicext((SV*)GvIOp(PL_argvoutgv), (SV*)magic_av, PERL_MAGIC_uvar, &argvout_vtbl, NULL, 0);
1514 mg->mg_flags |= MGf_DUP;
e0d4aead 1515 SvREFCNT_dec(magic_av);
1604cfb0 1516 PL_lastfd = PerlIO_fileno(IoIFP(GvIOp(PL_argvoutgv)));
375ed12a 1517 if (PL_lastfd >= 0) {
45a23732 1518 (void)PerlLIO_fstat(PL_lastfd,&statbuf);
fe14fcc3 1519#ifdef HAS_FCHMOD
375ed12a 1520 (void)fchmod(PL_lastfd,PL_filemode);
a687059c 1521#else
375ed12a 1522 (void)PerlLIO_chmod(PL_oldname,PL_filemode);
a687059c 1523#endif
45a23732 1524 if (fileuid != statbuf.st_uid || filegid != statbuf.st_gid) {
b469f1e0 1525 /* XXX silently ignore failures */
fe14fcc3 1526#ifdef HAS_FCHOWN
b469f1e0 1527 PERL_UNUSED_RESULT(fchown(PL_lastfd,fileuid,filegid));
4009c3ff 1528#elif defined(HAS_CHOWN)
b469f1e0 1529 PERL_UNUSED_RESULT(PerlLIO_chown(PL_oldname,fileuid,filegid));
a687059c 1530#endif
375ed12a 1531 }
1604cfb0 1532 }
d8015975 1533 return IoIFP(GvIOp(gv));
1604cfb0
MS		 1534 }
1535 } /* successful do_open_raw(), PL_inplace non-NULL */
d8015975
NC		 1536
1537 if (ckWARN_d(WARN_INPLACE)) {
1538 const int eno = errno;
7e30e49f 1539 Stat_t statbuf;
45a23732
DD		 1540 if (PerlLIO_stat(PL_oldname, &statbuf) >= 0
1541 && !S_ISREG(statbuf.st_mode)) {
d8015975
NC		 1542 Perl_warner(aTHX_ packWARN(WARN_INPLACE),
1543 "Can't do inplace edit: %s is not a regular file",
1544 PL_oldname);
1545 }
1546 else {
1547 Perl_warner(aTHX_ packWARN(WARN_INPLACE), "Can't open %s: %s",
1548 PL_oldname, Strerror(eno));
1549 }
1604cfb0 1550 }
a687059c 1551 }
18708f5a 1552 if (io && (IoFLAGS(io) & IOf_ARGV))
1604cfb0 1553 IoFLAGS(io) |= IOf_START;
3280af22 1554 if (PL_inplace) {
1604cfb0
MS		 1555 if (io && (IoFLAGS(io) & IOf_ARGV)
1556 && PL_argvout_stack && AvFILLp(PL_argvout_stack) >= 0)
1557 {
1558 GV * const oldout = MUTABLE_GV(av_pop(PL_argvout_stack));
1559 setdefout(oldout);
1560 SvREFCNT_dec_NN(oldout);
1561 return NULL;
1562 }
1563 setdefout(gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO));
a687059c 1564 }
4608196e 1565 return NULL;
a687059c
LW		 1566}
1567
84dbe61c 1568#ifdef ARGV_USE_ATFUNCTIONS
a3c63a94 1569# if defined(__FreeBSD__) || defined(__FreeBSD_kernel__)
84dbe61c
TC		 1570
1571/* FreeBSD 11 renameat() mis-behaves strangely with absolute paths in cases where the
1572 * equivalent rename() succeeds
1573 */
1574static int
1575S_my_renameat(int olddfd, const char *oldpath, int newdfd, const char *newpath) {
1576 /* this is intended only for use in Perl_do_close() */
1577 assert(olddfd == newdfd);
1578 assert(PERL_FILE_IS_ABSOLUTE(oldpath) == PERL_FILE_IS_ABSOLUTE(newpath));
1579 if (PERL_FILE_IS_ABSOLUTE(oldpath)) {
1580 return PerlLIO_rename(oldpath, newpath);
1581 }
1582 else {
1583 return renameat(olddfd, oldpath, newdfd, newpath);
1584 }
1585}
1586
1587# else
1588# define S_my_renameat(dh1, pv1, dh2, pv2) renameat((dh1), (pv1), (dh2), (pv2))
a3c63a94 1589# endif /* if defined(__FreeBSD__) || defined(__FreeBSD_kernel__) */
84dbe61c
TC		 1590#endif
1591
184f90dc 1592static bool
848643a9 1593S_dir_unchanged(pTHX_ const char *orig_pv, MAGIC *mg) {
184f90dc
TC		 1594 Stat_t statbuf;
1595
1596#ifdef ARGV_USE_STAT_INO
1597 SV **stat_psv = av_fetch((AV*)mg->mg_obj, ARGVMG_ORIG_CWD_STAT, FALSE);
1598 Stat_t *orig_cwd_stat = stat_psv && *stat_psv ? (Stat_t *)SvPVX(*stat_psv) : NULL;
1599
1600 /* if the path is absolute the possible moving of cwd (which the file
1601 might be in) isn't our problem.
1602 This code tries to be reasonably balanced about detecting a changed
1603 CWD, if we have the information needed to check that curdir has changed, we
1604 check it
1605 */
1606 if (!PERL_FILE_IS_ABSOLUTE(orig_pv)
1607 && orig_cwd_stat
1608 && PerlLIO_stat(".", &statbuf) >= 0
1609 && ( statbuf.st_dev != orig_cwd_stat->st_dev
1610 || statbuf.st_ino != orig_cwd_stat->st_ino)) {
1611 Perl_croak(aTHX_ "Cannot complete in-place edit of %s: %s",
1612 orig_pv, "Current directory has changed");
1613 }
1614#else
1615 SV **temp_psv = av_fetch((AV*)mg->mg_obj, ARGVMG_TEMP_NAME, FALSE);
1616
1617 /* Some platforms don't have useful st_ino etc, so just
1618 check we can see the work file.
1619 */
1620 if (!PERL_FILE_IS_ABSOLUTE(orig_pv)
1621 && PerlLIO_stat(SvPVX(*temp_psv), &statbuf) < 0) {
3c67ad9b 1622 Perl_croak(aTHX_ "Cannot complete in-place edit of %s: %s",
a06de4dc 1623 orig_pv,
184f90dc
TC		 1624 "Work file is missing - did you change directory?");
1625 }
1626#endif
1627
1628 return TRUE;
1629}
1630
848643a9
TC		 1631#define dir_unchanged(orig_psv, mg) \
1632 S_dir_unchanged(aTHX_ (orig_psv), (mg))
184f90dc 1633
404395d2 1634STATIC bool
d64b73b9 1635S_argvout_final(pTHX_ MAGIC *mg, IO *io, bool is_explict) {
1193dd27 1636 bool retval;
a687059c 1637
404395d2
TC		 1638 /* ensure args are checked before we start using them */
1639 PERL_ARGS_ASSERT_ARGVOUT_FINAL;
1640
1641 {
e0d4aead
TC		 1642 /* handle to an in-place edit work file */
1643 SV **back_psv = av_fetch((AV*)mg->mg_obj, ARGVMG_BACKUP_NAME, FALSE);
1644 SV **temp_psv = av_fetch((AV*)mg->mg_obj, ARGVMG_TEMP_NAME, FALSE);
1645 /* PL_oldname may have been modified by a nested ARGV use at this point */
1646 SV **orig_psv = av_fetch((AV*)mg->mg_obj, ARGVMG_ORIG_NAME, FALSE);
1647 SV **mode_psv = av_fetch((AV*)mg->mg_obj, ARGVMG_ORIG_MODE, FALSE);
05df5c88 1648 SV **pid_psv = av_fetch((AV*)mg->mg_obj, ARGVMG_ORIG_PID, FALSE);
1b4d0d79 1649#if defined(ARGV_USE_ATFUNCTIONS)
05df5c88 1650 SV **dir_psv = av_fetch((AV*)mg->mg_obj, ARGVMG_ORIG_DIRP, FALSE);
733612e0
TC		 1651 DIR *dir;
1652 int dfd;
1b4d0d79 1653#endif
e0d4aead
TC		 1654 UV mode;
1655 int fd;
1656
1657 const char *orig_pv;
1658
1659 assert(temp_psv && *temp_psv);
1660 assert(orig_psv && *orig_psv);
1661 assert(mode_psv && *mode_psv);
05df5c88 1662 assert(pid_psv && *pid_psv);
733612e0
TC		 1663#ifdef ARGV_USE_ATFUNCTIONS
1664 assert(dir_psv && *dir_psv);
1665 dir = INT2PTR(DIR *, SvIVX(*dir_psv));
1666 dfd = my_dirfd(dir);
1667#endif
e0d4aead
TC		 1668
1669 orig_pv = SvPVX(*orig_psv);
e0d4aead
TC		 1670 mode = SvUV(*mode_psv);
1671
1672 if ((mode & (S_ISUID|S_ISGID)) != 0
1673 && (fd = PerlIO_fileno(IoIFP(io))) >= 0) {
1674 (void)PerlIO_flush(IoIFP(io));
1675#ifdef HAS_FCHMOD
1676 (void)fchmod(fd, mode);
1677#else
1678 (void)PerlLIO_chmod(orig_pv, mode);
1679#endif
1680 }
1681
d64b73b9 1682 retval = io_close(io, NULL, is_explict, FALSE);
e0d4aead 1683
05df5c88
TC		 1684 if (SvIV(*pid_psv) != (IV)PerlProc_getpid()) {
1685 /* this is a child process, don't duplicate our rename() etc
1686 processing below */
1687 goto freext;
1688 }
1689
e0d4aead
TC		 1690 if (retval) {
1691#if defined(DOSISH) || defined(__CYGWIN__)
1692 if (PL_argvgv && GvIOp(PL_argvgv)
1693 && IoIFP(GvIOp(PL_argvgv))
1694 && (IoFLAGS(GvIOp(PL_argvgv)) & (IOf_ARGV|IOf_START)) == IOf_ARGV) {
1695 do_close(PL_argvgv, FALSE);
1696 }
1697#endif
184f90dc 1698#ifndef ARGV_USE_ATFUNCTIONS
848643a9 1699 if (!dir_unchanged(orig_pv, mg))
184f90dc
TC		 1700 goto abort_inplace;
1701#endif
e0d4aead
TC		 1702 if (back_psv && *back_psv) {
1703#if defined(HAS_LINK) && !defined(DOSISH) && !defined(__CYGWIN__) && defined(HAS_RENAME)
733612e0
TC		 1704 if (
1705# ifdef ARGV_USE_ATFUNCTIONS
184f90dc
TC		 1706 linkat(dfd, orig_pv, dfd, SvPVX(*back_psv), 0) < 0 &&
1707 !(UNLIKELY(NotSupported(errno)) &&
848643a9 1708 dir_unchanged(orig_pv, mg) &&
184f90dc 1709 link(orig_pv, SvPVX(*back_psv)) == 0)
733612e0
TC		 1710# else
1711 link(orig_pv, SvPVX(*back_psv)) < 0
1712# endif
1713 )
e0d4aead
TC		 1714#endif
1715 {
1716#ifdef HAS_RENAME
733612e0
TC		 1717 if (
1718# ifdef ARGV_USE_ATFUNCTIONS
184f90dc
TC		 1719 S_my_renameat(dfd, orig_pv, dfd, SvPVX(*back_psv)) < 0 &&
1720 !(UNLIKELY(NotSupported(errno)) &&
848643a9 1721 dir_unchanged(orig_pv, mg) &&
184f90dc 1722 PerlLIO_rename(orig_pv, SvPVX(*back_psv)) == 0)
733612e0
TC		 1723# else
1724 PerlLIO_rename(orig_pv, SvPVX(*back_psv)) < 0
1725# endif
1726 ) {
d64b73b9 1727 if (!is_explict) {
83419aa9 1728# ifdef ARGV_USE_ATFUNCTIONS
184f90dc
TC		 1729 if (unlinkat(dfd, SvPVX_const(*temp_psv), 0) < 0 &&
1730 UNLIKELY(NotSupported(errno)) &&
848643a9 1731 dir_unchanged(orig_pv, mg))
184f90dc 1732 (void)UNLINK(SvPVX_const(*temp_psv));
83419aa9
TC		 1733# else
1734 UNLINK(SvPVX(*temp_psv));
1735# endif
e0d4aead
TC		 1736 Perl_croak(aTHX_ "Can't rename %s to %s: %s, skipping file",
1737 SvPVX(*orig_psv), SvPVX(*back_psv), Strerror(errno));
1738 }
1739 /* should we warn here? */
1740 goto abort_inplace;
1741 }
1742#else
1743 (void)UNLINK(SvPVX(*back_psv));
1744 if (link(orig_pv, SvPVX(*back_psv))) {
d64b73b9 1745 if (!is_explict) {
e0d4aead
TC		 1746 Perl_croak(aTHX_ "Can't rename %s to %s: %s, skipping file",
1747 SvPVX(*orig_psv), SvPVX(*back_psv), Strerror(errno));
1748 }
1749 goto abort_inplace;
1750 }
1751 /* we need to use link() to get the temp into place too, and linK()
1752 fails if the new link name exists */
1753 (void)UNLINK(orig_pv);
1754#endif
1755 }
1756 }
1757#if defined(DOSISH) || defined(__CYGWIN__) || !defined(HAS_RENAME)
1758 else {
1759 UNLINK(orig_pv);
1760 }
1761#endif
1762 if (
4009c3ff
AC		 1763#if !defined(HAS_RENAME)
1764 link(SvPVX(*temp_psv), orig_pv) < 0
1765#elif defined(ARGV_USE_ATFUNCTIONS)
1604cfb0 1766 S_my_renameat(dfd, SvPVX(*temp_psv), dfd, orig_pv) < 0 &&
184f90dc 1767 !(UNLIKELY(NotSupported(errno)) &&
848643a9 1768 dir_unchanged(orig_pv, mg) &&
184f90dc 1769 PerlLIO_rename(SvPVX(*temp_psv), orig_pv) == 0)
e0d4aead 1770#else
4009c3ff 1771 PerlLIO_rename(SvPVX(*temp_psv), orig_pv) < 0
e0d4aead
TC		 1772#endif
1773 ) {
d64b73b9 1774 if (!is_explict) {
dddabd86 1775#ifdef ARGV_USE_ATFUNCTIONS
184f90dc
TC		 1776 if (unlinkat(dfd, SvPVX_const(*temp_psv), 0) < 0 &&
1777 NotSupported(errno))
1778 UNLINK(SvPVX(*temp_psv));
dddabd86
TC		 1779#else
1780 UNLINK(SvPVX(*temp_psv));
1781#endif
3c67ad9b
TC		 1782 /* diag_listed_as: Cannot complete in-place edit of %s: %s */
1783 Perl_croak(aTHX_ "Cannot complete in-place edit of %s: failed to rename work file '%s' to '%s': %s",
1784 orig_pv, SvPVX(*temp_psv), orig_pv, Strerror(errno));
e0d4aead
TC		 1785 }
1786 abort_inplace:
1787 UNLINK(SvPVX_const(*temp_psv));
1788 retval = FALSE;
1789 }
1790#ifndef HAS_RENAME
1791 UNLINK(SvPVX(*temp_psv));
1792#endif
1793 }
1794 else {
733612e0 1795#ifdef ARGV_USE_ATFUNCTIONS
184f90dc
TC		 1796 if (unlinkat(dfd, SvPVX_const(*temp_psv), 0) &&
1797 NotSupported(errno))
1798 UNLINK(SvPVX_const(*temp_psv));
1799
733612e0 1800#else
e0d4aead 1801 UNLINK(SvPVX_const(*temp_psv));
733612e0 1802#endif
d64b73b9 1803 if (!is_explict) {
e0d4aead
TC		 1804 Perl_croak(aTHX_ "Failed to close in-place work file %s: %s",
1805 SvPVX(*temp_psv), Strerror(errno));
1806 }
1807 }
404395d2
TC		 1808 freext:
1809 ;
1810 }
1811 return retval;
1812}
1813
74d55a0b
KW		 1814/*
1815=for apidoc do_close
1816
1817Close an I/O stream. This implements Perl L<perlfunc/C<close>>.
1818
1819C<gv> is the glob associated with the stream.
1820
1821C<is_explict> is C<true> if this is an explicit close of the stream; C<false>
1822if it is part of another operation, such as closing a pipe (which involves
1823implicitly closing both ends).
1824
1825Returns C<true> if successful; otherwise returns C<false> and sets C<errno> to
1826indicate the cause.
1827
1828=cut
1829*/
1830
404395d2 1831bool
d64b73b9 1832Perl_do_close(pTHX_ GV *gv, bool is_explict)
404395d2
TC		 1833{
1834 bool retval;
1835 IO *io;
1836 MAGIC *mg;
1837
1838 if (!gv)
1604cfb0 1839 gv = PL_argvgv;
404395d2 1840 if (!gv || !isGV_with_GP(gv)) {
d64b73b9 1841 if (is_explict)
1604cfb0
MS		 1842 SETERRNO(EBADF,SS_IVCHAN);
1843 return FALSE;
404395d2
TC		 1844 }
1845 io = GvIO(gv);
1846 if (!io) { /* never opened */
d64b73b9 1847 if (is_explict) {
1604cfb0
MS		 1848 report_evil_fh(gv);
1849 SETERRNO(EBADF,SS_IVCHAN);
1850 }
1851 return FALSE;
404395d2
TC		 1852 }
1853 if ((mg = mg_findext((SV*)io, PERL_MAGIC_uvar, &argvout_vtbl))
1854 && mg->mg_obj) {
d64b73b9 1855 retval = argvout_final(mg, io, is_explict);
e0d4aead
TC		 1856 mg_freeext((SV*)io, PERL_MAGIC_uvar, &argvout_vtbl);
1857 }
1858 else {
d64b73b9 1859 retval = io_close(io, NULL, is_explict, FALSE);
e0d4aead 1860 }
d64b73b9 1861 if (is_explict) {
1604cfb0
MS		 1862 IoLINES(io) = 0;
1863 IoPAGE(io) = 0;
1864 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1193dd27 1865 }
50952442 1866 IoTYPE(io) = IoTYPE_CLOSED;
1193dd27
IZ		 1867 return retval;
1868}
1869
1870bool
d64b73b9 1871Perl_io_close(pTHX_ IO *io, GV *gv, bool is_explict, bool warn_on_fail)
1193dd27
IZ		 1872{
1873 bool retval = FALSE;
1193dd27 1874
7918f24d
NC		 1875 PERL_ARGS_ASSERT_IO_CLOSE;
1876
8990e307 1877 if (IoIFP(io)) {
1604cfb0 1878 if (IoTYPE(io) == IoTYPE_PIPE) {
35608a16
TC		 1879 PerlIO *fh = IoIFP(io);
1880 int status;
1881
1882 /* my_pclose() can propagate signals which might bypass any code
1883 after the call here if the signal handler throws an exception.
1884 This would leave the handle in the IO object and try to close it again
1885 when the SV is destroyed on unwind or global destruction.
1886 So NULL it early.
1887 */
1888 IoOFP(io) = IoIFP(io) = NULL;
1604cfb0 1889 status = PerlProc_pclose(fh);
d64b73b9 1890 if (is_explict) {
1604cfb0
MS		 1891 STATUS_NATIVE_CHILD_SET(status);
1892 retval = (STATUS_UNIX == 0);
1893 }
1894 else {
1895 retval = (status != -1);
1896 }
1897 }
1898 else if (IoTYPE(io) == IoTYPE_STD)
1899 retval = TRUE;
1900 else {
1901 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) { /* a socket */
1902 const bool prev_err = PerlIO_error(IoOFP(io));
f4725fad 1903#ifdef USE_PERLIO
1604cfb0
MS		 1904 if (prev_err)
1905 PerlIO_restore_errno(IoOFP(io));
1906#endif
1907 retval = (PerlIO_close(IoOFP(io)) != EOF && !prev_err);
1908 PerlIO_close(IoIFP(io)); /* clear stdio, fd already closed */
1909 }
1910 else {
1911 const bool prev_err = PerlIO_error(IoIFP(io));
f4725fad 1912#ifdef USE_PERLIO
1604cfb0
MS		 1913 if (prev_err)
1914 PerlIO_restore_errno(IoIFP(io));
1915#endif
1916 retval = (PerlIO_close(IoIFP(io)) != EOF && !prev_err);
1917 }
1918 }
1919 IoOFP(io) = IoIFP(io) = NULL;
1920
1921 if (warn_on_fail && !retval) {
1922 if (gv)
1923 Perl_ck_warner_d(aTHX_ packWARN(WARN_IO),
1924 "Warning: unable to close filehandle %"
1925 HEKf " properly: %" SVf,
1926 HEKfARG(GvNAME_HEK(gv)),
ac892e4a 1927 SVfARG(get_sv("!",GV_ADD)));
1604cfb0
MS		 1928 else
1929 Perl_ck_warner_d(aTHX_ packWARN(WARN_IO),
1930 "Warning: unable to close filehandle "
1931 "properly: %" SVf,
1932 SVfARG(get_sv("!",GV_ADD)));
1933 }
79072805 1934 }
d64b73b9 1935 else if (is_explict) {
1604cfb0 1936 SETERRNO(EBADF,SS_IVCHAN);
20408e3c 1937 }
1193dd27 1938
a687059c
LW		 1939 return retval;
1940}
1941
1942bool
864dbfa3 1943Perl_do_eof(pTHX_ GV *gv)
a687059c 1944{
eb578fdb 1945 IO * const io = GvIO(gv);
a687059c 1946
7918f24d
NC		 1947 PERL_ARGS_ASSERT_DO_EOF;
1948
79072805 1949 if (!io)
1604cfb0 1950 return TRUE;
7716c5c5 1951 else if (IoTYPE(io) == IoTYPE_WRONLY)
1604cfb0 1952 report_wrongway_fh(gv, '>');
a687059c 1953
8990e307 1954 while (IoIFP(io)) {
760ac839 1955 if (PerlIO_has_cntptr(IoIFP(io))) { /* (the code works without this) */
1604cfb0
MS		 1956 if (PerlIO_get_cnt(IoIFP(io)) > 0) /* cheat a little, since */
1957 return FALSE; /* this is the most usual case */
1958 }
1959
1960 {
1961 /* getc and ungetc can stomp on errno */
1962 dSAVE_ERRNO;
1963 const int ch = PerlIO_getc(IoIFP(io));
1964 if (ch != EOF) {
1965 (void)PerlIO_ungetc(IoIFP(io),ch);
1966 RESTORE_ERRNO;
1967 return FALSE;
1968 }
1969 RESTORE_ERRNO;
1970 }
fab3f3a7 1971
760ac839 1972 if (PerlIO_has_cntptr(IoIFP(io)) && PerlIO_canset_cnt(IoIFP(io))) {
1604cfb0
MS		 1973 if (PerlIO_get_cnt(IoIFP(io)) < -1)
1974 PerlIO_set_cnt(IoIFP(io),-1);
1975 }
1976 if (PL_op->op_flags & OPf_SPECIAL) { /* not necessarily a real EOF yet? */
1977 if (gv != PL_argvgv || !nextargv(gv, FALSE)) /* get another fp handy */
1978 return TRUE;
1979 }
1980 else
1981 return TRUE; /* normal fp, definitely end of file */
a687059c
LW		 1982 }
1983 return TRUE;
1984}
1985
5ff3f7a4 1986Off_t
864dbfa3 1987Perl_do_tell(pTHX_ GV *gv)
a687059c 1988{
9c9f25b8 1989 IO *const io = GvIO(gv);
eb578fdb 1990 PerlIO *fp;
a687059c 1991
7918f24d
NC		 1992 PERL_ARGS_ASSERT_DO_TELL;
1993
9c9f25b8 1994 if (io && (fp = IoIFP(io))) {
1604cfb0 1995 return PerlIO_tell(fp);
96e4d5b1 1996 }
51087808 1997 report_evil_fh(gv);
93189314 1998 SETERRNO(EBADF,RMS_IFI);
5ff3f7a4 1999 return (Off_t)-1;
a687059c
LW		 2000}
2001
2002bool
864dbfa3 2003Perl_do_seek(pTHX_ GV *gv, Off_t pos, int whence)
a687059c 2004{
9c9f25b8 2005 IO *const io = GvIO(gv);
eb578fdb 2006 PerlIO *fp;
a687059c 2007
9c9f25b8 2008 if (io && (fp = IoIFP(io))) {
1604cfb0 2009 return PerlIO_seek(fp, pos, whence) >= 0;
137443ea 2010 }
51087808 2011 report_evil_fh(gv);
93189314 2012 SETERRNO(EBADF,RMS_IFI);
a687059c
LW		 2013 return FALSE;
2014}
2015
97cc44eb 2016Off_t
864dbfa3 2017Perl_do_sysseek(pTHX_ GV *gv, Off_t pos, int whence)
8903cb82 2018{
9c9f25b8 2019 IO *const io = GvIO(gv);
eb578fdb 2020 PerlIO *fp;
8903cb82 2021
7918f24d
NC		 2022 PERL_ARGS_ASSERT_DO_SYSSEEK;
2023
375ed12a
JH		 2024 if (io && (fp = IoIFP(io))) {
2025 int fd = PerlIO_fileno(fp);
07bd88da
JH		 2026 if (fd < 0 || (whence == SEEK_SET && pos < 0)) {
2027 SETERRNO(EINVAL,LIB_INVARG);
2028 return -1;
2029 } else {
375ed12a
JH		 2030 return PerlLIO_lseek(fd, pos, whence);
2031 }
2032 }
51087808 2033 report_evil_fh(gv);
93189314 2034 SETERRNO(EBADF,RMS_IFI);
d9b3e12d 2035 return (Off_t)-1;
8903cb82 2036}
2037
6ff81951 2038int
a79b25b7 2039Perl_mode_from_discipline(pTHX_ const char *s, STRLEN len)
16fe6d59
GS		 2040{
2041 int mode = O_BINARY;
81611534 2042 PERL_UNUSED_CONTEXT;
a79b25b7 2043 if (s) {
1604cfb0
MS		 2044 while (*s) {
2045 if (*s == ':') {
2046 switch (s[1]) {
2047 case 'r':
2048 if (s[2] == 'a' && s[3] == 'w'
2049 && (!s[4] || s[4] == ':' || isSPACE(s[4])))
2050 {
2051 mode = O_BINARY;
2052 s += 4;
2053 len -= 4;
2054 break;
2055 }
2056 /* FALLTHROUGH */
2057 case 'c':
2058 if (s[2] == 'r' && s[3] == 'l' && s[4] == 'f'
2059 && (!s[5] || s[5] == ':' || isSPACE(s[5])))
2060 {
2061 mode = O_TEXT;
2062 s += 5;
2063 len -= 5;
2064 break;
2065 }
2066 /* FALLTHROUGH */
2067 default:
2068 goto fail_discipline;
2069 }
2070 }
2071 else if (isSPACE(*s)) {
2072 ++s;
2073 --len;
2074 }
2075 else {
2076 const char *end;
7b52d656 2077 fail_discipline:
1604cfb0
MS		 2078 end = (char *) memchr(s+1, ':', len);
2079 if (!end)
2080 end = s+len;
60382766 2081#ifndef PERLIO_LAYERS
1604cfb0 2082 Perl_croak(aTHX_ "IO layers (like '%.*s') unavailable", end-s, s);
60382766 2083#else
1604cfb0
MS		 2084 len -= end-s;
2085 s = end;
60382766 2086#endif
1604cfb0
MS		 2087 }
2088 }
16fe6d59
GS		 2089 }
2090 return mode;
2091}
2092
02cb4161
KW		 2093/*
2094=for apidoc my_chsize
2095
2096The C library L<chsize(3)> if available, or a Perl implementation of it.
2097
2098=cut
2099*/
2100
58e24eff 2101#if !defined(HAS_TRUNCATE) && !defined(HAS_CHSIZE)
27da23d5
JH		 2102I32
2103my_chsize(int fd, Off_t length)
6eb13c3b 2104{
04b7ea23 2105# ifdef F_FREESP
1604cfb0 2106 /* code courtesy of William Kucharski */
04b7ea23 2107# define HAS_CHSIZE
58e24eff 2108
c623ac67 2109 Stat_t filebuf;
6eb13c3b 2110
3028581b 2111 if (PerlLIO_fstat(fd, &filebuf) < 0)
1604cfb0 2112 return -1;
6eb13c3b
LW		 2113
2114 if (filebuf.st_size < length) {
2115
1604cfb0 2116 /* extend file length */
6eb13c3b 2117
1604cfb0
MS		 2118 if ((PerlLIO_lseek(fd, (length - 1), 0)) < 0)
2119 return -1;
6eb13c3b 2120
1604cfb0 2121 /* write a "0" byte */
6eb13c3b 2122
1604cfb0
MS		 2123 if ((PerlLIO_write(fd, "", 1)) != 1)
2124 return -1;
6eb13c3b
LW		 2125 }
2126 else {
1604cfb0
MS		 2127 /* truncate length */
2128 struct flock fl;
2129 fl.l_whence = 0;
2130 fl.l_len = 0;
2131 fl.l_start = length;
2132 fl.l_type = F_WRLCK; /* write lock on file space */
2133
2134 /*
2135 * This relies on the UNDOCUMENTED F_FREESP argument to
2136 * fcntl(2), which truncates the file so that it ends at the
2137 * position indicated by fl.l_start.
2138 *
2139 * Will minor miracles never cease?
2140 */
6eb13c3b 2141
1604cfb0
MS		 2142 if (fcntl(fd, F_FREESP, &fl) < 0)
2143 return -1;
6eb13c3b
LW		 2144
2145 }
6eb13c3b 2146 return 0;
04b7ea23 2147# else
27da23d5 2148 Perl_croak_nocontext("truncate not implemented");
04b7ea23 2149# endif /* F_FREESP */
27da23d5 2150 return -1;
58e24eff
SH		 2151}
2152#endif /* !HAS_TRUNCATE && !HAS_CHSIZE */
ff8e2863 2153
a687059c 2154bool
5aaab254 2155Perl_do_print(pTHX_ SV *sv, PerlIO *fp)
a687059c 2156{
7918f24d
NC		 2157 PERL_ARGS_ASSERT_DO_PRINT;
2158
79072805
LW		 2159 /* assuming fp is checked earlier */
2160 if (!sv)
1604cfb0 2161 return TRUE;
e9950d3b 2162 if (SvTYPE(sv) == SVt_IV && SvIOK(sv)) {
1604cfb0
MS		 2163 assert(!SvGMAGICAL(sv));
2164 if (SvIsUV(sv))
2165 PerlIO_printf(fp, "%" UVuf, (UV)SvUVX(sv));
2166 else
2167 PerlIO_printf(fp, "%" IVdf, (IV)SvIVX(sv));
2168 return !PerlIO_error(fp);
e9950d3b
NC		 2169 }
2170 else {
1604cfb0
MS		 2171 STRLEN len;
2172 /* Do this first to trigger any overloading. */
2173 const char *tmps = SvPV_const(sv, len);
2174 U8 *tmpbuf = NULL;
2175 bool happy = TRUE;
2176
2177 if (PerlIO_isutf8(fp)) { /* If the stream is utf8 ... */
2178 if (!SvUTF8(sv)) { /* Convert to utf8 if necessary */
2179 /* We don't modify the original scalar. */
2180 tmpbuf = bytes_to_utf8((const U8*) tmps, &len);
2181 tmps = (char *) tmpbuf;
2182 }
2183 else if (ckWARN4_d(WARN_UTF8, WARN_SURROGATE, WARN_NON_UNICODE, WARN_NONCHAR)) {
2184 (void) check_utf8_print((const U8*) tmps, len);
2185 }
2186 } /* else stream isn't utf8 */
2187 else if (DO_UTF8(sv)) { /* But if is utf8 internally, attempt to
2188 convert to bytes */
2189 STRLEN tmplen = len;
2190 bool utf8 = TRUE;
2191 U8 * const result = bytes_from_utf8((const U8*) tmps, &tmplen, &utf8);
2192 if (!utf8) {
2193
2194 /* Here, succeeded in downgrading from utf8. Set up to below
2195 * output the converted value */
2196 tmpbuf = result;
2197 tmps = (char *) tmpbuf;
2198 len = tmplen;
2199 }
2200 else { /* Non-utf8 output stream, but string only representable in
2201 utf8 */
2202 assert((char *)result == tmps);
2203 Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8),
2204 "Wide character in %s",
2205 PL_op ? OP_DESC(PL_op) : "print"
2206 );
2207 /* Could also check that isn't one of the things to avoid
2208 * in utf8 by using check_utf8_print(), but not doing so,
2209 * since the stream isn't a UTF8 stream */
2210 }
2211 }
2212 /* To detect whether the process is about to overstep its
2213 * filesize limit we would need getrlimit(). We could then
2214 * also transparently raise the limit with setrlimit() --
2215 * but only until the system hard limit/the filesystem limit,
2216 * at which we would get EPERM. Note that when using buffered
2217 * io the write failure can be delayed until the flush/close. --jhi */
2218 if (len && (PerlIO_write(fp,tmps,len) == 0))
2219 happy = FALSE;
2220 Safefree(tmpbuf);
2221 return happy ? !PerlIO_error(fp) : FALSE;
ff8e2863 2222 }
a687059c
LW		 2223}
2224
79072805 2225I32
0d7d409d 2226Perl_my_stat_flags(pTHX_ const U32 flags)
a687059c 2227{
39644a26 2228 dSP;
79072805 2229 IO *io;
2dd78f96 2230 GV* gv;
79072805 2231
533c011a 2232 if (PL_op->op_flags & OPf_REF) {
1604cfb0 2233 gv = cGVOP_gv;
748a9306 2234 do_fstat:
97c8f3e6 2235 if (gv == PL_defgv) {
1604cfb0
MS		 2236 if (PL_laststatval < 0)
2237 SETERRNO(EBADF,RMS_IFI);
5228a96c 2238 return PL_laststatval;
1604cfb0
MS		 2239 }
2240 io = GvIO(gv);
ad02613c 2241 do_fstat_have_io:
5228a96c 2242 PL_laststype = OP_STAT;
bd5f6c01 2243 PL_statgv = gv ? gv : (GV *)io;
8062ff11 2244 SvPVCLEAR(PL_statname);
77616968 2245 if (io) {
1604cfb0 2246 if (IoIFP(io)) {
375ed12a 2247 int fd = PerlIO_fileno(IoIFP(io));
77616968
JH		 2248 if (fd < 0) {
2249 /* E.g. PerlIO::scalar has no real fd. */
1604cfb0 2250 SETERRNO(EBADF,RMS_IFI);
77616968
JH		 2251 return (PL_laststatval = -1);
2252 } else {
375ed12a
JH		 2253 return (PL_laststatval = PerlLIO_fstat(fd, &PL_statcache));
2254 }
5228a96c 2255 } else if (IoDIRP(io)) {
3497a01f 2256 return (PL_laststatval = PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache));
5228a96c 2257 }
5228a96c 2258 }
1604cfb0
MS		 2259 PL_laststatval = -1;
2260 report_evil_fh(gv);
2261 SETERRNO(EBADF,RMS_IFI);
2262 return -1;
a687059c 2263 }
d2c4d2d1 2264 else if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t))
1604cfb0
MS		 2265 == OPpFT_STACKED)
2266 return PL_laststatval;
d2c4d2d1 2267 else {
1604cfb0
MS		 2268 SV* const sv = TOPs;
2269 const char *s, *d;
2270 STRLEN len;
2271 if ((gv = MAYBE_DEREF_GV_flags(sv,flags))) {
2272 goto do_fstat;
2273 }
ad02613c 2274 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
a45c7426 2275 io = MUTABLE_IO(SvRV(sv));
1604cfb0 2276 gv = NULL;
ad02613c
SP		 2277 goto do_fstat_have_io;
2278 }
748a9306 2279
1604cfb0
MS		 2280 s = SvPV_flags_const(sv, len, flags);
2281 PL_statgv = NULL;
2282 sv_setpvn(PL_statname, s, len);
2283 d = SvPVX_const(PL_statname); /* s now NUL-terminated */
2284 PL_laststype = OP_STAT;
a155eb05
TC		 2285 if (!IS_SAFE_PATHNAME(s, len, OP_NAME(PL_op))) {
2286 PL_laststatval = -1;
2287 }
2288 else {
2289 PL_laststatval = PerlLIO_stat(d, &PL_statcache);
2290 }
1604cfb0 2291 if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && should_warn_nl(s)) {
7347ee54 2292 GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral); /* PL_warn_nl is constant */
1604cfb0 2293 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
7347ee54 2294 GCC_DIAG_RESTORE_STMT;
5d37acd6 2295 }
1604cfb0 2296 return PL_laststatval;
a687059c
LW		 2297 }
2298}
2299
fbb0b3b3 2300
79072805 2301I32
0d7d409d 2302Perl_my_lstat_flags(pTHX_ const U32 flags)
c623bd54 2303{
a1894d81 2304 static const char* const no_prev_lstat = "The stat preceding -l _ wasn't an lstat";
39644a26 2305 dSP;
b16276bb 2306 const char *file;
a155eb05 2307 STRLEN len;
cd22fad3 2308 SV* const sv = TOPs;
5840701a 2309 bool isio = FALSE;
533c011a 2310 if (PL_op->op_flags & OPf_REF) {
1604cfb0
MS		 2311 if (cGVOP_gv == PL_defgv) {
2312 if (PL_laststype != OP_LSTAT)
2313 Perl_croak(aTHX_ "%s", no_prev_lstat);
2314 if (PL_laststatval < 0)
2315 SETERRNO(EBADF,RMS_IFI);
2316 return PL_laststatval;
2317 }
2318 PL_laststatval = -1;
2319 if (ckWARN(WARN_IO)) {
2320 /* diag_listed_as: Use of -l on filehandle%s */
2321 Perl_warner(aTHX_ packWARN(WARN_IO),
2322 "Use of -l on filehandle %" HEKf,
2323 HEKfARG(GvENAME_HEK(cGVOP_gv)));
2324 }
2325 SETERRNO(EBADF,RMS_IFI);
2326 return -1;
fe14fcc3 2327 }
8db8f6b6 2328 if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t))
1604cfb0 2329 == OPpFT_STACKED) {
1f26655e 2330 if (PL_laststype != OP_LSTAT)
1604cfb0 2331 Perl_croak(aTHX_ "%s", no_prev_lstat);
1f26655e 2332 return PL_laststatval;
cd22fad3 2333 }
c623bd54 2334
3280af22 2335 PL_laststype = OP_LSTAT;
a0714e2c 2336 PL_statgv = NULL;
5840701a
FC		 2337 if ( ( (SvROK(sv) && ( isGV_with_GP(SvRV(sv))
2338 || (isio = SvTYPE(SvRV(sv)) == SVt_PVIO) )
2339 )
2340 || isGV_with_GP(sv)
2341 )
2342 && ckWARN(WARN_IO)) {
2343 if (isio)
1604cfb0 2344 /* diag_listed_as: Use of -l on filehandle%s */
5840701a
FC		 2345 Perl_warner(aTHX_ packWARN(WARN_IO),
2346 "Use of -l on filehandle");
2347 else
1604cfb0 2348 /* diag_listed_as: Use of -l on filehandle%s */
5840701a 2349 Perl_warner(aTHX_ packWARN(WARN_IO),
147e3846 2350 "Use of -l on filehandle %" HEKf,
10bafe90
BF		 2351 HEKfARG(GvENAME_HEK((const GV *)
2352 (SvROK(sv) ? SvRV(sv) : sv))));
cd22fad3 2353 }
a155eb05 2354 file = SvPV_flags_const(sv, len, flags);
b16276bb 2355 sv_setpv(PL_statname,file);
a155eb05
TC		 2356 if (!IS_SAFE_PATHNAME(file, len, OP_NAME(PL_op))) {
2357 PL_laststatval = -1;
2358 }
2359 else {
2360 PL_laststatval = PerlLIO_lstat(file,&PL_statcache);
2361 }
7cb3f959 2362 if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && should_warn_nl(file)) {
7347ee54 2363 GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral); /* PL_warn_nl is constant */
5d37acd6 2364 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "lstat");
7347ee54 2365 GCC_DIAG_RESTORE_STMT;
5d37acd6 2366 }
3280af22 2367 return PL_laststatval;
c623bd54
LW		 2368}
2369
a0f2c8ec
JD		 2370static void
2371S_exec_failed(pTHX_ const char *cmd, int fd, int do_report)
2372{
2373 const int e = errno;
7918f24d 2374 PERL_ARGS_ASSERT_EXEC_FAILED;
738ab09f
AB		 2375
2376 if (ckWARN(WARN_EXEC))
2377 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't exec \"%s\": %s",
2378 cmd, Strerror(e));
a0f2c8ec 2379 if (do_report) {
b469f1e0
JH		 2380 /* XXX silently ignore failures */
2381 PERL_UNUSED_RESULT(PerlLIO_write(fd, (void*)&e, sizeof(int)));
1604cfb0 2382 PerlLIO_close(fd);
a0f2c8ec
JD		 2383 }
2384}
2385
738ab09f 2386bool
5aaab254 2387Perl_do_aexec5(pTHX_ SV *really, SV **mark, SV **sp,
1604cfb0 2388 int fd, int do_report)
d5a9bfb0 2389{
7918f24d 2390 PERL_ARGS_ASSERT_DO_AEXEC5;
822c8b4d 2391#if defined(__LIBCATAMOUNT__)
cd39f2b6
JH		 2392 Perl_croak(aTHX_ "exec? I'm not *that* kind of operating system");
2393#else
2fcab330 2394 assert(sp >= mark);
282fc0b3 2395 ENTER;
2fcab330 2396 {
1604cfb0
MS		 2397 const char **argv, **a;
2398 const char *tmps = NULL;
2399 Newx(argv, sp - mark + 1, const char*);
2400 SAVEFREEPV(argv);
2401 a = argv;
2402
2403 while (++mark <= sp) {
2404 if (*mark) {
2405 char *arg = savepv(SvPV_nolen_const(*mark));
2406 SAVEFREEPV(arg);
2407 *a++ = arg;
2408 } else
2409 *a++ = "";
2410 }
2411 *a = NULL;
2412 if (really) {
2413 tmps = savepv(SvPV_nolen_const(really));
2414 SAVEFREEPV(tmps);
2415 }
282fc0b3 2416 if ((!really && argv[0] && *argv[0] != '/') ||
1604cfb0
MS		 2417 (really && *tmps != '/')) /* will execvp use PATH? */
2418 TAINT_ENV(); /* testing IFS here is overkill, probably */
2419 PERL_FPU_PRE_EXEC
2420 if (really && *tmps) {
282fc0b3
Z		 2421 PerlProc_execvp(tmps,EXEC_ARGV_CAST(argv));
2422 } else if (argv[0]) {
2423 PerlProc_execvp(argv[0],EXEC_ARGV_CAST(argv));
2fcab330
DIM		 2424 } else {
2425 SETERRNO(ENOENT,RMS_FNF);
2426 }
1604cfb0 2427 PERL_FPU_POST_EXEC
282fc0b3 2428 S_exec_failed(aTHX_ (really ? tmps : argv[0] ? argv[0] : ""), fd, do_report);
a687059c 2429 }
282fc0b3 2430 LEAVE;
cd39f2b6 2431#endif
738ab09f 2432 return FALSE;
a687059c
LW		 2433}
2434
9555a685 2435#ifdef PERL_DEFAULT_DO_EXEC3_IMPLEMENTATION
e446cec8 2436
738ab09f 2437bool
2fbb330f 2438Perl_do_exec3(pTHX_ const char *incmd, int fd, int do_report)
e446cec8 2439{
282fc0b3 2440 const char **argv, **a;
eb578fdb 2441 char *s;
15db3ae2 2442 char *buf;
2fbb330f 2443 char *cmd;
2fbb330f 2444 /* Make a copy so we can change it */
6fca0082 2445 const Size_t cmdlen = strlen(incmd) + 1;
7918f24d
NC		 2446
2447 PERL_ARGS_ASSERT_DO_EXEC3;
2448
282fc0b3 2449 ENTER;
15db3ae2 2450 Newx(buf, cmdlen, char);
282fc0b3 2451 SAVEFREEPV(buf);
15db3ae2 2452 cmd = buf;
cfff9797 2453 memcpy(cmd, incmd, cmdlen);
a687059c 2454
748a9306 2455 while (*cmd && isSPACE(*cmd))
1604cfb0 2456 cmd++;
748a9306 2457
a687059c
LW		 2458 /* save an extra exec if possible */
2459
bf38876a 2460#ifdef CSH
d05c1ba0 2461 {
0c19750d 2462 char flags[PERL_FLAGS_MAX];
1604cfb0
MS		 2463 if (strnEQ(cmd,PL_cshname,PL_cshlen) &&
2464 strBEGINs(cmd+PL_cshlen," -c")) {
28f0d0ec 2465 my_strlcpy(flags, "-c", PERL_FLAGS_MAX);
1604cfb0
MS		 2466 s = cmd+PL_cshlen+3;
2467 if (*s == 'f') {
2468 s++;
28f0d0ec 2469 my_strlcat(flags, "f", PERL_FLAGS_MAX - 2);
1604cfb0
MS		 2470 }
2471 if (*s == ' ')
2472 s++;
2473 if (*s++ == '\'') {
2474 char * const ncmd = s;
2475
2476 while (*s)
2477 s++;
2478 if (s[-1] == '\n')
2479 *--s = '\0';
2480 if (s[-1] == '\'') {
2481 *--s = '\0';
2482 PERL_FPU_PRE_EXEC
2483 PerlProc_execl(PL_cshname, "csh", flags, ncmd, (char*)NULL);
2484 PERL_FPU_POST_EXEC
2485 *s = '\'';
2486 S_exec_failed(aTHX_ PL_cshname, fd, do_report);
2487 goto leave;
2488 }
2489 }
2490 }
a687059c 2491 }
bf38876a 2492#endif /* CSH */
a687059c
LW		 2493
2494 /* see if there are shell metacharacters in it */
2495
748a9306 2496 if (*cmd == '.' && isSPACE(cmd[1]))
1604cfb0 2497 goto doshell;
748a9306 2498
c8b388b0 2499 if (strBEGINs(cmd,"exec") && isSPACE(cmd[4]))
1604cfb0 2500 goto doshell;
748a9306 2501
294b3b39 2502 s = cmd;
0eb30aeb 2503 while (isWORDCHAR(*s))
1604cfb0 2504 s++; /* catch VAR=val gizmo */
63f2c1e1 2505 if (*s == '=')
1604cfb0 2506 goto doshell;
748a9306 2507
a687059c 2508 for (s = cmd; *s; s++) {
1604cfb0
MS		 2509 if (*s != ' ' && !isALPHA(*s) &&
2510 memCHRs("$&*(){}[]'\";\\|?<>~`\n",*s)) {
2511 if (*s == '\n' && !s[1]) {
2512 *s = '\0';
2513 break;
2514 }
2515 /* handle the 2>&1 construct at the end */
2516 if (*s == '>' && s[1] == '&' && s[2] == '1'
2517 && s > cmd + 1 && s[-1] == '2' && isSPACE(s[-2])
2518 && (!s[3] || isSPACE(s[3])))
2519 {
6867be6d 2520 const char *t = s + 3;
603a98b0 2521
1604cfb0
MS		 2522 while (*t && isSPACE(*t))
2523 ++t;
2524 if (!*t && (PerlLIO_dup2(1,2) != -1)) {
2525 s[-2] = '\0';
2526 break;
2527 }
2528 }
2529 doshell:
2530 PERL_FPU_PRE_EXEC
738ab09f 2531 PerlProc_execl(PL_sh_path, "sh", "-c", cmd, (char *)NULL);
1604cfb0
MS		 2532 PERL_FPU_POST_EXEC
2533 S_exec_failed(aTHX_ PL_sh_path, fd, do_report);
2534 goto leave;
2535 }
a687059c 2536 }
748a9306 2537
282fc0b3
Z		 2538 Newx(argv, (s - cmd) / 2 + 2, const char*);
2539 SAVEFREEPV(argv);
2540 cmd = savepvn(cmd, s-cmd);
2541 SAVEFREEPV(cmd);
2542 a = argv;
2543 for (s = cmd; *s;) {
1604cfb0
MS		 2544 while (isSPACE(*s))
2545 s++;
2546 if (*s)
2547 *(a++) = s;
2548 while (*s && !isSPACE(*s))
2549 s++;
2550 if (*s)
2551 *s++ = '\0';
a687059c 2552 }
6136c704 2553 *a = NULL;
282fc0b3 2554 if (argv[0]) {
1604cfb0 2555 PERL_FPU_PRE_EXEC
282fc0b3 2556 PerlProc_execvp(argv[0],EXEC_ARGV_CAST(argv));
1604cfb0
MS		 2557 PERL_FPU_POST_EXEC
2558 if (errno == ENOEXEC) /* for system V NIH syndrome */
2559 goto doshell;
2560 S_exec_failed(aTHX_ argv[0], fd, do_report);
a687059c 2561 }
282fc0b3
Z		 2562leave:
2563 LEAVE;
738ab09f 2564 return FALSE;
a687059c
LW		 2565}
2566
6890e559 2567#endif /* OS2 || WIN32 */
760ac839 2568
79072805 2569I32
5aaab254 2570Perl_apply(pTHX_ I32 type, SV **mark, SV **sp)
a687059c 2571{
eb578fdb
KW		 2572 I32 val;
2573 I32 tot = 0;
4634a855 2574 const char *const what = PL_op_name[type];
5c144d81 2575 const char *s;
84c7b88c 2576 STRLEN len;
890ce7af 2577 SV ** const oldmark = mark;
885b4b39 2578 bool killgp = FALSE;
a687059c 2579
7918f24d
NC		 2580 PERL_ARGS_ASSERT_APPLY;
2581
9a9b5ec9
DM		 2582 PERL_UNUSED_VAR(what); /* may not be used depending on compile options */
2583
1444765e 2584 /* Doing this ahead of the switch statement preserves the old behaviour,
a3815e44 2585 where attempting to use kill as a taint test would fail on
1444765e
NC		 2586 platforms where kill was not defined. */
2587#ifndef HAS_KILL
2588 if (type == OP_KILL)
1604cfb0 2589 Perl_die(aTHX_ PL_no_func, what);
1444765e
NC		 2590#endif
2591#ifndef HAS_CHOWN
2592 if (type == OP_CHOWN)
1604cfb0 2593 Perl_die(aTHX_ PL_no_func, what);
1444765e
NC		 2594#endif
2595
2596
20408e3c 2597#define APPLY_TAINT_PROPER() \
3280af22 2598 STMT_START { \
1604cfb0 2599 if (TAINT_get) { TAINT_PROPER(what); } \
873ef191 2600 } STMT_END
20408e3c
GS		 2601
2602 /* This is a first heuristic; it doesn't catch tainting magic. */
284167a5 2603 if (TAINTING_get) {
1604cfb0
MS		 2604 while (++mark <= sp) {
2605 if (SvTAINTED(*mark)) {
2606 TAINT;
2607 break;
2608 }
2609 }
2610 mark = oldmark;
463ee0b2 2611 }
a687059c 2612 switch (type) {
79072805 2613 case OP_CHMOD:
1604cfb0
MS		 2614 APPLY_TAINT_PROPER();
2615 if (++mark <= sp) {
2616 val = SvIV(*mark);
2617 APPLY_TAINT_PROPER();
2618 tot = sp - mark;
2619 while (++mark <= sp) {
c4aca7d0 2620 GV* gv;
2ea1cce7 2621 if ((gv = MAYBE_DEREF_GV(*mark))) {
1604cfb0 2622 if (GvIO(gv) && IoIFP(GvIOp(gv))) {
c4aca7d0 2623#ifdef HAS_FCHMOD
375ed12a 2624 int fd = PerlIO_fileno(IoIFP(GvIOn(gv)));
1604cfb0 2625 APPLY_TAINT_PROPER();
375ed12a
JH		 2626 if (fd < 0) {
2627 SETERRNO(EBADF,RMS_IFI);
2628 tot--;
2629 } else if (fchmod(fd, val))
2630 tot--;
c4aca7d0 2631#else
1604cfb0 2632 Perl_die(aTHX_ PL_no_func, "fchmod");
c4aca7d0 2633#endif
1604cfb0
MS		 2634 }
2635 else {
8334cae6 2636 SETERRNO(EBADF,RMS_IFI);
1604cfb0
MS		 2637 tot--;
2638 }
2639 }
2640 else {
2641 const char *name = SvPV_nomg_const(*mark, len);
2642 APPLY_TAINT_PROPER();
41188aa0 2643 if (!IS_SAFE_PATHNAME(name, len, "chmod") ||
c8028aa6
TC		 2644 PerlLIO_chmod(name, val)) {
2645 tot--;
2646 }
1604cfb0
MS		 2647 }
2648 }
2649 }
2650 break;
fe14fcc3 2651#ifdef HAS_CHOWN
79072805 2652 case OP_CHOWN:
1604cfb0
MS		 2653 APPLY_TAINT_PROPER();
2654 if (sp - mark > 2) {
eb578fdb 2655 I32 val2;
1604cfb0
MS		 2656 val = SvIVx(*++mark);
2657 val2 = SvIVx(*++mark);
2658 APPLY_TAINT_PROPER();
2659 tot = sp - mark;
2660 while (++mark <= sp) {
c4aca7d0 2661 GV* gv;
1604cfb0
MS		 2662 if ((gv = MAYBE_DEREF_GV(*mark))) {
2663 if (GvIO(gv) && IoIFP(GvIOp(gv))) {
c4aca7d0 2664#ifdef HAS_FCHOWN
375ed12a 2665 int fd = PerlIO_fileno(IoIFP(GvIOn(gv)));
1604cfb0 2666 APPLY_TAINT_PROPER();
375ed12a 2667 if (fd < 0) {
dd1dbff0 2668 SETERRNO(EBADF,RMS_IFI);
1604cfb0 2669 tot--;
375ed12a 2670 } else if (fchown(fd, val, val2))
1604cfb0 2671 tot--;
c4aca7d0 2672#else
1604cfb0 2673 Perl_die(aTHX_ PL_no_func, "fchown");
c4aca7d0 2674#endif
1604cfb0
MS		 2675 }
2676 else {
8334cae6 2677 SETERRNO(EBADF,RMS_IFI);
1604cfb0
MS		 2678 tot--;
2679 }
2680 }
2681 else {
2682 const char *name = SvPV_nomg_const(*mark, len);
2683 APPLY_TAINT_PROPER();
41188aa0 2684 if (!IS_SAFE_PATHNAME(name, len, "chown") ||
c8028aa6 2685 PerlLIO_chown(name, val, val2)) {
1604cfb0 2686 tot--;
c8028aa6 2687 }
1604cfb0
MS		 2688 }
2689 }
2690 }
2691 break;
b1248f16 2692#endif
a1d180c4 2693/*
dd64f1c3
AD		 2694XXX Should we make lchown() directly available from perl?
2695For now, we'll let Configure test for HAS_LCHOWN, but do
2696nothing in the core.
2697 --AD 5/1998
2698*/
fe14fcc3 2699#ifdef HAS_KILL
79072805 2700 case OP_KILL:
1604cfb0
MS		 2701 APPLY_TAINT_PROPER();
2702 if (mark == sp)
2703 break;
2704 s = SvPVx_const(*++mark, len);
2705 if (*s == '-' && isALPHA(s[1]))
2706 {
2707 s++;
2708 len--;
885b4b39 2709 killgp = TRUE;
1604cfb0
MS		 2710 }
2711 if (isALPHA(*s)) {
2712 if (*s == 'S' && s[1] == 'I' && s[2] == 'G') {
2713 s += 3;
84c7b88c
BF		 2714 len -= 3;
2715 }
2716 if ((val = whichsig_pvn(s, len)) < 0)
147e3846
KW		 2717 Perl_croak(aTHX_ "Unrecognized signal name \"%" SVf "\"",
2718 SVfARG(*mark));
1604cfb0
MS		 2719 }
2720 else
2721 {
2722 val = SvIV(*mark);
2723 if (val < 0)
2724 {
2725 killgp = TRUE;
c2fd40cb 2726 val = -val;
1604cfb0
MS		 2727 }
2728 }
2729 APPLY_TAINT_PROPER();
2730 tot = sp - mark;
2731
2732 while (++mark <= sp) {
2733 Pid_t proc;
2734 SvGETMAGIC(*mark);
2735 if (!(SvNIOK(*mark) || looks_like_number(*mark)))
2736 Perl_croak(aTHX_ "Can't kill a non-numeric process ID");
2737 proc = SvIV_nomg(*mark);
2738 APPLY_TAINT_PROPER();
111f73b5
DM		 2739#ifdef HAS_KILLPG
2740 /* use killpg in preference, as the killpg() wrapper for Win32
2741 * understands process groups, but the kill() wrapper doesn't */
2742 if (killgp ? PerlProc_killpg(proc, val)
2743 : PerlProc_kill(proc, val))
2744#else
2745 if (PerlProc_kill(killgp ? -proc: proc, val))
2746#endif
1604cfb0
MS		 2747 tot--;
2748 }
2749 PERL_ASYNC_CHECK();
2750 break;
b1248f16 2751#endif
79072805 2752 case OP_UNLINK:
1604cfb0
MS		 2753 APPLY_TAINT_PROPER();
2754 tot = sp - mark;
2755 while (++mark <= sp) {
2756 s = SvPV_const(*mark, len);
2757 APPLY_TAINT_PROPER();
2758 if (!IS_SAFE_PATHNAME(s, len, "unlink")) {
c8028aa6
TC		 2759 tot--;
2760 }
1604cfb0
MS		 2761 else if (PL_unsafe) {
2762 if (UNLINK(s))
2763 {
2764 tot--;
2765 }
5cdd1fc2 2766#if defined(__amigaos4__) && defined(NEWLIB)
1604cfb0
MS		 2767 else
2768 {
5cdd1fc2
AB		 2769 /* Under AmigaOS4 unlink only 'fails' if the
2770 * filename is invalid. It may not remove the file
2771 * if it's locked, so check if it's still around. */
2772 if ((access(s,F_OK) != -1))
2773 {
2774 tot--;
2775 }
1604cfb0
MS		 2776 }
2777#endif
2778 }
2779 else { /* don't let root wipe out directories without -U */
2780 Stat_t statbuf;
2781 if (PerlLIO_lstat(s, &statbuf) < 0)
2782 tot--;
2783 else if (S_ISDIR(statbuf.st_mode)) {
2784 SETERRNO(EISDIR, SS_NOPRIV);
2785 tot--;
2786 }
2787 else {
2788 if (UNLINK(s))
2789 {
2790 tot--;
2791 }
5cdd1fc2 2792#if defined(__amigaos4__) && defined(NEWLIB)
1604cfb0
MS		 2793 else
2794 {
2795 /* Under AmigaOS4 unlink only 'fails' if the filename is invalid */
2796 /* It may not remove the file if it's Locked, so check if it's still */
2797 /* arround */
2798 if((access(s,F_OK) != -1))
2799 {
2800 tot--;
2801 }
2802 }
2803#endif
2804 }
2805 }
2806 }
2807 break;
e96b369d 2808#if defined(HAS_UTIME) || defined(HAS_FUTIMES)
79072805 2809 case OP_UTIME:
1604cfb0
MS		 2810 APPLY_TAINT_PROPER();
2811 if (sp - mark > 2) {
e96b369d 2812#if defined(HAS_FUTIMES)
1604cfb0
MS		 2813 struct timeval utbuf[2];
2814 void *utbufp = utbuf;
e96b369d 2815#elif defined(I_UTIME) || defined(VMS)
1604cfb0
MS		 2816 struct utimbuf utbuf;
2817 struct utimbuf *utbufp = &utbuf;
663a0e37 2818#else
1604cfb0
MS		 2819 struct {
2820 Time_t actime;
2821 Time_t modtime;
2822 } utbuf;
2823 void *utbufp = &utbuf;
663a0e37 2824#endif
a687059c 2825
1604cfb0
MS		 2826 SV* const accessed = *++mark;
2827 SV* const modified = *++mark;
c6f7b413 2828
6ec06612
SB		 2829 /* Be like C, and if both times are undefined, let the C
2830 * library figure out what to do. This usually means
2831 * "current time". */
c6f7b413
RS		 2832
2833 if ( accessed == &PL_sv_undef && modified == &PL_sv_undef )
6ec06612
SB		 2834 utbufp = NULL;
2835 else {
2836 Zero(&utbuf, sizeof utbuf, char);
e96b369d 2837#ifdef HAS_FUTIMES
1604cfb0
MS		 2838 utbuf[0].tv_sec = (long)SvIV(accessed); /* time accessed */
2839 utbuf[0].tv_usec = 0;
2840 utbuf[1].tv_sec = (long)SvIV(modified); /* time modified */
2841 utbuf[1].tv_usec = 0;
e96b369d 2842#elif defined(BIG_TIME)
4ea561bc
NC		 2843 utbuf.actime = (Time_t)SvNV(accessed); /* time accessed */
2844 utbuf.modtime = (Time_t)SvNV(modified); /* time modified */
517844ec 2845#else
4ea561bc
NC		 2846 utbuf.actime = (Time_t)SvIV(accessed); /* time accessed */
2847 utbuf.modtime = (Time_t)SvIV(modified); /* time modified */
517844ec 2848#endif
6ec06612 2849 }
1604cfb0
MS		 2850 APPLY_TAINT_PROPER();
2851 tot = sp - mark;
2852 while (++mark <= sp) {
e96b369d 2853 GV* gv;
64617da9 2854 if ((gv = MAYBE_DEREF_GV(*mark))) {
1604cfb0 2855 if (GvIO(gv) && IoIFP(GvIOp(gv))) {
e96b369d 2856#ifdef HAS_FUTIMES
375ed12a 2857 int fd = PerlIO_fileno(IoIFP(GvIOn(gv)));
1604cfb0 2858 APPLY_TAINT_PROPER();
375ed12a
JH		 2859 if (fd < 0) {
2860 SETERRNO(EBADF,RMS_IFI);
2861 tot--;
1604cfb0
MS		 2862 } else if (futimes(fd, (struct timeval *) utbufp))
2863 tot--;
e96b369d 2864#else
1604cfb0
MS		 2865 Perl_die(aTHX_ PL_no_func, "futimes");
2866#endif
2867 }
2868 else {
8f432bc3 2869 SETERRNO(EBADF,RMS_IFI);
1604cfb0
MS		 2870 tot--;
2871 }
2872 }
2873 else {
2874 const char * const name = SvPV_nomg_const(*mark, len);
2875 APPLY_TAINT_PROPER();
2876 if (!IS_SAFE_PATHNAME(name, len, "utime")) {
c8028aa6
TC		 2877 tot--;
2878 }
2879 else
e96b369d 2880#ifdef HAS_FUTIMES
1604cfb0 2881 if (utimes(name, (struct timeval *)utbufp))
e96b369d 2882#else
1604cfb0 2883 if (PerlLIO_utime(name, utbufp))
e96b369d 2884#endif
1604cfb0
MS		 2885 tot--;
2886 }
e96b369d 2887
1604cfb0
MS		 2888 }
2889 }
2890 else
2891 tot = 0;
2892 break;
a0d0e21e 2893#endif
a687059c
LW		 2894 }
2895 return tot;
20408e3c 2896
20408e3c 2897#undef APPLY_TAINT_PROPER
a687059c
LW		 2898}
2899
bd93adf5 2900/* Do the permissions in *statbufp allow some operation? */
a0d0e21e 2901#ifndef VMS /* VMS' cando is in vms.c */
7f4774ae 2902bool
5aaab254 2903Perl_cando(pTHX_ Mode_t mode, bool effective, const Stat_t *statbufp)
ae1951c1
NC		 2904/* effective is a flag, true for EUID, or for checking if the effective gid
2905 * is in the list of groups returned from getgroups().
2906 */
a687059c 2907{
7918f24d 2908 PERL_ARGS_ASSERT_CANDO;
81611534 2909 PERL_UNUSED_CONTEXT;
7918f24d 2910
bee1dbe2 2911#ifdef DOSISH
fe14fcc3
LW		 2912 /* [Comments and code from Len Reed]
2913 * MS-DOS "user" is similar to UNIX's "superuser," but can't write
2914 * to write-protected files. The execute permission bit is set
486ec47a 2915 * by the Microsoft C library stat() function for the following:
fe14fcc3
LW		 2916 * .exe files
2917 * .com files
2918 * .bat files
2919 * directories
2920 * All files and directories are readable.
2921 * Directories and special files, e.g. "CON", cannot be
2922 * write-protected.
2923 * [Comment by Tom Dinger -- a directory can have the write-protect
2924 * bit set in the file system, but DOS permits changes to
2925 * the directory anyway. In addition, all bets are off
2926 * here for networked software, such as Novell and
2927 * Sun's PC-NFS.]
2928 */
2929
bee1dbe2
LW		 2930 /* Atari stat() does pretty much the same thing. we set x_bit_set_in_stat
2931 * too so it will actually look into the files for magic numbers
2932 */
8298454c 2933 return cBOOL(mode & statbufp->st_mode);
fe14fcc3 2934
55497cff 2935#else /* ! DOSISH */
b595cd4b
RU		 2936# ifdef __CYGWIN__
2937 if (ingroup(544,effective)) { /* member of Administrators */
2938# else
985213f2 2939 if ((effective ? PerlProc_geteuid() : PerlProc_getuid()) == 0) { /* root is special */
b595cd4b 2940# endif
1604cfb0
MS		 2941 if (mode == S_IXUSR) {
2942 if (statbufp->st_mode & 0111 || S_ISDIR(statbufp->st_mode))
2943 return TRUE;
2944 }
2945 else
2946 return TRUE; /* root reads and writes anything */
2947 return FALSE;
a687059c 2948 }
985213f2 2949 if (statbufp->st_uid == (effective ? PerlProc_geteuid() : PerlProc_getuid()) ) {
1604cfb0
MS		 2950 if (statbufp->st_mode & mode)
2951 return TRUE; /* ok as "user" */
a687059c 2952 }
d8eceb89 2953 else if (ingroup(statbufp->st_gid,effective)) {
1604cfb0
MS		 2954 if (statbufp->st_mode & mode >> 3)
2955 return TRUE; /* ok as "group" */
a687059c 2956 }
7f4774ae 2957 else if (statbufp->st_mode & mode >> 6)
1604cfb0 2958 return TRUE; /* ok as "other" */
a687059c 2959 return FALSE;
55497cff 2960#endif /* ! DOSISH */
a687059c 2961}
a0d0e21e 2962#endif /* ! VMS */
a687059c 2963
1f676739 2964static bool
0da8eb3a 2965S_ingroup(pTHX_ Gid_t testgid, bool effective)
a687059c 2966{
81611534
JH		 2967#ifndef PERL_IMPLICIT_SYS
2968 /* PERL_IMPLICIT_SYS like Win32: getegid() etc. require the context. */
2969 PERL_UNUSED_CONTEXT;
2970#endif
985213f2 2971 if (testgid == (effective ? PerlProc_getegid() : PerlProc_getgid()))
1604cfb0 2972 return TRUE;
fe14fcc3 2973#ifdef HAS_GETGROUPS
a687059c 2974 {
1604cfb0
MS		 2975 Groups_t *gary = NULL;
2976 I32 anum;
331b57bc 2977 bool rc = FALSE;
a687059c 2978
1604cfb0 2979 anum = getgroups(0, gary);
375ed12a
JH		 2980 if (anum > 0) {
2981 Newx(gary, anum, Groups_t);
2982 anum = getgroups(anum, gary);
2983 while (--anum >= 0)
2984 if (gary[anum] == testgid) {
2985 rc = TRUE;
2986 break;
2987 }
331b57bc 2988
375ed12a
JH		 2989 Safefree(gary);
2990 }
331b57bc 2991 return rc;
a687059c 2992 }
c685562b 2993#else
a687059c 2994 return FALSE;
cd39f2b6 2995#endif
a687059c 2996}
c2ab57d4 2997
fe14fcc3 2998#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
c2ab57d4 2999
79072805 3000I32
864dbfa3 3001Perl_do_ipcget(pTHX_ I32 optype, SV **mark, SV **sp)
c2ab57d4 3002{
0bcc34c2 3003 const key_t key = (key_t)SvNVx(*++mark);
c3312966 3004 SV *nsv = optype == OP_MSGGET ? NULL : *++mark;
6867be6d 3005 const I32 flags = SvIVx(*++mark);
294a48e9 3006
7918f24d 3007 PERL_ARGS_ASSERT_DO_IPCGET;
294a48e9 3008 PERL_UNUSED_ARG(sp);
c2ab57d4 3009
748a9306 3010 SETERRNO(0,0);
c2ab57d4
LW		 3011 switch (optype)
3012 {
fe14fcc3 3013#ifdef HAS_MSG
79072805 3014 case OP_MSGGET:
1604cfb0 3015 return msgget(key, flags);
e5d73d77 3016#endif
fe14fcc3 3017#ifdef HAS_SEM
79072805 3018 case OP_SEMGET:
1604cfb0 3019 return semget(key, (int) SvIV(nsv), flags);
e5d73d77 3020#endif
fe14fcc3 3021#ifdef HAS_SHM
79072805 3022 case OP_SHMGET:
1604cfb0 3023 return shmget(key, (size_t) SvUV(nsv), flags);
e5d73d77 3024#endif
fe14fcc3 3025#if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
e5d73d77 3026 default:
fe13d51d 3027 /* diag_listed_as: msg%s not implemented */
1604cfb0 3028 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
e5d73d77 3029#endif
c2ab57d4
LW		 3030 }
3031 return -1; /* should never happen */
3032}
3033
79072805 3034I32
864dbfa3 3035Perl_do_ipcctl(pTHX_ I32 optype, SV **mark, SV **sp)
c2ab57d4 3036{
c2ab57d4 3037 char *a;
a0d0e21e 3038 I32 ret = -1;
6867be6d 3039 const I32 id = SvIVx(*++mark);
95b63a38 3040#ifdef Semctl
6867be6d 3041 const I32 n = (optype == OP_SEMCTL) ? SvIVx(*++mark) : 0;
95b63a38 3042#endif
6867be6d 3043 const I32 cmd = SvIVx(*++mark);
0bcc34c2
AL		 3044 SV * const astr = *++mark;
3045 STRLEN infosize = 0;
3046 I32 getinfo = (cmd == IPC_STAT);
c2ab57d4 3047
7918f24d 3048 PERL_ARGS_ASSERT_DO_IPCCTL;
0bcc34c2 3049 PERL_UNUSED_ARG(sp);
c2ab57d4
LW		 3050
3051 switch (optype)
3052 {
fe14fcc3 3053#ifdef HAS_MSG
79072805 3054 case OP_MSGCTL:
1604cfb0
MS		 3055 if (cmd == IPC_STAT || cmd == IPC_SET)
3056 infosize = sizeof(struct msqid_ds);
3057 break;
e5d73d77 3058#endif
fe14fcc3 3059#ifdef HAS_SHM
79072805 3060 case OP_SHMCTL:
1604cfb0
MS		 3061 if (cmd == IPC_STAT || cmd == IPC_SET)
3062 infosize = sizeof(struct shmid_ds);
3063 break;
e5d73d77 3064#endif
fe14fcc3 3065#ifdef HAS_SEM
79072805 3066 case OP_SEMCTL:
39398f3f 3067#ifdef Semctl
1604cfb0
MS		 3068 if (cmd == IPC_STAT || cmd == IPC_SET)
3069 infosize = sizeof(struct semid_ds);
3070 else if (cmd == GETALL || cmd == SETALL)
3071 {
3072 struct semid_ds semds;
3073 union semun semun;
e6f0bdd6
GS		 3074#ifdef EXTRA_F_IN_SEMUN_BUF
3075 semun.buff = &semds;
3076#else
84902520 3077 semun.buf = &semds;
e6f0bdd6 3078#endif
1604cfb0
MS		 3079 getinfo = (cmd == GETALL);
3080 if (Semctl(id, 0, IPC_STAT, semun) == -1)
3081 return -1;
3082 infosize = semds.sem_nsems * sizeof(short);
3083 /* "short" is technically wrong but much more portable
3084 than guessing about u_?short(_t)? */
3085 }
39398f3f 3086#else
fe13d51d 3087 /* diag_listed_as: sem%s not implemented */
1604cfb0 3088 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
39398f3f 3089#endif
1604cfb0 3090 break;
e5d73d77 3091#endif
fe14fcc3 3092#if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
e5d73d77 3093 default:
fe13d51d 3094 /* diag_listed_as: shm%s not implemented */
1604cfb0 3095 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
e5d73d77 3096#endif
c2ab57d4
LW		 3097 }
3098
3099 if (infosize)
3100 {
1604cfb0
MS		 3101 if (getinfo)
3102 {
d43c116b
TC		 3103 /* we're not using the value here, so don't SvPVanything */
3104 SvUPGRADE(astr, SVt_PV);
3105 SvGETMAGIC(astr);
3106 if (SvTHINKFIRST(astr))
3107 sv_force_normal_flags(astr, 0);
1604cfb0
MS		 3108 a = SvGROW(astr, infosize+1);
3109 }
3110 else
3111 {
3112 STRLEN len;
3113 a = SvPVbyte(astr, len);
3114 if (len != infosize)
3115 Perl_croak(aTHX_ "Bad arg length for %s, is %lu, should be %ld",
3116 PL_op_desc[optype],
3117 (unsigned long)len,
3118 (long)infosize);
3119 }
c2ab57d4
LW		 3120 }
3121 else
3122 {
d43c116b
TC		 3123 /* We historically treat this as a pointer if we don't otherwise recognize
3124 the op, but for many ops the value is simply ignored anyway, so
3125 don't warn on undef.
3126 */
3127 SvGETMAGIC(astr);
3128 if (SvOK(astr)) {
3129 const IV i = SvIV_nomg(astr);
3130 a = INT2PTR(char *,i); /* ouch */
3131 }
3132 else {
3133 a = NULL;
3134 }
c2ab57d4 3135 }
748a9306 3136 SETERRNO(0,0);
c2ab57d4
LW		 3137 switch (optype)
3138 {
fe14fcc3 3139#ifdef HAS_MSG
79072805 3140 case OP_MSGCTL:
1604cfb0
MS		 3141 ret = msgctl(id, cmd, (struct msqid_ds *)a);
3142 break;
e5d73d77 3143#endif
fe14fcc3 3144#ifdef HAS_SEM
bd89102f 3145 case OP_SEMCTL: {
39398f3f 3146#ifdef Semctl
bd89102f
AD		 3147 union semun unsemds;
3148
64d76282
BC		 3149 if(cmd == SETVAL) {
3150 unsemds.val = PTR2nat(a);
3151 }
3152 else {
e6f0bdd6 3153#ifdef EXTRA_F_IN_SEMUN_BUF
64d76282 3154 unsemds.buff = (struct semid_ds *)a;
e6f0bdd6 3155#else
64d76282 3156 unsemds.buf = (struct semid_ds *)a;
e6f0bdd6 3157#endif
64d76282 3158 }
1604cfb0 3159 ret = Semctl(id, n, cmd, unsemds);
39398f3f 3160#else
1604cfb0
MS		 3161 /* diag_listed_as: sem%s not implemented */
3162 Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
39398f3f 3163#endif
bd89102f 3164 }
1604cfb0 3165 break;
e5d73d77 3166#endif
fe14fcc3 3167#ifdef HAS_SHM
79072805 3168 case OP_SHMCTL:
1604cfb0
MS		 3169 ret = shmctl(id, cmd, (struct shmid_ds *)a);
3170 break;
e5d73d77 3171#endif
c2ab57d4
LW		 3172 }
3173 if (getinfo && ret >= 0) {
1604cfb0
MS		 3174 SvCUR_set(astr, infosize);
3175 *SvEND(astr) = '\0';
d43c116b 3176 SvPOK_only(astr);
1604cfb0 3177 SvSETMAGIC(astr);
c2ab57d4
LW		 3178 }
3179 return ret;
3180}
3181
79072805 3182I32
864dbfa3 3183Perl_do_msgsnd(pTHX_ SV **mark, SV **sp)
c2ab57d4 3184{
fe14fcc3 3185#ifdef HAS_MSG
463ee0b2 3186 STRLEN len;
6867be6d 3187 const I32 id = SvIVx(*++mark);
0bcc34c2
AL		 3188 SV * const mstr = *++mark;
3189 const I32 flags = SvIVx(*++mark);
aa058ea4 3190 const char * const mbuf = SvPVbyte(mstr, len);
0bcc34c2
AL		 3191 const I32 msize = len - sizeof(long);
3192
7918f24d 3193 PERL_ARGS_ASSERT_DO_MSGSND;
890ce7af 3194 PERL_UNUSED_ARG(sp);
c2ab57d4 3195
0bcc34c2 3196 if (msize < 0)
1604cfb0 3197 Perl_croak(aTHX_ "Arg too short for msgsnd");
748a9306 3198 SETERRNO(0,0);
681fb693
JH		 3199 if (id >= 0 && flags >= 0) {
3200 return msgsnd(id, (struct msgbuf *)mbuf, msize, flags);
3201 } else {
3202 SETERRNO(EINVAL,LIB_INVARG);
3203 return -1;
3204 }
e5d73d77 3205#else
2d51fa4d
RGS		 3206 PERL_UNUSED_ARG(sp);
3207 PERL_UNUSED_ARG(mark);
fe13d51d 3208 /* diag_listed_as: msg%s not implemented */
cea2e8a9 3209 Perl_croak(aTHX_ "msgsnd not implemented");
7c522378 3210 return -1;
e5d73d77 3211#endif
c2ab57d4
LW		 3212}
3213
79072805 3214I32
864dbfa3 3215Perl_do_msgrcv(pTHX_ SV **mark, SV **sp)
c2ab57d4 3216{
fe14fcc3 3217#ifdef HAS_MSG
c2ab57d4
LW		 3218 char *mbuf;
3219 long mtype;
6867be6d 3220 I32 msize, flags, ret;
6867be6d 3221 const I32 id = SvIVx(*++mark);
0bcc34c2 3222 SV * const mstr = *++mark;
7918f24d
NC		 3223
3224 PERL_ARGS_ASSERT_DO_MSGRCV;
890ce7af 3225 PERL_UNUSED_ARG(sp);
79072805 3226
c2e66d9e
GS		 3227 /* suppress warning when reading into undef var --jhi */
3228 if (! SvOK(mstr))
8062ff11 3229 SvPVCLEAR(mstr);
463ee0b2
LW		 3230 msize = SvIVx(*++mark);
3231 mtype = (long)SvIVx(*++mark);
3232 flags = SvIVx(*++mark);
93524f2b 3233 SvPV_force_nolen(mstr);
a0d0e21e 3234 mbuf = SvGROW(mstr, sizeof(long)+msize+1);
a1d180c4 3235
748a9306 3236 SETERRNO(0,0);
d2607e1e
JH		 3237 if (id >= 0 && msize >= 0 && flags >= 0) {
3238 ret = msgrcv(id, (struct msgbuf *)mbuf, msize, mtype, flags);
3239 } else {
3240 SETERRNO(EINVAL,LIB_INVARG);
3241 ret = -1;
3242 }
c2ab57d4 3243 if (ret >= 0) {
1604cfb0 3244 SvCUR_set(mstr, sizeof(long)+ret);
6987f443 3245 SvPOK_only(mstr);
1604cfb0
MS		 3246 *SvEND(mstr) = '\0';
3247 /* who knows who has been playing with this message? */
3248 SvTAINTED_on(mstr);
c2ab57d4
LW		 3249 }
3250 return ret;
e5d73d77 3251#else
2d51fa4d
RGS		 3252 PERL_UNUSED_ARG(sp);
3253 PERL_UNUSED_ARG(mark);
fe13d51d 3254 /* diag_listed_as: msg%s not implemented */
cea2e8a9 3255 Perl_croak(aTHX_ "msgrcv not implemented");
7c522378 3256 return -1;
e5d73d77 3257#endif
c2ab57d4
LW		 3258}
3259
79072805 3260I32
864dbfa3 3261Perl_do_semop(pTHX_ SV **mark, SV **sp)
c2ab57d4 3262{
fe14fcc3 3263#ifdef HAS_SEM
463ee0b2 3264 STRLEN opsize;
6867be6d 3265 const I32 id = SvIVx(*++mark);
0bcc34c2 3266 SV * const opstr = *++mark;
61f05872 3267 const char * const opbuf = SvPVbyte(opstr, opsize);
7918f24d
NC		 3268
3269 PERL_ARGS_ASSERT_DO_SEMOP;
890ce7af 3270 PERL_UNUSED_ARG(sp);
c2ab57d4 3271
248ff010 3272 if (opsize < 3 * SHORTSIZE
1604cfb0
MS		 3273 || (opsize % (3 * SHORTSIZE))) {
3274 SETERRNO(EINVAL,LIB_INVARG);
3275 return -1;
c2ab57d4 3276 }
748a9306 3277 SETERRNO(0,0);
248ff010
NC		 3278 /* We can't assume that sizeof(struct sembuf) == 3 * sizeof(short). */
3279 {
6867be6d 3280 const int nsops = opsize / (3 * sizeof (short));
248ff010 3281 int i = nsops;
0bcc34c2 3282 short * const ops = (short *) opbuf;
248ff010
NC		 3283 short *o = ops;
3284 struct sembuf *temps, *t;
3285 I32 result;
3286
a02a5408 3287 Newx (temps, nsops, struct sembuf);
248ff010
NC		 3288 t = temps;
3289 while (i--) {
3290 t->sem_num = *o++;
3291 t->sem_op = *o++;
3292 t->sem_flg = *o++;
3293 t++;
3294 }
3295 result = semop(id, temps, nsops);
248ff010
NC		 3296 Safefree(temps);
3297 return result;
3298 }
e5d73d77 3299#else
fe13d51d 3300 /* diag_listed_as: sem%s not implemented */
cea2e8a9 3301 Perl_croak(aTHX_ "semop not implemented");
e5d73d77 3302#endif
c2ab57d4
LW		 3303}
3304
79072805 3305I32
864dbfa3 3306Perl_do_shmio(pTHX_ I32 optype, SV **mark, SV **sp)
c2ab57d4 3307{
fe14fcc3 3308#ifdef HAS_SHM
4373e329 3309 char *shm;
c2ab57d4 3310 struct shmid_ds shmds;
6867be6d 3311 const I32 id = SvIVx(*++mark);
0bcc34c2
AL		 3312 SV * const mstr = *++mark;
3313 const I32 mpos = SvIVx(*++mark);
3314 const I32 msize = SvIVx(*++mark);
7918f24d
NC		 3315
3316 PERL_ARGS_ASSERT_DO_SHMIO;
890ce7af 3317 PERL_UNUSED_ARG(sp);
c2ab57d4 3318
748a9306 3319 SETERRNO(0,0);
c2ab57d4 3320 if (shmctl(id, IPC_STAT, &shmds) == -1)
1604cfb0 3321 return -1;
7f39519f 3322 if (mpos < 0 || msize < 0
1604cfb0
MS		 3323 || (size_t)mpos + msize > (size_t)shmds.shm_segsz) {
3324 SETERRNO(EFAULT,SS_ACCVIO); /* can't do as caller requested */
3325 return -1;
c2ab57d4 3326 }
568fc267
JH		 3327 if (id >= 0) {
3328 shm = (char *)shmat(id, NULL, (optype == OP_SHMREAD) ? SHM_RDONLY : 0);
3329 } else {
3330 SETERRNO(EINVAL,LIB_INVARG);
3331 return -1;
3332 }
c2ab57d4 3333 if (shm == (char *)-1) /* I hate System V IPC, I really do */
1604cfb0 3334 return -1;
79072805 3335 if (optype == OP_SHMREAD) {
1604cfb0
MS		 3336 char *mbuf;
3337 /* suppress warning when reading into undef var (tchrist 3/Mar/00) */
3338 SvGETMAGIC(mstr);
3339 SvUPGRADE(mstr, SVt_PV);
3340 if (! SvOK(mstr))
8062ff11 3341 SvPVCLEAR(mstr);
1604cfb0
MS		 3342 SvPOK_only(mstr);
3343 mbuf = SvGROW(mstr, (STRLEN)msize+1);
a0d0e21e 3344
1604cfb0
MS		 3345 Copy(shm + mpos, mbuf, msize, char);
3346 SvCUR_set(mstr, msize);
3347 *SvEND(mstr) = '\0';
3348 SvSETMAGIC(mstr);
3349 /* who knows who has been playing with this shared memory? */
3350 SvTAINTED_on(mstr);
c2ab57d4
LW		 3351 }
3352 else {
1604cfb0 3353 STRLEN len;
c2ab57d4 3354
1604cfb0
MS		 3355 const char *mbuf = SvPVbyte(mstr, len);
3356 const I32 n = ((I32)len > msize) ? msize : (I32)len;
3357 Copy(mbuf, shm + mpos, n, char);
3358 if (n < msize)
3359 memzero(shm + mpos + n, msize - n);
c2ab57d4
LW		 3360 }
3361 return shmdt(shm);
e5d73d77 3362#else
fe13d51d 3363 /* diag_listed_as: shm%s not implemented */
cea2e8a9 3364 Perl_croak(aTHX_ "shm I/O not implemented");
7c522378 3365 return -1;
e5d73d77 3366#endif
c2ab57d4
LW		 3367}
3368
fe14fcc3 3369#endif /* SYSV IPC */
4e35701f 3370
0d44d22b
NC		 3371/*
3372=for apidoc start_glob
3373
3374Function called by C<do_readline> to spawn a glob (or do the glob inside
154e47c8 3375perl on VMS). This code used to be inline, but now perl uses C<File::Glob>
25047fde
KW		 3376this glob starter is only used by miniperl during the build process,
3377or when PERL_EXTERNAL_GLOB is defined.
75af9d73 3378Moving it away shrinks F<pp_hot.c>; shrinking F<pp_hot.c> helps speed perl up.
fab3f3a7 3379
0d44d22b
NC		 3380=cut
3381*/
3382
3383PerlIO *
3384Perl_start_glob (pTHX_ SV *tmpglob, IO *io)
3385{
561b68a9 3386 SV * const tmpcmd = newSV(0);
0d44d22b 3387 PerlIO *fp;
41188aa0
TC		 3388 STRLEN len;
3389 const char *s = SvPV(tmpglob, len);
7918f24d
NC		 3390
3391 PERL_ARGS_ASSERT_START_GLOB;
3392
41188aa0 3393 if (!IS_SAFE_SYSCALL(s, len, "pattern", "glob"))
c8028aa6
TC		 3394 return NULL;
3395
0d44d22b
NC		 3396 ENTER;
3397 SAVEFREESV(tmpcmd);
3398#ifdef VMS /* expand the wildcards right here, rather than opening a pipe, */
3399 /* since spawning off a process is a real performance hit */
dca5a913 3400
1cc9774b
CB		 3401PerlIO *
3402Perl_vms_start_glob
3403 (pTHX_ SV *tmpglob,
3404 IO *io);
3405
49a7a762 3406 fp = Perl_vms_start_glob(aTHX_ tmpglob, io);
dca5a913 3407
0d44d22b 3408#else /* !VMS */
4009c3ff
AC		 3409# ifdef DOSISH
3410# if defined(OS2)
0d44d22b
NC		 3411 sv_setpv(tmpcmd, "for a in ");
3412 sv_catsv(tmpcmd, tmpglob);
f8db7d5b 3413 sv_catpvs(tmpcmd, "; do echo \"$a\\0\\c\"; done |");
4009c3ff 3414# else
0d44d22b
NC		 3415 sv_setpv(tmpcmd, "perlglob ");
3416 sv_catsv(tmpcmd, tmpglob);
f8db7d5b 3417 sv_catpvs(tmpcmd, " |");
4009c3ff
AC		 3418# endif
3419# elif defined(CSH)
0d44d22b 3420 sv_setpvn(tmpcmd, PL_cshname, PL_cshlen);
f8db7d5b 3421 sv_catpvs(tmpcmd, " -cf 'set nonomatch; glob ");
0d44d22b 3422 sv_catsv(tmpcmd, tmpglob);
f8db7d5b 3423 sv_catpvs(tmpcmd, "' 2>/dev/null |");
4009c3ff 3424# else
0d44d22b
NC		 3425 sv_setpv(tmpcmd, "echo ");
3426 sv_catsv(tmpcmd, tmpglob);
f8db7d5b 3427 sv_catpvs(tmpcmd, "|tr -s ' \t\f\r' '\\n\\n\\n\\n'|");
4009c3ff 3428# endif /* !DOSISH && !CSH */
93b2dae1 3429 {
acffc8af
FC		 3430 SV ** const svp = hv_fetchs(GvHVn(PL_envgv), "LS_COLORS", 0);
3431 if (svp && *svp)
3432 save_helem_flags(GvHV(PL_envgv),
3433 newSVpvs_flags("LS_COLORS", SVs_TEMP), svp,
3434 SAVEf_SETMAGIC);
93b2dae1 3435 }
d5eb9a46
NC		 3436 (void)do_open6(PL_last_in_gv, SvPVX_const(tmpcmd), SvCUR(tmpcmd),
3437 NULL, NULL, 0);
0d44d22b
NC		 3438 fp = IoIFP(io);
3439#endif /* !VMS */
3440 LEAVE;
de7dabb6
TC		 3441
3442 if (!fp && ckWARN(WARN_GLOB)) {
3443 Perl_warner(aTHX_ packWARN(WARN_GLOB), "glob failed (can't start child: %s)",
3444 Strerror(errno));
3445 }
3446
0d44d22b
NC		 3447 return fp;
3448}
66610fdd
RGS		 3449
3450/*
14d04a33 3451 * ex: set ts=8 sts=4 sw=4 et:
37442d52 3452 */
Unnamed repository; edit this file 'description' to name the repository.