Context Navigation

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

Visit:

Revision 14597, 44.7 KB checked in by ghudson, 25 years ago (diff)
Revert local change; it's not necessary (and breaks) in perl 5.6.0. Will revert this file to vendor branch.

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

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

Download in other formats: