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