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