Context Navigation

source: trunk/third/perl/doio.c @ 14554

Visit:

Revision 14554, 44.9 KB checked in by ghudson, 24 years ago (diff)
Merge local change.

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

Note: See TracBrowser for help on using the repository browser.

Download in other formats: