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