Context Navigation

source: trunk/third/perl/pp_sys.c @ 10950

Visit:

Revision 10950, 83.3 KB checked in by ghudson, 27 years ago (diff)
Add a hack to let perl scripts get at the d_ino/d_fileno field of the dirent structure. This lets us speed up a perl version of getcwd().

Line
1	/* pp_sys.c
2	*
3	* Copyright (c) 1991-1997, 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	* But only a short way ahead its floor and the walls on either side were
12	* cloven by a great fissure, out of which the red glare came, now leaping
13	* up, now dying down into darkness; and all the while far below there was
14	* a rumour and a trouble as of great engines throbbing and labouring.
15	*/
16
17	#include "EXTERN.h"
18	#include "perl.h"
19
20	/* XXX If this causes problems, set i_unistd=undef in the hint file. */
21	#ifdef I_UNISTD
22	# include <unistd.h>
23	#endif
24
25	#ifdef I_SYS_WAIT
26	# include <sys/wait.h>
27	#endif
28
29	#ifdef I_SYS_RESOURCE
30	# include <sys/resource.h>
31	#endif
32
33	#if defined(HAS_SOCKET) && !defined(VMS) /* VMS handles sockets via vmsish.h */
34	# include <sys/socket.h>
35	# include <netdb.h>
36	# ifndef ENOTSOCK
37	# ifdef I_NET_ERRNO
38	# include <net/errno.h>
39	# endif
40	# endif
41	#endif
42
43	#ifdef HAS_SELECT
44	#ifdef I_SYS_SELECT
45	#include <sys/select.h>
46	#endif
47	#endif
48
49	#ifdef HOST_NOT_FOUND
50	extern int h_errno;
51	#endif
52
53	#ifdef HAS_PASSWD
54	# ifdef I_PWD
55	# include <pwd.h>
56	# else
57	struct passwd getpwnam _((char ));
58	struct passwd *getpwuid _((Uid_t));
59	# endif
60	struct passwd *getpwent _((void));
61	#endif
62
63	#ifdef HAS_GROUP
64	# ifdef I_GRP
65	# include <grp.h>
66	# else
67	struct group getgrnam _((char ));
68	struct group *getgrgid _((Gid_t));
69	# endif
70	struct group *getgrent _((void));
71	#endif
72
73	#ifdef I_UTIME
74	# ifdef _MSC_VER
75	# include <sys/utime.h>
76	# else
77	# include <utime.h>
78	# endif
79	#endif
80	#ifdef I_FCNTL
81	#include <fcntl.h>
82	#endif
83	#ifdef I_SYS_FILE
84	#include <sys/file.h>
85	#endif
86
87	/* Put this after #includes because fork and vfork prototypes may conflict. */
88	#ifndef HAS_VFORK
89	# define vfork fork
90	#endif
91
92	/* Put this after #includes because <unistd.h> defines _XOPEN_. /
93	#ifndef Sock_size_t
94	# if _XOPEN_VERSION >= 5 \|\| defined(_XOPEN_SOURCE_EXTENDED) \|\| defined(__GLIBC__)
95	# define Sock_size_t Size_t
96	# else
97	# define Sock_size_t int
98	# endif
99	#endif
100
101	#if !defined(HAS_MKDIR) \|\| !defined(HAS_RMDIR)
102	static int dooneliner _((char cmd, char filename));
103	#endif
104
105	#ifdef HAS_CHSIZE
106	# ifdef my_chsize /* Probably #defined to Perl_my_chsize in embed.h */
107	# undef my_chsize
108	# endif
109	# define my_chsize chsize
110	#endif
111
112	#ifdef HAS_FLOCK
113	# define FLOCK flock
114	#else /* no flock() */
115
116	/* fcntl.h might not have been included, even if it exists, because
117	the current Configure only sets I_FCNTL if it's needed to pick up
118	the *_OK constants. Make sure it has been included before testing
119	the fcntl() locking constants. */
120	# if defined(HAS_FCNTL) && !defined(I_FCNTL)
121	# include <fcntl.h>
122	# endif
123
124	# if defined(HAS_FCNTL) && defined(F_SETLK) && defined (F_SETLKW)
125	# define FLOCK fcntl_emulate_flock
126	# define FCNTL_EMULATE_FLOCK
127	# else /* no flock() or fcntl(F_SETLK,...) */
128	# ifdef HAS_LOCKF
129	# define FLOCK lockf_emulate_flock
130	# define LOCKF_EMULATE_FLOCK
131	# endif /* lockf */
132	# endif /* no flock() or fcntl(F_SETLK,...) */
133
134	# ifdef FLOCK
135	static int FLOCK _((int, int));
136
137	/*
138	* These are the flock() constants. Since this sytems doesn't have
139	* flock(), the values of the constants are probably not available.
140	*/
141	# ifndef LOCK_SH
142	# define LOCK_SH 1
143	# endif
144	# ifndef LOCK_EX
145	# define LOCK_EX 2
146	# endif
147	# ifndef LOCK_NB
148	# define LOCK_NB 4
149	# endif
150	# ifndef LOCK_UN
151	# define LOCK_UN 8
152	# endif
153	# endif /* emulating flock() */
154
155	#endif /* no flock() */
156
157	#ifndef MAXPATHLEN
158	# ifdef PATH_MAX
159	# define MAXPATHLEN PATH_MAX
160	# else
161	# define MAXPATHLEN 1024
162	# endif
163	#endif
164
165	#define ZBTLEN 10
166	static char zero_but_true[ZBTLEN + 1] = "0 but true";
167
168	/* Pushy I/O. */
169
170	PP(pp_backtick)
171	{
172	dSP; dTARGET;
173	PerlIO *fp;
174	char *tmps = POPp;
175	I32 gimme = GIMME_V;
176
177	TAINT_PROPER("``");
178	fp = my_popen(tmps, "r");
179	if (fp) {
180	if (gimme == G_VOID) {
181	while (PerlIO_read(fp, tokenbuf, sizeof tokenbuf) > 0)
182	/SUPPRESS 530/
183	;
184	}
185	else if (gimme == G_SCALAR) {
186	sv_setpv(TARG, ""); /* note that this preserves previous buffer */
187	while (sv_gets(TARG, fp, SvCUR(TARG)) != Nullch)
188	/SUPPRESS 530/
189	;
190	XPUSHs(TARG);
191	SvTAINTED_on(TARG);
192	}
193	else {
194	SV *sv;
195
196	for (;;) {
197	sv = NEWSV(56, 80);
198	if (sv_gets(sv, fp, 0) == Nullch) {
199	SvREFCNT_dec(sv);
200	break;
201	}
202	XPUSHs(sv_2mortal(sv));
203	if (SvLEN(sv) - SvCUR(sv) > 20) {
204	SvLEN_set(sv, SvCUR(sv)+1);
205	Renew(SvPVX(sv), SvLEN(sv), char);
206	}
207	SvTAINTED_on(sv);
208	}
209	}
210	STATUS_NATIVE_SET(my_pclose(fp));
211	TAINT; /* "I believe that this is not gratuitous!" */
212	}
213	else {
214	STATUS_NATIVE_SET(-1);
215	if (gimme == G_SCALAR)
216	RETPUSHUNDEF;
217	}
218
219	RETURN;
220	}
221
222	PP(pp_glob)
223	{
224	OP *result;
225	ENTER;
226
227	#ifndef VMS
228	if (tainting) {
229	/*
230	* The external globbing program may use things we can't control,
231	* so for security reasons we must assume the worst.
232	*/
233	TAINT;
234	taint_proper(no_security, "glob");
235	}
236	#endif /* !VMS */
237
238	SAVESPTR(last_in_gv); /* We don't want this to be permanent. */
239	last_in_gv = (GV)stack_sp--;
240
241	SAVESPTR(rs); /* This is not permanent, either. */
242	rs = sv_2mortal(newSVpv("", 1));
243	#ifndef DOSISH
244	#ifndef CSH
245	*SvPVX(rs) = '\n';
246	#endif /* !CSH */
247	#endif /* !DOSISH */
248
249	result = do_readline();
250	LEAVE;
251	return result;
252	}
253
254	PP(pp_indread)
255	{
256	last_in_gv = gv_fetchpv(SvPVx(GvSV((GV)(stack_sp--)), na), TRUE,SVt_PVIO);
257	return do_readline();
258	}
259
260	PP(pp_rcatline)
261	{
262	last_in_gv = cGVOP->op_gv;
263	return do_readline();
264	}
265
266	PP(pp_warn)
267	{
268	dSP; dMARK;
269	char *tmps;
270	if (SP - MARK != 1) {
271	dTARGET;
272	do_join(TARG, &sv_no, MARK, SP);
273	tmps = SvPV(TARG, na);
274	SP = MARK + 1;
275	}
276	else {
277	tmps = SvPV(TOPs, na);
278	}
279	if (!tmps \|\| !*tmps) {
280	SV *error = GvSV(errgv);
281	(void)SvUPGRADE(error, SVt_PV);
282	if (SvPOK(error) && SvCUR(error))
283	sv_catpv(error, "\t...caught");
284	tmps = SvPV(error, na);
285	}
286	if (!tmps \|\| !*tmps)
287	tmps = "Warning: something's wrong";
288	warn("%s", tmps);
289	RETSETYES;
290	}
291
292	PP(pp_die)
293	{
294	dSP; dMARK;
295	char *tmps;
296	if (SP - MARK != 1) {
297	dTARGET;
298	do_join(TARG, &sv_no, MARK, SP);
299	tmps = SvPV(TARG, na);
300	SP = MARK + 1;
301	}
302	else {
303	tmps = SvPV(TOPs, na);
304	}
305	if (!tmps \|\| !*tmps) {
306	SV *error = GvSV(errgv);
307	(void)SvUPGRADE(error, SVt_PV);
308	if (SvPOK(error) && SvCUR(error))
309	sv_catpv(error, "\t...propagated");
310	tmps = SvPV(error, na);
311	}
312	if (!tmps \|\| !*tmps)
313	tmps = "Died";
314	DIE("%s", tmps);
315	}
316
317	/* I/O. */
318
319	PP(pp_open)
320	{
321	dSP; dTARGET;
322	GV *gv;
323	SV *sv;
324	char *tmps;
325	STRLEN len;
326
327	if (MAXARG > 1)
328	sv = POPs;
329	if (!isGV(TOPs))
330	DIE(no_usym, "filehandle");
331	if (MAXARG <= 1)
332	sv = GvSV(TOPs);
333	gv = (GV*)POPs;
334	if (!isGV(gv))
335	DIE(no_usym, "filehandle");
336	if (GvIOp(gv))
337	IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
338	tmps = SvPV(sv, len);
339	if (do_open(gv, tmps, len, FALSE, 0, 0, Nullfp))
340	PUSHi( (I32)forkprocess );
341	else if (forkprocess == 0) /* we are a new child */
342	PUSHi(0);
343	else
344	RETPUSHUNDEF;
345	RETURN;
346	}
347
348	PP(pp_close)
349	{
350	dSP;
351	GV *gv;
352
353	if (MAXARG == 0)
354	gv = defoutgv;
355	else
356	gv = (GV*)POPs;
357	EXTEND(SP, 1);
358	PUSHs(boolSV(do_close(gv, TRUE)));
359	RETURN;
360	}
361
362	PP(pp_pipe_op)
363	{
364	dSP;
365	#ifdef HAS_PIPE
366	GV *rgv;
367	GV *wgv;
368	register IO *rstio;
369	register IO *wstio;
370	int fd[2];
371
372	wgv = (GV*)POPs;
373	rgv = (GV*)POPs;
374
375	if (!rgv \|\| !wgv)
376	goto badexit;
377
378	if (SvTYPE(rgv) != SVt_PVGV \|\| SvTYPE(wgv) != SVt_PVGV)
379	DIE(no_usym, "filehandle");
380	rstio = GvIOn(rgv);
381	wstio = GvIOn(wgv);
382
383	if (IoIFP(rstio))
384	do_close(rgv, FALSE);
385	if (IoIFP(wstio))
386	do_close(wgv, FALSE);
387
388	if (pipe(fd) < 0)
389	goto badexit;
390
391	IoIFP(rstio) = PerlIO_fdopen(fd[0], "r");
392	IoOFP(wstio) = PerlIO_fdopen(fd[1], "w");
393	IoIFP(wstio) = IoOFP(wstio);
394	IoTYPE(rstio) = '<';
395	IoTYPE(wstio) = '>';
396
397	if (!IoIFP(rstio) \|\| !IoOFP(wstio)) {
398	if (IoIFP(rstio)) PerlIO_close(IoIFP(rstio));
399	else close(fd[0]);
400	if (IoOFP(wstio)) PerlIO_close(IoOFP(wstio));
401	else close(fd[1]);
402	goto badexit;
403	}
404
405	RETPUSHYES;
406
407	badexit:
408	RETPUSHUNDEF;
409	#else
410	DIE(no_func, "pipe");
411	#endif
412	}
413
414	PP(pp_fileno)
415	{
416	dSP; dTARGET;
417	GV *gv;
418	IO *io;
419	PerlIO *fp;
420	if (MAXARG < 1)
421	RETPUSHUNDEF;
422	gv = (GV*)POPs;
423	if (!gv \|\| !(io = GvIO(gv)) \|\| !(fp = IoIFP(io)))
424	RETPUSHUNDEF;
425	PUSHi(PerlIO_fileno(fp));
426	RETURN;
427	}
428
429	PP(pp_umask)
430	{
431	dSP; dTARGET;
432	int anum;
433
434	#ifdef HAS_UMASK
435	if (MAXARG < 1) {
436	anum = umask(0);
437	(void)umask(anum);
438	}
439	else
440	anum = umask(POPi);
441	TAINT_PROPER("umask");
442	XPUSHi(anum);
443	#else
444	DIE(no_func, "Unsupported function umask");
445	#endif
446	RETURN;
447	}
448
449	PP(pp_binmode)
450	{
451	dSP;
452	GV *gv;
453	IO *io;
454	PerlIO *fp;
455
456	if (MAXARG < 1)
457	RETPUSHUNDEF;
458
459	gv = (GV*)POPs;
460
461	EXTEND(SP, 1);
462	if (!(io = GvIO(gv)) \|\| !(fp = IoIFP(io)))
463	RETPUSHUNDEF;
464
465	#ifdef DOSISH
466	#ifdef atarist
467	if (!PerlIO_flush(fp) && (fp->_flag \|= _IOBIN))
468	RETPUSHYES;
469	else
470	RETPUSHUNDEF;
471	#else
472	if (setmode(PerlIO_fileno(fp), OP_BINARY) != -1) {
473	#if defined(WIN32) && defined(__BORLANDC__)
474	/* The translation mode of the stream is maintained independent
475	* of the translation mode of the fd in the Borland RTL (heavy
476	* digging through their runtime sources reveal). User has to
477	* set the mode explicitly for the stream (though they don't
478	* document this anywhere). GSAR 97-5-24
479	*/
480	PerlIO_seek(fp,0L,0);
481	fp->flags \|= _F_BIN;
482	#endif
483	RETPUSHYES;
484	}
485	else
486	RETPUSHUNDEF;
487	#endif
488	#else
489	#if defined(USEMYBINMODE)
490	if (my_binmode(fp,IoTYPE(io)) != NULL)
491	RETPUSHYES;
492	else
493	RETPUSHUNDEF;
494	#else
495	RETPUSHYES;
496	#endif
497	#endif
498
499	}
500
501	PP(pp_tie)
502	{
503	dSP;
504	SV *varsv;
505	HV* stash;
506	GV *gv;
507	BINOP myop;
508	SV *sv;
509	SV *mark = stack_base + ++markstack_ptr; /* reuse in entersub */
510	I32 markoff = mark - stack_base - 1;
511	char *methname;
512	bool oldcatch = CATCH_GET;
513
514	varsv = mark[0];
515	if (SvTYPE(varsv) == SVt_PVHV)
516	methname = "TIEHASH";
517	else if (SvTYPE(varsv) == SVt_PVAV)
518	methname = "TIEARRAY";
519	else if (SvTYPE(varsv) == SVt_PVGV)
520	methname = "TIEHANDLE";
521	else
522	methname = "TIESCALAR";
523
524	stash = gv_stashsv(mark[1], FALSE);
525	if (!stash \|\| !(gv = gv_fetchmethod(stash, methname)))
526	DIE("Can't locate object method \"%s\" via package \"%s\"",
527	methname, SvPV(mark[1],na));
528
529	Zero(&myop, 1, BINOP);
530	myop.op_last = (OP *) &myop;
531	myop.op_next = Nullop;
532	myop.op_flags = OPf_WANT_SCALAR \| OPf_STACKED;
533	CATCH_SET(TRUE);
534
535	ENTER;
536	SAVESPTR(op);
537	op = (OP *) &myop;
538	if (PERLDB_SUB && curstash != debstash)
539	op->op_private \|= OPpENTERSUB_DB;
540
541	XPUSHs((SV*)GvCV(gv));
542	PUTBACK;
543
544	if (op = pp_entersub())
545	runops();
546	SPAGAIN;
547
548	CATCH_SET(oldcatch);
549	sv = TOPs;
550	if (sv_isobject(sv)) {
551	if (SvTYPE(varsv) == SVt_PVHV \|\| SvTYPE(varsv) == SVt_PVAV) {
552	sv_unmagic(varsv, 'P');
553	sv_magic(varsv, sv, 'P', Nullch, 0);
554	}
555	else {
556	sv_unmagic(varsv, 'q');
557	sv_magic(varsv, sv, 'q', Nullch, 0);
558	}
559	}
560	LEAVE;
561	SP = stack_base + markoff;
562	PUSHs(sv);
563	RETURN;
564	}
565
566	PP(pp_untie)
567	{
568	dSP;
569	SV * sv ;
570
571	sv = POPs;
572
573	if (dowarn) {
574	MAGIC * mg ;
575	if (SvMAGICAL(sv)) {
576	if (SvTYPE(sv) == SVt_PVHV \|\| SvTYPE(sv) == SVt_PVAV)
577	mg = mg_find(sv, 'P') ;
578	else
579	mg = mg_find(sv, 'q') ;
580
581	if (mg && SvREFCNT(SvRV(mg->mg_obj)) > 1)
582	warn("untie attempted while %lu inner references still exist",
583	(unsigned long)SvREFCNT(SvRV(mg->mg_obj)) - 1 ) ;
584	}
585	}
586
587	if (SvTYPE(sv) == SVt_PVHV \|\| SvTYPE(sv) == SVt_PVAV)
588	sv_unmagic(sv, 'P');
589	else
590	sv_unmagic(sv, 'q');
591	RETPUSHYES;
592	}
593
594	PP(pp_tied)
595	{
596	dSP;
597	SV * sv ;
598	MAGIC * mg ;
599
600	sv = POPs;
601	if (SvMAGICAL(sv)) {
602	if (SvTYPE(sv) == SVt_PVHV \|\| SvTYPE(sv) == SVt_PVAV)
603	mg = mg_find(sv, 'P') ;
604	else
605	mg = mg_find(sv, 'q') ;
606
607	if (mg) {
608	PUSHs(sv_2mortal(newSVsv(mg->mg_obj))) ;
609	RETURN ;
610	}
611	}
612
613	RETPUSHUNDEF;
614	}
615
616	PP(pp_dbmopen)
617	{
618	dSP;
619	HV *hv;
620	dPOPPOPssrl;
621	HV* stash;
622	GV *gv;
623	BINOP myop;
624	SV *sv;
625	bool oldcatch = CATCH_GET;
626
627	hv = (HV*)POPs;
628
629	sv = sv_mortalcopy(&sv_no);
630	sv_setpv(sv, "AnyDBM_File");
631	stash = gv_stashsv(sv, FALSE);
632	if (!stash \|\| !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
633	PUTBACK;
634	perl_require_pv("AnyDBM_File.pm");
635	SPAGAIN;
636	if (!(gv = gv_fetchmethod(stash, "TIEHASH")))
637	DIE("No dbm on this machine");
638	}
639
640	Zero(&myop, 1, BINOP);
641	myop.op_last = (OP *) &myop;
642	myop.op_next = Nullop;
643	myop.op_flags = OPf_WANT_SCALAR \| OPf_STACKED;
644	CATCH_SET(TRUE);
645
646	ENTER;
647	SAVESPTR(op);
648	op = (OP *) &myop;
649	if (PERLDB_SUB && curstash != debstash)
650	op->op_private \|= OPpENTERSUB_DB;
651	PUTBACK;
652	pp_pushmark();
653
654	EXTEND(sp, 5);
655	PUSHs(sv);
656	PUSHs(left);
657	if (SvIV(right))
658	PUSHs(sv_2mortal(newSViv(O_RDWR\|O_CREAT)));
659	else
660	PUSHs(sv_2mortal(newSViv(O_RDWR)));
661	PUSHs(right);
662	PUSHs((SV*)GvCV(gv));
663	PUTBACK;
664
665	if (op = pp_entersub())
666	runops();
667	SPAGAIN;
668
669	if (!sv_isobject(TOPs)) {
670	sp--;
671	op = (OP *) &myop;
672	PUTBACK;
673	pp_pushmark();
674
675	PUSHs(sv);
676	PUSHs(left);
677	PUSHs(sv_2mortal(newSViv(O_RDONLY)));
678	PUSHs(right);
679	PUSHs((SV*)GvCV(gv));
680	PUTBACK;
681
682	if (op = pp_entersub())
683	runops();
684	SPAGAIN;
685	}
686
687	CATCH_SET(oldcatch);
688	if (sv_isobject(TOPs))
689	sv_magic((SV*)hv, TOPs, 'P', Nullch, 0);
690	LEAVE;
691	RETURN;
692	}
693
694	PP(pp_dbmclose)
695	{
696	return pp_untie(ARGS);
697	}
698
699	PP(pp_sselect)
700	{
701	dSP; dTARGET;
702	#ifdef HAS_SELECT
703	register I32 i;
704	register I32 j;
705	register char *s;
706	register SV *sv;
707	double value;
708	I32 maxlen = 0;
709	I32 nfound;
710	struct timeval timebuf;
711	struct timeval *tbuf = &timebuf;
712	I32 growsize;
713	char *fd_sets[4];
714	#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
715	I32 masksize;
716	I32 offset;
717	I32 k;
718
719	# if BYTEORDER & 0xf0000
720	# define ORDERBYTE (0x88888888 - BYTEORDER)
721	# else
722	# define ORDERBYTE (0x4444 - BYTEORDER)
723	# endif
724
725	#endif
726
727	SP -= 4;
728	for (i = 1; i <= 3; i++) {
729	if (!SvPOK(SP[i]))
730	continue;
731	j = SvCUR(SP[i]);
732	if (maxlen < j)
733	maxlen = j;
734	}
735
736	#if BYTEORDER == 0x1234 \|\| BYTEORDER == 0x12345678
737	#if defined(__linux__) \|\| defined(OS2)
738	growsize = sizeof(fd_set);
739	#else
740	growsize = maxlen; /* little endians can use vecs directly */
741	#endif
742	#else
743	#ifdef NFDBITS
744
745	#ifndef NBBY
746	#define NBBY 8
747	#endif
748
749	masksize = NFDBITS / NBBY;
750	#else
751	masksize = sizeof(long); /* documented int, everyone seems to use long */
752	#endif
753	growsize = maxlen + (masksize - (maxlen % masksize));
754	Zero(&fd_sets[0], 4, char*);
755	#endif
756
757	sv = SP[4];
758	if (SvOK(sv)) {
759	value = SvNV(sv);
760	if (value < 0.0)
761	value = 0.0;
762	timebuf.tv_sec = (long)value;
763	value -= (double)timebuf.tv_sec;
764	timebuf.tv_usec = (long)(value * 1000000.0);
765	}
766	else
767	tbuf = Null(struct timeval*);
768
769	for (i = 1; i <= 3; i++) {
770	sv = SP[i];
771	if (!SvOK(sv)) {
772	fd_sets[i] = 0;
773	continue;
774	}
775	else if (!SvPOK(sv))
776	SvPV_force(sv,na); /* force string conversion */
777	j = SvLEN(sv);
778	if (j < growsize) {
779	Sv_Grow(sv, growsize);
780	}
781	j = SvCUR(sv);
782	s = SvPVX(sv) + j;
783	while (++j <= growsize) {
784	*s++ = '\0';
785	}
786
787	#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
788	s = SvPVX(sv);
789	New(403, fd_sets[i], growsize, char);
790	for (offset = 0; offset < growsize; offset += masksize) {
791	for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
792	fd_sets[i][j+offset] = s[(k % masksize) + offset];
793	}
794	#else
795	fd_sets[i] = SvPVX(sv);
796	#endif
797	}
798
799	nfound = select(
800	maxlen * 8,
801	(Select_fd_set_t) fd_sets[1],
802	(Select_fd_set_t) fd_sets[2],
803	(Select_fd_set_t) fd_sets[3],
804	tbuf);
805	for (i = 1; i <= 3; i++) {
806	if (fd_sets[i]) {
807	sv = SP[i];
808	#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
809	s = SvPVX(sv);
810	for (offset = 0; offset < growsize; offset += masksize) {
811	for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
812	s[(k % masksize) + offset] = fd_sets[i][j+offset];
813	}
814	Safefree(fd_sets[i]);
815	#endif
816	SvSETMAGIC(sv);
817	}
818	}
819
820	PUSHi(nfound);
821	if (GIMME == G_ARRAY && tbuf) {
822	value = (double)(timebuf.tv_sec) +
823	(double)(timebuf.tv_usec) / 1000000.0;
824	PUSHs(sv = sv_mortalcopy(&sv_no));
825	sv_setnv(sv, value);
826	}
827	RETURN;
828	#else
829	DIE("select not implemented");
830	#endif
831	}
832
833	void
834	setdefout(gv)
835	GV *gv;
836	{
837	if (gv)
838	(void)SvREFCNT_inc(gv);
839	if (defoutgv)
840	SvREFCNT_dec(defoutgv);
841	defoutgv = gv;
842	}
843
844	PP(pp_select)
845	{
846	dSP; dTARGET;
847	GV newdefout, egv;
848	HV *hv;
849
850	newdefout = (op->op_private > 0) ? ((GV *) POPs) : NULL;
851
852	egv = GvEGV(defoutgv);
853	if (!egv)
854	egv = defoutgv;
855	hv = GvSTASH(egv);
856	if (! hv)
857	XPUSHs(&sv_undef);
858	else {
859	GV gvp = (GV)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
860	if (gvp && *gvp == egv) {
861	gv_efullname3(TARG, defoutgv, Nullch);
862	XPUSHTARG;
863	}
864	else {
865	XPUSHs(sv_2mortal(newRV((SV*)egv)));
866	}
867	}
868
869	if (newdefout) {
870	if (!GvIO(newdefout))
871	gv_IOadd(newdefout);
872	setdefout(newdefout);
873	}
874
875	RETURN;
876	}
877
878	PP(pp_getc)
879	{
880	dSP; dTARGET;
881	GV *gv;
882	MAGIC *mg;
883
884	if (MAXARG <= 0)
885	gv = stdingv;
886	else
887	gv = (GV*)POPs;
888	if (!gv)
889	gv = argvgv;
890
891	if (SvMAGICAL(gv) && (mg = mg_find((SV*)gv, 'q'))) {
892	I32 gimme = GIMME_V;
893	PUSHMARK(SP);
894	XPUSHs(mg->mg_obj);
895	PUTBACK;
896	ENTER;
897	perl_call_method("GETC", gimme);
898	LEAVE;
899	SPAGAIN;
900	if (gimme == G_SCALAR)
901	SvSetMagicSV_nosteal(TARG, TOPs);
902	RETURN;
903	}
904	if (!gv \|\| do_eof(gv)) /* make sure we have fp with something */
905	RETPUSHUNDEF;
906	TAINT;
907	sv_setpv(TARG, " ");
908	SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); / should never be EOF */
909	PUSHTARG;
910	RETURN;
911	}
912
913	PP(pp_read)
914	{
915	return pp_sysread(ARGS);
916	}
917
918	static OP *
919	doform(cv,gv,retop)
920	CV *cv;
921	GV *gv;
922	OP *retop;
923	{
924	register CONTEXT *cx;
925	I32 gimme = GIMME_V;
926	AV* padlist = CvPADLIST(cv);
927	SV** svp = AvARRAY(padlist);
928
929	ENTER;
930	SAVETMPS;
931
932	push_return(retop);
933	PUSHBLOCK(cx, CXt_SUB, stack_sp);
934	PUSHFORMAT(cx);
935	SAVESPTR(curpad);
936	curpad = AvARRAY((AV*)svp[1]);
937
938	setdefout(gv); /* locally select filehandle so $% et al work */
939	return CvSTART(cv);
940	}
941
942	PP(pp_enterwrite)
943	{
944	dSP;
945	register GV *gv;
946	register IO *io;
947	GV *fgv;
948	CV *cv;
949
950	if (MAXARG == 0)
951	gv = defoutgv;
952	else {
953	gv = (GV*)POPs;
954	if (!gv)
955	gv = defoutgv;
956	}
957	EXTEND(SP, 1);
958	io = GvIO(gv);
959	if (!io) {
960	RETPUSHNO;
961	}
962	if (IoFMT_GV(io))
963	fgv = IoFMT_GV(io);
964	else
965	fgv = gv;
966
967	cv = GvFORM(fgv);
968	if (!cv) {
969	if (fgv) {
970	SV *tmpsv = sv_newmortal();
971	gv_efullname3(tmpsv, fgv, Nullch);
972	DIE("Undefined format \"%s\" called",SvPVX(tmpsv));
973	}
974	DIE("Not a format reference");
975	}
976	if (CvCLONE(cv))
977	cv = (CV)sv_2mortal((SV)cv_clone(cv));
978
979	IoFLAGS(io) &= ~IOf_DIDTOP;
980	return doform(cv,gv,op->op_next);
981	}
982
983	PP(pp_leavewrite)
984	{
985	dSP;
986	GV *gv = cxstack[cxstack_ix].blk_sub.gv;
987	register IO *io = GvIOp(gv);
988	PerlIO *ofp = IoOFP(io);
989	PerlIO *fp;
990	SV **newsp;
991	I32 gimme;
992	register CONTEXT *cx;
993
994	DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
995	(long)IoLINES_LEFT(io), (long)FmLINES(formtarget)));
996	if (IoLINES_LEFT(io) < FmLINES(formtarget) &&
997	formtarget != toptarget)
998	{
999	GV *fgv;
1000	CV *cv;
1001	if (!IoTOP_GV(io)) {
1002	GV *topgv;
1003	SV *topname;
1004
1005	if (!IoTOP_NAME(io)) {
1006	if (!IoFMT_NAME(io))
1007	IoFMT_NAME(io) = savepv(GvNAME(gv));
1008	topname = sv_2mortal(newSVpvf("%s_TOP", IoFMT_NAME(io)));
1009	topgv = gv_fetchpv(SvPVX(topname), FALSE, SVt_PVFM);
1010	if ((topgv && GvFORM(topgv)) \|\|
1011	!gv_fetchpv("top",FALSE,SVt_PVFM))
1012	IoTOP_NAME(io) = savepv(SvPVX(topname));
1013	else
1014	IoTOP_NAME(io) = savepv("top");
1015	}
1016	topgv = gv_fetchpv(IoTOP_NAME(io),FALSE, SVt_PVFM);
1017	if (!topgv \|\| !GvFORM(topgv)) {
1018	IoLINES_LEFT(io) = 100000000;
1019	goto forget_top;
1020	}
1021	IoTOP_GV(io) = topgv;
1022	}
1023	if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1024	I32 lines = IoLINES_LEFT(io);
1025	char *s = SvPVX(formtarget);
1026	if (lines <= 0) /* Yow, header didn't even fit!!! */
1027	goto forget_top;
1028	while (lines-- > 0) {
1029	s = strchr(s, '\n');
1030	if (!s)
1031	break;
1032	s++;
1033	}
1034	if (s) {
1035	PerlIO_write(ofp, SvPVX(formtarget), s - SvPVX(formtarget));
1036	sv_chop(formtarget, s);
1037	FmLINES(formtarget) -= IoLINES_LEFT(io);
1038	}
1039	}
1040	if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
1041	PerlIO_write(ofp, SvPVX(formfeed), SvCUR(formfeed));
1042	IoLINES_LEFT(io) = IoPAGE_LEN(io);
1043	IoPAGE(io)++;
1044	formtarget = toptarget;
1045	IoFLAGS(io) \|= IOf_DIDTOP;
1046	fgv = IoTOP_GV(io);
1047	if (!fgv)
1048	DIE("bad top format reference");
1049	cv = GvFORM(fgv);
1050	if (!cv) {
1051	SV *tmpsv = sv_newmortal();
1052	gv_efullname3(tmpsv, fgv, Nullch);
1053	DIE("Undefined top format \"%s\" called",SvPVX(tmpsv));
1054	}
1055	if (CvCLONE(cv))
1056	cv = (CV)sv_2mortal((SV)cv_clone(cv));
1057	return doform(cv,gv,op);
1058	}
1059
1060	forget_top:
1061	POPBLOCK(cx,curpm);
1062	POPFORMAT(cx);
1063	LEAVE;
1064
1065	fp = IoOFP(io);
1066	if (!fp) {
1067	if (dowarn) {
1068	if (IoIFP(io))
1069	warn("Filehandle only opened for input");
1070	else
1071	warn("Write on closed filehandle");
1072	}
1073	PUSHs(&sv_no);
1074	}
1075	else {
1076	if ((IoLINES_LEFT(io) -= FmLINES(formtarget)) < 0) {
1077	if (dowarn)
1078	warn("page overflow");
1079	}
1080	if (!PerlIO_write(ofp, SvPVX(formtarget), SvCUR(formtarget)) \|\|
1081	PerlIO_error(fp))
1082	PUSHs(&sv_no);
1083	else {
1084	FmLINES(formtarget) = 0;
1085	SvCUR_set(formtarget, 0);
1086	*SvEND(formtarget) = '\0';
1087	if (IoFLAGS(io) & IOf_FLUSH)
1088	(void)PerlIO_flush(fp);
1089	PUSHs(&sv_yes);
1090	}
1091	}
1092	formtarget = bodytarget;
1093	PUTBACK;
1094	return pop_return();
1095	}
1096
1097	PP(pp_prtf)
1098	{
1099	dSP; dMARK; dORIGMARK;
1100	GV *gv;
1101	IO *io;
1102	PerlIO *fp;
1103	SV *sv;
1104	MAGIC *mg;
1105
1106	if (op->op_flags & OPf_STACKED)
1107	gv = (GV)++MARK;
1108	else
1109	gv = defoutgv;
1110
1111	if (SvMAGICAL(gv) && (mg = mg_find((SV*)gv, 'q'))) {
1112	if (MARK == ORIGMARK) {
1113	EXTEND(SP, 1);
1114	++MARK;
1115	Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1116	++SP;
1117	}
1118	PUSHMARK(MARK - 1);
1119	*MARK = mg->mg_obj;
1120	PUTBACK;
1121	ENTER;
1122	perl_call_method("PRINTF", G_SCALAR);
1123	LEAVE;
1124	SPAGAIN;
1125	MARK = ORIGMARK + 1;
1126	MARK = SP;
1127	SP = MARK;
1128	RETURN;
1129	}
1130
1131	sv = NEWSV(0,0);
1132	if (!(io = GvIO(gv))) {
1133	if (dowarn) {
1134	gv_fullname3(sv, gv, Nullch);
1135	warn("Filehandle %s never opened", SvPV(sv,na));
1136	}
1137	SETERRNO(EBADF,RMS$_IFI);
1138	goto just_say_no;
1139	}
1140	else if (!(fp = IoOFP(io))) {
1141	if (dowarn) {
1142	gv_fullname3(sv, gv, Nullch);
1143	if (IoIFP(io))
1144	warn("Filehandle %s opened only for input", SvPV(sv,na));
1145	else
1146	warn("printf on closed filehandle %s", SvPV(sv,na));
1147	}
1148	SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
1149	goto just_say_no;
1150	}
1151	else {
1152	#ifdef USE_LOCALE_NUMERIC
1153	if (op->op_private & OPpLOCALE)
1154	SET_NUMERIC_LOCAL();
1155	else
1156	SET_NUMERIC_STANDARD();
1157	#endif
1158	do_sprintf(sv, SP - MARK, MARK + 1);
1159	if (!do_print(sv, fp))
1160	goto just_say_no;
1161
1162	if (IoFLAGS(io) & IOf_FLUSH)
1163	if (PerlIO_flush(fp) == EOF)
1164	goto just_say_no;
1165	}
1166	SvREFCNT_dec(sv);
1167	SP = ORIGMARK;
1168	PUSHs(&sv_yes);
1169	RETURN;
1170
1171	just_say_no:
1172	SvREFCNT_dec(sv);
1173	SP = ORIGMARK;
1174	PUSHs(&sv_undef);
1175	RETURN;
1176	}
1177
1178	PP(pp_sysopen)
1179	{
1180	dSP;
1181	GV *gv;
1182	SV *sv;
1183	char *tmps;
1184	STRLEN len;
1185	int mode, perm;
1186
1187	if (MAXARG > 3)
1188	perm = POPi;
1189	else
1190	perm = 0666;
1191	mode = POPi;
1192	sv = POPs;
1193	gv = (GV *)POPs;
1194
1195	tmps = SvPV(sv, len);
1196	if (do_open(gv, tmps, len, TRUE, mode, perm, Nullfp)) {
1197	IoLINES(GvIOp(gv)) = 0;
1198	PUSHs(&sv_yes);
1199	}
1200	else {
1201	PUSHs(&sv_undef);
1202	}
1203	RETURN;
1204	}
1205
1206	PP(pp_sysread)
1207	{
1208	dSP; dMARK; dORIGMARK; dTARGET;
1209	int offset;
1210	GV *gv;
1211	IO *io;
1212	char *buffer;
1213	SSize_t length;
1214	Sock_size_t bufsize;
1215	SV *bufsv;
1216	STRLEN blen;
1217	MAGIC *mg;
1218
1219	gv = (GV)++MARK;
1220	if ((op->op_type == OP_READ \|\| op->op_type == OP_SYSREAD) &&
1221	SvMAGICAL(gv) && (mg = mg_find((SV*)gv, 'q')))
1222	{
1223	SV *sv;
1224
1225	PUSHMARK(MARK-1);
1226	*MARK = mg->mg_obj;
1227	ENTER;
1228	perl_call_method("READ", G_SCALAR);
1229	LEAVE;
1230	SPAGAIN;
1231	sv = POPs;
1232	SP = ORIGMARK;
1233	PUSHs(sv);
1234	RETURN;
1235	}
1236
1237	if (!gv)
1238	goto say_undef;
1239	bufsv = *++MARK;
1240	if (! SvOK(bufsv))
1241	sv_setpvn(bufsv, "", 0);
1242	buffer = SvPV_force(bufsv, blen);
1243	length = SvIVx(*++MARK);
1244	if (length < 0)
1245	DIE("Negative length");
1246	SETERRNO(0,0);
1247	if (MARK < SP)
1248	offset = SvIVx(*++MARK);
1249	else
1250	offset = 0;
1251	io = GvIO(gv);
1252	if (!io \|\| !IoIFP(io))
1253	goto say_undef;
1254	#ifdef HAS_SOCKET
1255	if (op->op_type == OP_RECV) {
1256	char namebuf[MAXPATHLEN];
1257	#if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
1258	bufsize = sizeof (struct sockaddr_in);
1259	#else
1260	bufsize = sizeof namebuf;
1261	#endif
1262	buffer = SvGROW(bufsv, length+1);
1263	/* 'offset' means 'flags' here */
1264	length = recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
1265	(struct sockaddr *)namebuf, &bufsize);
1266	if (length < 0)
1267	RETPUSHUNDEF;
1268	SvCUR_set(bufsv, length);
1269	*SvEND(bufsv) = '\0';
1270	(void)SvPOK_only(bufsv);
1271	SvSETMAGIC(bufsv);
1272	/* This should not be marked tainted if the fp is marked clean */
1273	if (!(IoFLAGS(io) & IOf_UNTAINT))
1274	SvTAINTED_on(bufsv);
1275	SP = ORIGMARK;
1276	sv_setpvn(TARG, namebuf, bufsize);
1277	PUSHs(TARG);
1278	RETURN;
1279	}
1280	#else
1281	if (op->op_type == OP_RECV)
1282	DIE(no_sock_func, "recv");
1283	#endif
1284	if (offset < 0) {
1285	if (-offset > blen)
1286	DIE("Offset outside string");
1287	offset += blen;
1288	}
1289	bufsize = SvCUR(bufsv);
1290	buffer = SvGROW(bufsv, length+offset+1);
1291	if (offset > bufsize) { /* Zero any newly allocated space */
1292	Zero(buffer+bufsize, offset-bufsize, char);
1293	}
1294	if (op->op_type == OP_SYSREAD) {
1295	length = read(PerlIO_fileno(IoIFP(io)), buffer+offset, length);
1296	}
1297	else
1298	#ifdef HAS_SOCKET__bad_code_maybe
1299	if (IoTYPE(io) == 's') {
1300	char namebuf[MAXPATHLEN];
1301	#if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
1302	bufsize = sizeof (struct sockaddr_in);
1303	#else
1304	bufsize = sizeof namebuf;
1305	#endif
1306	length = recvfrom(PerlIO_fileno(IoIFP(io)), buffer+offset, length, 0,
1307	(struct sockaddr *)namebuf, &bufsize);
1308	}
1309	else
1310	#endif
1311	length = PerlIO_read(IoIFP(io), buffer+offset, length);
1312	if (length < 0)
1313	goto say_undef;
1314	SvCUR_set(bufsv, length+offset);
1315	*SvEND(bufsv) = '\0';
1316	(void)SvPOK_only(bufsv);
1317	SvSETMAGIC(bufsv);
1318	/* This should not be marked tainted if the fp is marked clean */
1319	if (!(IoFLAGS(io) & IOf_UNTAINT))
1320	SvTAINTED_on(bufsv);
1321	SP = ORIGMARK;
1322	PUSHi(length);
1323	RETURN;
1324
1325	say_undef:
1326	SP = ORIGMARK;
1327	RETPUSHUNDEF;
1328	}
1329
1330	PP(pp_syswrite)
1331	{
1332	return pp_send(ARGS);
1333	}
1334
1335	PP(pp_send)
1336	{
1337	dSP; dMARK; dORIGMARK; dTARGET;
1338	GV *gv;
1339	IO *io;
1340	int offset;
1341	SV *bufsv;
1342	char *buffer;
1343	int length;
1344	STRLEN blen;
1345
1346	gv = (GV)++MARK;
1347	if (!gv)
1348	goto say_undef;
1349	bufsv = *++MARK;
1350	buffer = SvPV(bufsv, blen);
1351	length = SvIVx(*++MARK);
1352	if (length < 0)
1353	DIE("Negative length");
1354	SETERRNO(0,0);
1355	io = GvIO(gv);
1356	if (!io \|\| !IoIFP(io)) {
1357	length = -1;
1358	if (dowarn) {
1359	if (op->op_type == OP_SYSWRITE)
1360	warn("Syswrite on closed filehandle");
1361	else
1362	warn("Send on closed socket");
1363	}
1364	}
1365	else if (op->op_type == OP_SYSWRITE) {
1366	if (MARK < SP) {
1367	offset = SvIVx(*++MARK);
1368	if (offset < 0) {
1369	if (-offset > blen)
1370	DIE("Offset outside string");
1371	offset += blen;
1372	} else if (offset >= blen && blen > 0)
1373	DIE("Offset outside string");
1374	} else
1375	offset = 0;
1376	if (length > blen - offset)
1377	length = blen - offset;
1378	length = write(PerlIO_fileno(IoIFP(io)), buffer+offset, length);
1379	}
1380	#ifdef HAS_SOCKET
1381	else if (SP > MARK) {
1382	char *sockbuf;
1383	STRLEN mlen;
1384	sockbuf = SvPVx(*++MARK, mlen);
1385	length = sendto(PerlIO_fileno(IoIFP(io)), buffer, blen, length,
1386	(struct sockaddr *)sockbuf, mlen);
1387	}
1388	else
1389	length = send(PerlIO_fileno(IoIFP(io)), buffer, blen, length);
1390
1391	#else
1392	else
1393	DIE(no_sock_func, "send");
1394	#endif
1395	if (length < 0)
1396	goto say_undef;
1397	SP = ORIGMARK;
1398	PUSHi(length);
1399	RETURN;
1400
1401	say_undef:
1402	SP = ORIGMARK;
1403	RETPUSHUNDEF;
1404	}
1405
1406	PP(pp_recv)
1407	{
1408	return pp_sysread(ARGS);
1409	}
1410
1411	PP(pp_eof)
1412	{
1413	dSP;
1414	GV *gv;
1415
1416	if (MAXARG <= 0)
1417	gv = last_in_gv;
1418	else
1419	gv = last_in_gv = (GV*)POPs;
1420	PUSHs(boolSV(!gv \|\| do_eof(gv)));
1421	RETURN;
1422	}
1423
1424	PP(pp_tell)
1425	{
1426	dSP; dTARGET;
1427	GV *gv;
1428
1429	if (MAXARG <= 0)
1430	gv = last_in_gv;
1431	else
1432	gv = last_in_gv = (GV*)POPs;
1433	PUSHi( do_tell(gv) );
1434	RETURN;
1435	}
1436
1437	PP(pp_seek)
1438	{
1439	return pp_sysseek(ARGS);
1440	}
1441
1442	PP(pp_sysseek)
1443	{
1444	dSP;
1445	GV *gv;
1446	int whence = POPi;
1447	long offset = POPl;
1448
1449	gv = last_in_gv = (GV*)POPs;
1450	if (op->op_type == OP_SEEK)
1451	PUSHs(boolSV(do_seek(gv, offset, whence)));
1452	else {
1453	long n = do_sysseek(gv, offset, whence);
1454	PUSHs((n < 0) ? &sv_undef
1455	: sv_2mortal(n ? newSViv((IV)n)
1456	: newSVpv(zero_but_true, ZBTLEN)));
1457	}
1458	RETURN;
1459	}
1460
1461	PP(pp_truncate)
1462	{
1463	dSP;
1464	Off_t len = (Off_t)POPn;
1465	int result = 1;
1466	GV *tmpgv;
1467
1468	SETERRNO(0,0);
1469	#if defined(HAS_TRUNCATE) \|\| defined(HAS_CHSIZE) \|\| defined(F_FREESP)
1470	if (op->op_flags & OPf_SPECIAL) {
1471	tmpgv = gv_fetchpv(POPp, FALSE, SVt_PVIO);
1472	do_ftruncate:
1473	TAINT_PROPER("truncate");
1474	if (!GvIO(tmpgv) \|\| !IoIFP(GvIOp(tmpgv)) \|\|
1475	#ifdef HAS_TRUNCATE
1476	ftruncate(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
1477	#else
1478	my_chsize(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
1479	#endif
1480	result = 0;
1481	}
1482	else {
1483	SV *sv = POPs;
1484	char *name;
1485
1486	if (SvTYPE(sv) == SVt_PVGV) {
1487	tmpgv = (GV)sv; / main::FRED for example /
1488	goto do_ftruncate;
1489	}
1490	else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
1491	tmpgv = (GV) SvRV(sv); / \main::FRED for example /
1492	goto do_ftruncate;
1493	}
1494
1495	name = SvPV(sv, na);
1496	TAINT_PROPER("truncate");
1497	#ifdef HAS_TRUNCATE
1498	if (truncate(name, len) < 0)
1499	result = 0;
1500	#else
1501	{
1502	int tmpfd;
1503	if ((tmpfd = open(name, O_RDWR)) < 0)
1504	result = 0;
1505	else {
1506	if (my_chsize(tmpfd, len) < 0)
1507	result = 0;
1508	close(tmpfd);
1509	}
1510	}
1511	#endif
1512	}
1513
1514	if (result)
1515	RETPUSHYES;
1516	if (!errno)
1517	SETERRNO(EBADF,RMS$_IFI);
1518	RETPUSHUNDEF;
1519	#else
1520	DIE("truncate not implemented");
1521	#endif
1522	}
1523
1524	PP(pp_fcntl)
1525	{
1526	return pp_ioctl(ARGS);
1527	}
1528
1529	PP(pp_ioctl)
1530	{
1531	dSP; dTARGET;
1532	SV *argsv = POPs;
1533	unsigned int func = U_I(POPn);
1534	int optype = op->op_type;
1535	char *s;
1536	IV retval;
1537	GV gv = (GV)POPs;
1538	IO *io = GvIOn(gv);
1539
1540	if (!io \|\| !argsv \|\| !IoIFP(io)) {
1541	SETERRNO(EBADF,RMS$_IFI); /* well, sort of... */
1542	RETPUSHUNDEF;
1543	}
1544
1545	if (SvPOK(argsv) \|\| !SvNIOK(argsv)) {
1546	STRLEN len;
1547	STRLEN need;
1548	s = SvPV_force(argsv, len);
1549	need = IOCPARM_LEN(func);
1550	if (len < need) {
1551	s = Sv_Grow(argsv, need + 1);
1552	SvCUR_set(argsv, need);
1553	}
1554
1555	s[SvCUR(argsv)] = 17; /* a little sanity check here */
1556	}
1557	else {
1558	retval = SvIV(argsv);
1559	s = (char)retval; / ouch */
1560	}
1561
1562	TAINT_PROPER(optype == OP_IOCTL ? "ioctl" : "fcntl");
1563
1564	if (optype == OP_IOCTL)
1565	#ifdef HAS_IOCTL
1566	retval = ioctl(PerlIO_fileno(IoIFP(io)), func, s);
1567	#else
1568	DIE("ioctl is not implemented");
1569	#endif
1570	else
1571	#ifdef HAS_FCNTL
1572	#if defined(OS2) && defined(__EMX__)
1573	retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
1574	#else
1575	retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
1576	#endif
1577	#else
1578	DIE("fcntl is not implemented");
1579	#endif
1580
1581	if (SvPOK(argsv)) {
1582	if (s[SvCUR(argsv)] != 17)
1583	DIE("Possible memory corruption: %s overflowed 3rd argument",
1584	op_name[optype]);
1585	s[SvCUR(argsv)] = 0; /* put our null back */
1586	SvSETMAGIC(argsv); /* Assume it has changed */
1587	}
1588
1589	if (retval == -1)
1590	RETPUSHUNDEF;
1591	if (retval != 0) {
1592	PUSHi(retval);
1593	}
1594	else {
1595	PUSHp(zero_but_true, ZBTLEN);
1596	}
1597	RETURN;
1598	}
1599
1600	PP(pp_flock)
1601	{
1602	dSP; dTARGET;
1603	I32 value;
1604	int argtype;
1605	GV *gv;
1606	PerlIO *fp;
1607
1608	#ifdef FLOCK
1609	argtype = POPi;
1610	if (MAXARG <= 0)
1611	gv = last_in_gv;
1612	else
1613	gv = (GV*)POPs;
1614	if (gv && GvIO(gv))
1615	fp = IoIFP(GvIOp(gv));
1616	else
1617	fp = Nullfp;
1618	if (fp) {
1619	(void)PerlIO_flush(fp);
1620	value = (I32)(FLOCK(PerlIO_fileno(fp), argtype) >= 0);
1621	}
1622	else
1623	value = 0;
1624	PUSHi(value);
1625	RETURN;
1626	#else
1627	DIE(no_func, "flock()");
1628	#endif
1629	}
1630
1631	/* Sockets. */
1632
1633	PP(pp_socket)
1634	{
1635	dSP;
1636	#ifdef HAS_SOCKET
1637	GV *gv;
1638	register IO *io;
1639	int protocol = POPi;
1640	int type = POPi;
1641	int domain = POPi;
1642	int fd;
1643
1644	gv = (GV*)POPs;
1645
1646	if (!gv) {
1647	SETERRNO(EBADF,LIB$_INVARG);
1648	RETPUSHUNDEF;
1649	}
1650
1651	io = GvIOn(gv);
1652	if (IoIFP(io))
1653	do_close(gv, FALSE);
1654
1655	TAINT_PROPER("socket");
1656	fd = socket(domain, type, protocol);
1657	if (fd < 0)
1658	RETPUSHUNDEF;
1659	IoIFP(io) = PerlIO_fdopen(fd, "r"); /* stdio gets confused about sockets */
1660	IoOFP(io) = PerlIO_fdopen(fd, "w");
1661	IoTYPE(io) = 's';
1662	if (!IoIFP(io) \|\| !IoOFP(io)) {
1663	if (IoIFP(io)) PerlIO_close(IoIFP(io));
1664	if (IoOFP(io)) PerlIO_close(IoOFP(io));
1665	if (!IoIFP(io) && !IoOFP(io)) close(fd);
1666	RETPUSHUNDEF;
1667	}
1668
1669	RETPUSHYES;
1670	#else
1671	DIE(no_sock_func, "socket");
1672	#endif
1673	}
1674
1675	PP(pp_sockpair)
1676	{
1677	dSP;
1678	#ifdef HAS_SOCKETPAIR
1679	GV *gv1;
1680	GV *gv2;
1681	register IO *io1;
1682	register IO *io2;
1683	int protocol = POPi;
1684	int type = POPi;
1685	int domain = POPi;
1686	int fd[2];
1687
1688	gv2 = (GV*)POPs;
1689	gv1 = (GV*)POPs;
1690	if (!gv1 \|\| !gv2)
1691	RETPUSHUNDEF;
1692
1693	io1 = GvIOn(gv1);
1694	io2 = GvIOn(gv2);
1695	if (IoIFP(io1))
1696	do_close(gv1, FALSE);
1697	if (IoIFP(io2))
1698	do_close(gv2, FALSE);
1699
1700	TAINT_PROPER("socketpair");
1701	if (socketpair(domain, type, protocol, fd) < 0)
1702	RETPUSHUNDEF;
1703	IoIFP(io1) = PerlIO_fdopen(fd[0], "r");
1704	IoOFP(io1) = PerlIO_fdopen(fd[0], "w");
1705	IoTYPE(io1) = 's';
1706	IoIFP(io2) = PerlIO_fdopen(fd[1], "r");
1707	IoOFP(io2) = PerlIO_fdopen(fd[1], "w");
1708	IoTYPE(io2) = 's';
1709	if (!IoIFP(io1) \|\| !IoOFP(io1) \|\| !IoIFP(io2) \|\| !IoOFP(io2)) {
1710	if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
1711	if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
1712	if (!IoIFP(io1) && !IoOFP(io1)) close(fd[0]);
1713	if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
1714	if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
1715	if (!IoIFP(io2) && !IoOFP(io2)) close(fd[1]);
1716	RETPUSHUNDEF;
1717	}
1718
1719	RETPUSHYES;
1720	#else
1721	DIE(no_sock_func, "socketpair");
1722	#endif
1723	}
1724
1725	PP(pp_bind)
1726	{
1727	dSP;
1728	#ifdef HAS_SOCKET
1729	SV *addrsv = POPs;
1730	char *addr;
1731	GV gv = (GV)POPs;
1732	register IO *io = GvIOn(gv);
1733	STRLEN len;
1734
1735	if (!io \|\| !IoIFP(io))
1736	goto nuts;
1737
1738	addr = SvPV(addrsv, len);
1739	TAINT_PROPER("bind");
1740	if (bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
1741	RETPUSHYES;
1742	else
1743	RETPUSHUNDEF;
1744
1745	nuts:
1746	if (dowarn)
1747	warn("bind() on closed fd");
1748	SETERRNO(EBADF,SS$_IVCHAN);
1749	RETPUSHUNDEF;
1750	#else
1751	DIE(no_sock_func, "bind");
1752	#endif
1753	}
1754
1755	PP(pp_connect)
1756	{
1757	dSP;
1758	#ifdef HAS_SOCKET
1759	SV *addrsv = POPs;
1760	char *addr;
1761	GV gv = (GV)POPs;
1762	register IO *io = GvIOn(gv);
1763	STRLEN len;
1764
1765	if (!io \|\| !IoIFP(io))
1766	goto nuts;
1767
1768	addr = SvPV(addrsv, len);
1769	TAINT_PROPER("connect");
1770	if (connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
1771	RETPUSHYES;
1772	else
1773	RETPUSHUNDEF;
1774
1775	nuts:
1776	if (dowarn)
1777	warn("connect() on closed fd");
1778	SETERRNO(EBADF,SS$_IVCHAN);
1779	RETPUSHUNDEF;
1780	#else
1781	DIE(no_sock_func, "connect");
1782	#endif
1783	}
1784
1785	PP(pp_listen)
1786	{
1787	dSP;
1788	#ifdef HAS_SOCKET
1789	int backlog = POPi;
1790	GV gv = (GV)POPs;
1791	register IO *io = GvIOn(gv);
1792
1793	if (!io \|\| !IoIFP(io))
1794	goto nuts;
1795
1796	if (listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
1797	RETPUSHYES;
1798	else
1799	RETPUSHUNDEF;
1800
1801	nuts:
1802	if (dowarn)
1803	warn("listen() on closed fd");
1804	SETERRNO(EBADF,SS$_IVCHAN);
1805	RETPUSHUNDEF;
1806	#else
1807	DIE(no_sock_func, "listen");
1808	#endif
1809	}
1810
1811	PP(pp_accept)
1812	{
1813	dSP; dTARGET;
1814	#ifdef HAS_SOCKET
1815	GV *ngv;
1816	GV *ggv;
1817	register IO *nstio;
1818	register IO *gstio;
1819	struct sockaddr saddr; /* use a struct to avoid alignment problems */
1820	Sock_size_t len = sizeof saddr;
1821	int fd;
1822
1823	ggv = (GV*)POPs;
1824	ngv = (GV*)POPs;
1825
1826	if (!ngv)
1827	goto badexit;
1828	if (!ggv)
1829	goto nuts;
1830
1831	gstio = GvIO(ggv);
1832	if (!gstio \|\| !IoIFP(gstio))
1833	goto nuts;
1834
1835	nstio = GvIOn(ngv);
1836	if (IoIFP(nstio))
1837	do_close(ngv, FALSE);
1838
1839	fd = accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *)&saddr, &len);
1840	if (fd < 0)
1841	goto badexit;
1842	IoIFP(nstio) = PerlIO_fdopen(fd, "r");
1843	IoOFP(nstio) = PerlIO_fdopen(fd, "w");
1844	IoTYPE(nstio) = 's';
1845	if (!IoIFP(nstio) \|\| !IoOFP(nstio)) {
1846	if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
1847	if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
1848	if (!IoIFP(nstio) && !IoOFP(nstio)) close(fd);
1849	goto badexit;
1850	}
1851
1852	PUSHp((char *)&saddr, len);
1853	RETURN;
1854
1855	nuts:
1856	if (dowarn)
1857	warn("accept() on closed fd");
1858	SETERRNO(EBADF,SS$_IVCHAN);
1859
1860	badexit:
1861	RETPUSHUNDEF;
1862
1863	#else
1864	DIE(no_sock_func, "accept");
1865	#endif
1866	}
1867
1868	PP(pp_shutdown)
1869	{
1870	dSP; dTARGET;
1871	#ifdef HAS_SOCKET
1872	int how = POPi;
1873	GV gv = (GV)POPs;
1874	register IO *io = GvIOn(gv);
1875
1876	if (!io \|\| !IoIFP(io))
1877	goto nuts;
1878
1879	PUSHi( shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
1880	RETURN;
1881
1882	nuts:
1883	if (dowarn)
1884	warn("shutdown() on closed fd");
1885	SETERRNO(EBADF,SS$_IVCHAN);
1886	RETPUSHUNDEF;
1887	#else
1888	DIE(no_sock_func, "shutdown");
1889	#endif
1890	}
1891
1892	PP(pp_gsockopt)
1893	{
1894	#ifdef HAS_SOCKET
1895	return pp_ssockopt(ARGS);
1896	#else
1897	DIE(no_sock_func, "getsockopt");
1898	#endif
1899	}
1900
1901	PP(pp_ssockopt)
1902	{
1903	dSP;
1904	#ifdef HAS_SOCKET
1905	int optype = op->op_type;
1906	SV *sv;
1907	int fd;
1908	unsigned int optname;
1909	unsigned int lvl;
1910	GV *gv;
1911	register IO *io;
1912	Sock_size_t len;
1913
1914	if (optype == OP_GSOCKOPT)
1915	sv = sv_2mortal(NEWSV(22, 257));
1916	else
1917	sv = POPs;
1918	optname = (unsigned int) POPi;
1919	lvl = (unsigned int) POPi;
1920
1921	gv = (GV*)POPs;
1922	io = GvIOn(gv);
1923	if (!io \|\| !IoIFP(io))
1924	goto nuts;
1925
1926	fd = PerlIO_fileno(IoIFP(io));
1927	switch (optype) {
1928	case OP_GSOCKOPT:
1929	SvGROW(sv, 257);
1930	(void)SvPOK_only(sv);
1931	SvCUR_set(sv,256);
1932	*SvEND(sv) ='\0';
1933	len = SvCUR(sv);
1934	if (getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
1935	goto nuts2;
1936	SvCUR_set(sv, len);
1937	*SvEND(sv) ='\0';
1938	PUSHs(sv);
1939	break;
1940	case OP_SSOCKOPT: {
1941	char *buf;
1942	int aint;
1943	if (SvPOKp(sv)) {
1944	buf = SvPV(sv, na);
1945	len = na;
1946	}
1947	else if (SvOK(sv)) {
1948	aint = (int)SvIV(sv);
1949	buf = (char*)&aint;
1950	len = sizeof(int);
1951	}
1952	if (setsockopt(fd, lvl, optname, buf, len) < 0)
1953	goto nuts2;
1954	PUSHs(&sv_yes);
1955	}
1956	break;
1957	}
1958	RETURN;
1959
1960	nuts:
1961	if (dowarn)
1962	warn("[gs]etsockopt() on closed fd");
1963	SETERRNO(EBADF,SS$_IVCHAN);
1964	nuts2:
1965	RETPUSHUNDEF;
1966
1967	#else
1968	DIE(no_sock_func, "setsockopt");
1969	#endif
1970	}
1971
1972	PP(pp_getsockname)
1973	{
1974	#ifdef HAS_SOCKET
1975	return pp_getpeername(ARGS);
1976	#else
1977	DIE(no_sock_func, "getsockname");
1978	#endif
1979	}
1980
1981	PP(pp_getpeername)
1982	{
1983	dSP;
1984	#ifdef HAS_SOCKET
1985	int optype = op->op_type;
1986	SV *sv;
1987	int fd;
1988	GV gv = (GV)POPs;
1989	register IO *io = GvIOn(gv);
1990	Sock_size_t len;
1991
1992	if (!io \|\| !IoIFP(io))
1993	goto nuts;
1994
1995	sv = sv_2mortal(NEWSV(22, 257));
1996	(void)SvPOK_only(sv);
1997	len = 256;
1998	SvCUR_set(sv, len);
1999	*SvEND(sv) ='\0';
2000	fd = PerlIO_fileno(IoIFP(io));
2001	switch (optype) {
2002	case OP_GETSOCKNAME:
2003	if (getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2004	goto nuts2;
2005	break;
2006	case OP_GETPEERNAME:
2007	if (getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2008	goto nuts2;
2009	#if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2010	{
2011	static const char nowhere[] = "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0";
2012	/* If the call succeeded, make sure we don't have a zeroed port/addr */
2013	if (((struct sockaddr *)SvPVX(sv))->sa_family == AF_INET &&
2014	!memcmp((char *)SvPVX(sv) + sizeof(u_short), nowhere,
2015	sizeof(u_short) + sizeof(struct in_addr))) {
2016	goto nuts2;
2017	}
2018	}
2019	#endif
2020	break;
2021	}
2022	#ifdef BOGUS_GETNAME_RETURN
2023	/* Interactive Unix, getpeername() and getsockname()
2024	does not return valid namelen */
2025	if (len == BOGUS_GETNAME_RETURN)
2026	len = sizeof(struct sockaddr);
2027	#endif
2028	SvCUR_set(sv, len);
2029	*SvEND(sv) ='\0';
2030	PUSHs(sv);
2031	RETURN;
2032
2033	nuts:
2034	if (dowarn)
2035	warn("get{sock, peer}name() on closed fd");
2036	SETERRNO(EBADF,SS$_IVCHAN);
2037	nuts2:
2038	RETPUSHUNDEF;
2039
2040	#else
2041	DIE(no_sock_func, "getpeername");
2042	#endif
2043	}
2044
2045	/* Stat calls. */
2046
2047	PP(pp_lstat)
2048	{
2049	return pp_stat(ARGS);
2050	}
2051
2052	PP(pp_stat)
2053	{
2054	dSP;
2055	GV *tmpgv;
2056	I32 gimme;
2057	I32 max = 13;
2058
2059	if (op->op_flags & OPf_REF) {
2060	tmpgv = cGVOP->op_gv;
2061	do_fstat:
2062	if (tmpgv != defgv) {
2063	laststype = OP_STAT;
2064	statgv = tmpgv;
2065	sv_setpv(statname, "");
2066	laststatval = (GvIO(tmpgv) && IoIFP(GvIOp(tmpgv))
2067	? Fstat(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), &statcache) : -1);
2068	}
2069	if (laststatval < 0)
2070	max = 0;
2071	}
2072	else {
2073	SV* sv = POPs;
2074	if (SvTYPE(sv) == SVt_PVGV) {
2075	tmpgv = (GV*)sv;
2076	goto do_fstat;
2077	}
2078	else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2079	tmpgv = (GV*)SvRV(sv);
2080	goto do_fstat;
2081	}
2082	sv_setpv(statname, SvPV(sv,na));
2083	statgv = Nullgv;
2084	#ifdef HAS_LSTAT
2085	laststype = op->op_type;
2086	if (op->op_type == OP_LSTAT)
2087	laststatval = lstat(SvPV(statname, na), &statcache);
2088	else
2089	#endif
2090	laststatval = Stat(SvPV(statname, na), &statcache);
2091	if (laststatval < 0) {
2092	if (dowarn && strchr(SvPV(statname, na), '\n'))
2093	warn(warn_nl, "stat");
2094	max = 0;
2095	}
2096	}
2097
2098	gimme = GIMME_V;
2099	if (gimme != G_ARRAY) {
2100	if (gimme != G_VOID)
2101	XPUSHs(boolSV(max));
2102	RETURN;
2103	}
2104	if (max) {
2105	EXTEND(SP, max);
2106	EXTEND_MORTAL(max);
2107	PUSHs(sv_2mortal(newSViv((I32)statcache.st_dev)));
2108	PUSHs(sv_2mortal(newSViv((I32)statcache.st_ino)));
2109	PUSHs(sv_2mortal(newSViv((I32)statcache.st_mode)));
2110	PUSHs(sv_2mortal(newSViv((I32)statcache.st_nlink)));
2111	PUSHs(sv_2mortal(newSViv((I32)statcache.st_uid)));
2112	PUSHs(sv_2mortal(newSViv((I32)statcache.st_gid)));
2113	#ifdef USE_STAT_RDEV
2114	PUSHs(sv_2mortal(newSViv((I32)statcache.st_rdev)));
2115	#else
2116	PUSHs(sv_2mortal(newSVpv("", 0)));
2117	#endif
2118	PUSHs(sv_2mortal(newSViv((I32)statcache.st_size)));
2119	#ifdef BIG_TIME
2120	PUSHs(sv_2mortal(newSVnv((U32)statcache.st_atime)));
2121	PUSHs(sv_2mortal(newSVnv((U32)statcache.st_mtime)));
2122	PUSHs(sv_2mortal(newSVnv((U32)statcache.st_ctime)));
2123	#else
2124	PUSHs(sv_2mortal(newSViv((I32)statcache.st_atime)));
2125	PUSHs(sv_2mortal(newSViv((I32)statcache.st_mtime)));
2126	PUSHs(sv_2mortal(newSViv((I32)statcache.st_ctime)));
2127	#endif
2128	#ifdef USE_STAT_BLOCKS
2129	PUSHs(sv_2mortal(newSViv((I32)statcache.st_blksize)));
2130	PUSHs(sv_2mortal(newSViv((I32)statcache.st_blocks)));
2131	#else
2132	PUSHs(sv_2mortal(newSVpv("", 0)));
2133	PUSHs(sv_2mortal(newSVpv("", 0)));
2134	#endif
2135	}
2136	RETURN;
2137	}
2138
2139	PP(pp_ftrread)
2140	{
2141	I32 result = my_stat(ARGS);
2142	dSP;
2143	if (result < 0)
2144	RETPUSHUNDEF;
2145	if (cando(S_IRUSR, 0, &statcache))
2146	RETPUSHYES;
2147	RETPUSHNO;
2148	}
2149
2150	PP(pp_ftrwrite)
2151	{
2152	I32 result = my_stat(ARGS);
2153	dSP;
2154	if (result < 0)
2155	RETPUSHUNDEF;
2156	if (cando(S_IWUSR, 0, &statcache))
2157	RETPUSHYES;
2158	RETPUSHNO;
2159	}
2160
2161	PP(pp_ftrexec)
2162	{
2163	I32 result = my_stat(ARGS);
2164	dSP;
2165	if (result < 0)
2166	RETPUSHUNDEF;
2167	if (cando(S_IXUSR, 0, &statcache))
2168	RETPUSHYES;
2169	RETPUSHNO;
2170	}
2171
2172	PP(pp_fteread)
2173	{
2174	I32 result = my_stat(ARGS);
2175	dSP;
2176	if (result < 0)
2177	RETPUSHUNDEF;
2178	if (cando(S_IRUSR, 1, &statcache))
2179	RETPUSHYES;
2180	RETPUSHNO;
2181	}
2182
2183	PP(pp_ftewrite)
2184	{
2185	I32 result = my_stat(ARGS);
2186	dSP;
2187	if (result < 0)
2188	RETPUSHUNDEF;
2189	if (cando(S_IWUSR, 1, &statcache))
2190	RETPUSHYES;
2191	RETPUSHNO;
2192	}
2193
2194	PP(pp_fteexec)
2195	{
2196	I32 result = my_stat(ARGS);
2197	dSP;
2198	if (result < 0)
2199	RETPUSHUNDEF;
2200	if (cando(S_IXUSR, 1, &statcache))
2201	RETPUSHYES;
2202	RETPUSHNO;
2203	}
2204
2205	PP(pp_ftis)
2206	{
2207	I32 result = my_stat(ARGS);
2208	dSP;
2209	if (result < 0)
2210	RETPUSHUNDEF;
2211	RETPUSHYES;
2212	}
2213
2214	PP(pp_fteowned)
2215	{
2216	return pp_ftrowned(ARGS);
2217	}
2218
2219	PP(pp_ftrowned)
2220	{
2221	I32 result = my_stat(ARGS);
2222	dSP;
2223	if (result < 0)
2224	RETPUSHUNDEF;
2225	if (statcache.st_uid == (op->op_type == OP_FTEOWNED ? euid : uid) )
2226	RETPUSHYES;
2227	RETPUSHNO;
2228	}
2229
2230	PP(pp_ftzero)
2231	{
2232	I32 result = my_stat(ARGS);
2233	dSP;
2234	if (result < 0)
2235	RETPUSHUNDEF;
2236	if (!statcache.st_size)
2237	RETPUSHYES;
2238	RETPUSHNO;
2239	}
2240
2241	PP(pp_ftsize)
2242	{
2243	I32 result = my_stat(ARGS);
2244	dSP; dTARGET;
2245	if (result < 0)
2246	RETPUSHUNDEF;
2247	PUSHi(statcache.st_size);
2248	RETURN;
2249	}
2250
2251	PP(pp_ftmtime)
2252	{
2253	I32 result = my_stat(ARGS);
2254	dSP; dTARGET;
2255	if (result < 0)
2256	RETPUSHUNDEF;
2257	PUSHn( ((I32)basetime - (I32)statcache.st_mtime) / 86400.0 );
2258	RETURN;
2259	}
2260
2261	PP(pp_ftatime)
2262	{
2263	I32 result = my_stat(ARGS);
2264	dSP; dTARGET;
2265	if (result < 0)
2266	RETPUSHUNDEF;
2267	PUSHn( ((I32)basetime - (I32)statcache.st_atime) / 86400.0 );
2268	RETURN;
2269	}
2270
2271	PP(pp_ftctime)
2272	{
2273	I32 result = my_stat(ARGS);
2274	dSP; dTARGET;
2275	if (result < 0)
2276	RETPUSHUNDEF;
2277	PUSHn( ((I32)basetime - (I32)statcache.st_ctime) / 86400.0 );
2278	RETURN;
2279	}
2280
2281	PP(pp_ftsock)
2282	{
2283	I32 result = my_stat(ARGS);
2284	dSP;
2285	if (result < 0)
2286	RETPUSHUNDEF;
2287	if (S_ISSOCK(statcache.st_mode))
2288	RETPUSHYES;
2289	RETPUSHNO;
2290	}
2291
2292	PP(pp_ftchr)
2293	{
2294	I32 result = my_stat(ARGS);
2295	dSP;
2296	if (result < 0)
2297	RETPUSHUNDEF;
2298	if (S_ISCHR(statcache.st_mode))
2299	RETPUSHYES;
2300	RETPUSHNO;
2301	}
2302
2303	PP(pp_ftblk)
2304	{
2305	I32 result = my_stat(ARGS);
2306	dSP;
2307	if (result < 0)
2308	RETPUSHUNDEF;
2309	if (S_ISBLK(statcache.st_mode))
2310	RETPUSHYES;
2311	RETPUSHNO;
2312	}
2313
2314	PP(pp_ftfile)
2315	{
2316	I32 result = my_stat(ARGS);
2317	dSP;
2318	if (result < 0)
2319	RETPUSHUNDEF;
2320	if (S_ISREG(statcache.st_mode))
2321	RETPUSHYES;
2322	RETPUSHNO;
2323	}
2324
2325	PP(pp_ftdir)
2326	{
2327	I32 result = my_stat(ARGS);
2328	dSP;
2329	if (result < 0)
2330	RETPUSHUNDEF;
2331	if (S_ISDIR(statcache.st_mode))
2332	RETPUSHYES;
2333	RETPUSHNO;
2334	}
2335
2336	PP(pp_ftpipe)
2337	{
2338	I32 result = my_stat(ARGS);
2339	dSP;
2340	if (result < 0)
2341	RETPUSHUNDEF;
2342	if (S_ISFIFO(statcache.st_mode))
2343	RETPUSHYES;
2344	RETPUSHNO;
2345	}
2346
2347	PP(pp_ftlink)
2348	{
2349	I32 result = my_lstat(ARGS);
2350	dSP;
2351	if (result < 0)
2352	RETPUSHUNDEF;
2353	if (S_ISLNK(statcache.st_mode))
2354	RETPUSHYES;
2355	RETPUSHNO;
2356	}
2357
2358	PP(pp_ftsuid)
2359	{
2360	dSP;
2361	#ifdef S_ISUID
2362	I32 result = my_stat(ARGS);
2363	SPAGAIN;
2364	if (result < 0)
2365	RETPUSHUNDEF;
2366	if (statcache.st_mode & S_ISUID)
2367	RETPUSHYES;
2368	#endif
2369	RETPUSHNO;
2370	}
2371
2372	PP(pp_ftsgid)
2373	{
2374	dSP;
2375	#ifdef S_ISGID
2376	I32 result = my_stat(ARGS);
2377	SPAGAIN;
2378	if (result < 0)
2379	RETPUSHUNDEF;
2380	if (statcache.st_mode & S_ISGID)
2381	RETPUSHYES;
2382	#endif
2383	RETPUSHNO;
2384	}
2385
2386	PP(pp_ftsvtx)
2387	{
2388	dSP;
2389	#ifdef S_ISVTX
2390	I32 result = my_stat(ARGS);
2391	SPAGAIN;
2392	if (result < 0)
2393	RETPUSHUNDEF;
2394	if (statcache.st_mode & S_ISVTX)
2395	RETPUSHYES;
2396	#endif
2397	RETPUSHNO;
2398	}
2399
2400	PP(pp_fttty)
2401	{
2402	dSP;
2403	int fd;
2404	GV *gv;
2405	char *tmps = Nullch;
2406
2407	if (op->op_flags & OPf_REF)
2408	gv = cGVOP->op_gv;
2409	else if (isGV(TOPs))
2410	gv = (GV*)POPs;
2411	else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
2412	gv = (GV*)SvRV(POPs);
2413	else
2414	gv = gv_fetchpv(tmps = POPp, FALSE, SVt_PVIO);
2415
2416	if (GvIO(gv) && IoIFP(GvIOp(gv)))
2417	fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
2418	else if (tmps && isDIGIT(*tmps))
2419	fd = atoi(tmps);
2420	else
2421	RETPUSHUNDEF;
2422	if (isatty(fd))
2423	RETPUSHYES;
2424	RETPUSHNO;
2425	}
2426
2427	#if defined(atarist) /* this will work with atariST. Configure will
2428	make guesses for other systems. */
2429	# define FILE_base(f) ((f)->_base)
2430	# define FILE_ptr(f) ((f)->_ptr)
2431	# define FILE_cnt(f) ((f)->_cnt)
2432	# define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
2433	#endif
2434
2435	PP(pp_fttext)
2436	{
2437	dSP;
2438	I32 i;
2439	I32 len;
2440	I32 odd = 0;
2441	STDCHAR tbuf[512];
2442	register STDCHAR *s;
2443	register IO *io;
2444	register SV *sv;
2445	GV *gv;
2446
2447	if (op->op_flags & OPf_REF)
2448	gv = cGVOP->op_gv;
2449	else if (isGV(TOPs))
2450	gv = (GV*)POPs;
2451	else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
2452	gv = (GV*)SvRV(POPs);
2453	else
2454	gv = Nullgv;
2455
2456	if (gv) {
2457	EXTEND(SP, 1);
2458	if (gv == defgv) {
2459	if (statgv)
2460	io = GvIO(statgv);
2461	else {
2462	sv = statname;
2463	goto really_filename;
2464	}
2465	}
2466	else {
2467	statgv = gv;
2468	laststatval = -1;
2469	sv_setpv(statname, "");
2470	io = GvIO(statgv);
2471	}
2472	if (io && IoIFP(io)) {
2473	if (! PerlIO_has_base(IoIFP(io)))
2474	DIE("-T and -B not implemented on filehandles");
2475	laststatval = Fstat(PerlIO_fileno(IoIFP(io)), &statcache);
2476	if (laststatval < 0)
2477	RETPUSHUNDEF;
2478	if (S_ISDIR(statcache.st_mode)) /* handle NFS glitch */
2479	if (op->op_type == OP_FTTEXT)
2480	RETPUSHNO;
2481	else
2482	RETPUSHYES;
2483	if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
2484	i = PerlIO_getc(IoIFP(io));
2485	if (i != EOF)
2486	(void)PerlIO_ungetc(IoIFP(io),i);
2487	}
2488	if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
2489	RETPUSHYES;
2490	len = PerlIO_get_bufsiz(IoIFP(io));
2491	s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
2492	/* sfio can have large buffers - limit to 512 */
2493	if (len > 512)
2494	len = 512;
2495	}
2496	else {
2497	if (dowarn)
2498	warn("Test on unopened file <%s>",
2499	GvENAME(cGVOP->op_gv));
2500	SETERRNO(EBADF,RMS$_IFI);
2501	RETPUSHUNDEF;
2502	}
2503	}
2504	else {
2505	sv = POPs;
2506	really_filename:
2507	statgv = Nullgv;
2508	laststatval = -1;
2509	sv_setpv(statname, SvPV(sv, na));
2510	#ifdef HAS_OPEN3
2511	i = open(SvPV(sv, na), O_RDONLY, 0);
2512	#else
2513	i = open(SvPV(sv, na), 0);
2514	#endif
2515	if (i < 0) {
2516	if (dowarn && strchr(SvPV(sv, na), '\n'))
2517	warn(warn_nl, "open");
2518	RETPUSHUNDEF;
2519	}
2520	laststatval = Fstat(i, &statcache);
2521	if (laststatval < 0)
2522	RETPUSHUNDEF;
2523	len = read(i, tbuf, 512);
2524	(void)close(i);
2525	if (len <= 0) {
2526	if (S_ISDIR(statcache.st_mode) && op->op_type == OP_FTTEXT)
2527	RETPUSHNO; /* special case NFS directories */
2528	RETPUSHYES; /* null file is anything */
2529	}
2530	s = tbuf;
2531	}
2532
2533	/* now scan s to look for textiness */
2534	/* XXX ASCII dependent code */
2535
2536	for (i = 0; i < len; i++, s++) {
2537	if (!s) { / null never allowed in text */
2538	odd += len;
2539	break;
2540	}
2541	else if (*s & 128)
2542	odd++;
2543	else if (*s < 32 &&
2544	s != '\n' && s != '\r' && *s != '\b' &&
2545	s != '\t' && s != '\f' && *s != 27)
2546	odd++;
2547	}
2548
2549	if ((odd * 3 > len) == (op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
2550	RETPUSHNO;
2551	else
2552	RETPUSHYES;
2553	}
2554
2555	PP(pp_ftbinary)
2556	{
2557	return pp_fttext(ARGS);
2558	}
2559
2560	/* File calls. */
2561
2562	PP(pp_chdir)
2563	{
2564	dSP; dTARGET;
2565	char *tmps;
2566	SV **svp;
2567
2568	if (MAXARG < 1)
2569	tmps = Nullch;
2570	else
2571	tmps = POPp;
2572	if (!tmps \|\| !*tmps) {
2573	svp = hv_fetch(GvHVn(envgv), "HOME", 4, FALSE);
2574	if (svp)
2575	tmps = SvPV(*svp, na);
2576	}
2577	if (!tmps \|\| !*tmps) {
2578	svp = hv_fetch(GvHVn(envgv), "LOGDIR", 6, FALSE);
2579	if (svp)
2580	tmps = SvPV(*svp, na);
2581	}
2582	TAINT_PROPER("chdir");
2583	PUSHi( chdir(tmps) >= 0 );
2584	#ifdef VMS
2585	/* Clear the DEFAULT element of ENV so we'll get the new value
2586	* in the future. */
2587	hv_delete(GvHVn(envgv),"DEFAULT",7,G_DISCARD);
2588	#endif
2589	RETURN;
2590	}
2591
2592	PP(pp_chown)
2593	{
2594	dSP; dMARK; dTARGET;
2595	I32 value;
2596	#ifdef HAS_CHOWN
2597	value = (I32)apply(op->op_type, MARK, SP);
2598	SP = MARK;
2599	PUSHi(value);
2600	RETURN;
2601	#else
2602	DIE(no_func, "Unsupported function chown");
2603	#endif
2604	}
2605
2606	PP(pp_chroot)
2607	{
2608	dSP; dTARGET;
2609	char *tmps;
2610	#ifdef HAS_CHROOT
2611	tmps = POPp;
2612	TAINT_PROPER("chroot");
2613	PUSHi( chroot(tmps) >= 0 );
2614	RETURN;
2615	#else
2616	DIE(no_func, "chroot");
2617	#endif
2618	}
2619
2620	PP(pp_unlink)
2621	{
2622	dSP; dMARK; dTARGET;
2623	I32 value;
2624	value = (I32)apply(op->op_type, MARK, SP);
2625	SP = MARK;
2626	PUSHi(value);
2627	RETURN;
2628	}
2629
2630	PP(pp_chmod)
2631	{
2632	dSP; dMARK; dTARGET;
2633	I32 value;
2634	value = (I32)apply(op->op_type, MARK, SP);
2635	SP = MARK;
2636	PUSHi(value);
2637	RETURN;
2638	}
2639
2640	PP(pp_utime)
2641	{
2642	dSP; dMARK; dTARGET;
2643	I32 value;
2644	value = (I32)apply(op->op_type, MARK, SP);
2645	SP = MARK;
2646	PUSHi(value);
2647	RETURN;
2648	}
2649
2650	PP(pp_rename)
2651	{
2652	dSP; dTARGET;
2653	int anum;
2654
2655	char *tmps2 = POPp;
2656	char *tmps = SvPV(TOPs, na);
2657	TAINT_PROPER("rename");
2658	#ifdef HAS_RENAME
2659	anum = rename(tmps, tmps2);
2660	#else
2661	if (!(anum = Stat(tmps, &statbuf))) {
2662	if (same_dirent(tmps2, tmps)) /* can always rename to same name */
2663	anum = 1;
2664	else {
2665	if (euid \|\| Stat(tmps2, &statbuf) < 0 \|\| !S_ISDIR(statbuf.st_mode))
2666	(void)UNLINK(tmps2);
2667	if (!(anum = link(tmps, tmps2)))
2668	anum = UNLINK(tmps);
2669	}
2670	}
2671	#endif
2672	SETi( anum >= 0 );
2673	RETURN;
2674	}
2675
2676	PP(pp_link)
2677	{
2678	dSP; dTARGET;
2679	#ifdef HAS_LINK
2680	char *tmps2 = POPp;
2681	char *tmps = SvPV(TOPs, na);
2682	TAINT_PROPER("link");
2683	SETi( link(tmps, tmps2) >= 0 );
2684	#else
2685	DIE(no_func, "Unsupported function link");
2686	#endif
2687	RETURN;
2688	}
2689
2690	PP(pp_symlink)
2691	{
2692	dSP; dTARGET;
2693	#ifdef HAS_SYMLINK
2694	char *tmps2 = POPp;
2695	char *tmps = SvPV(TOPs, na);
2696	TAINT_PROPER("symlink");
2697	SETi( symlink(tmps, tmps2) >= 0 );
2698	RETURN;
2699	#else
2700	DIE(no_func, "symlink");
2701	#endif
2702	}
2703
2704	PP(pp_readlink)
2705	{
2706	dSP; dTARGET;
2707	#ifdef HAS_SYMLINK
2708	char *tmps;
2709	char buf[MAXPATHLEN];
2710	int len;
2711
2712	#ifndef INCOMPLETE_TAINTS
2713	TAINT;
2714	#endif
2715	tmps = POPp;
2716	len = readlink(tmps, buf, sizeof buf);
2717	EXTEND(SP, 1);
2718	if (len < 0)
2719	RETPUSHUNDEF;
2720	PUSHp(buf, len);
2721	RETURN;
2722	#else
2723	EXTEND(SP, 1);
2724	RETSETUNDEF; /* just pretend it's a normal file */
2725	#endif
2726	}
2727
2728	#if !defined(HAS_MKDIR) \|\| !defined(HAS_RMDIR)
2729	static int
2730	dooneliner(cmd, filename)
2731	char *cmd;
2732	char *filename;
2733	{
2734	char *save_filename = filename;
2735	char *cmdline;
2736	char *s;
2737	PerlIO *myfp;
2738	int anum = 1;
2739
2740	New(666, cmdline, strlen(cmd) + (strlen(filename) * 2) + 10, char);
2741	strcpy(cmdline, cmd);
2742	strcat(cmdline, " ");
2743	for (s = cmdline + strlen(cmdline); *filename; ) {
2744	*s++ = '\\';
2745	s++ = filename++;
2746	}
2747	strcpy(s, " 2>&1");
2748	myfp = my_popen(cmdline, "r");
2749	Safefree(cmdline);
2750
2751	if (myfp) {
2752	SV *tmpsv = sv_newmortal();
2753	/* Need to save/restore 'rs' ?? */
2754	s = sv_gets(tmpsv, myfp, 0);
2755	(void)my_pclose(myfp);
2756	if (s != Nullch) {
2757	int e;
2758	for (e = 1;
2759	#ifdef HAS_SYS_ERRLIST
2760	e <= sys_nerr
2761	#endif
2762	; e++)
2763	{
2764	/* you don't see this */
2765	char *errmsg =
2766	#ifdef HAS_SYS_ERRLIST
2767	sys_errlist[e]
2768	#else
2769	strerror(e)
2770	#endif
2771	;
2772	if (!errmsg)
2773	break;
2774	if (instr(s, errmsg)) {
2775	SETERRNO(e,0);
2776	return 0;
2777	}
2778	}
2779	SETERRNO(0,0);
2780	#ifndef EACCES
2781	#define EACCES EPERM
2782	#endif
2783	if (instr(s, "cannot make"))
2784	SETERRNO(EEXIST,RMS$_FEX);
2785	else if (instr(s, "existing file"))
2786	SETERRNO(EEXIST,RMS$_FEX);
2787	else if (instr(s, "ile exists"))
2788	SETERRNO(EEXIST,RMS$_FEX);
2789	else if (instr(s, "non-exist"))
2790	SETERRNO(ENOENT,RMS$_FNF);
2791	else if (instr(s, "does not exist"))
2792	SETERRNO(ENOENT,RMS$_FNF);
2793	else if (instr(s, "not empty"))
2794	SETERRNO(EBUSY,SS$_DEVOFFLINE);
2795	else if (instr(s, "cannot access"))
2796	SETERRNO(EACCES,RMS$_PRV);
2797	else
2798	SETERRNO(EPERM,RMS$_PRV);
2799	return 0;
2800	}
2801	else { /* some mkdirs return no failure indication */
2802	anum = (Stat(save_filename, &statbuf) >= 0);
2803	if (op->op_type == OP_RMDIR)
2804	anum = !anum;
2805	if (anum)
2806	SETERRNO(0,0);
2807	else
2808	SETERRNO(EACCES,RMS$_PRV); /* a guess */
2809	}
2810	return anum;
2811	}
2812	else
2813	return 0;
2814	}
2815	#endif
2816
2817	PP(pp_mkdir)
2818	{
2819	dSP; dTARGET;
2820	int mode = POPi;
2821	#ifndef HAS_MKDIR
2822	int oldumask;
2823	#endif
2824	char *tmps = SvPV(TOPs, na);
2825
2826	TAINT_PROPER("mkdir");
2827	#ifdef HAS_MKDIR
2828	SETi( Mkdir(tmps, mode) >= 0 );
2829	#else
2830	SETi( dooneliner("mkdir", tmps) );
2831	oldumask = umask(0);
2832	umask(oldumask);
2833	chmod(tmps, (mode & ~oldumask) & 0777);
2834	#endif
2835	RETURN;
2836	}
2837
2838	PP(pp_rmdir)
2839	{
2840	dSP; dTARGET;
2841	char *tmps;
2842
2843	tmps = POPp;
2844	TAINT_PROPER("rmdir");
2845	#ifdef HAS_RMDIR
2846	XPUSHi( rmdir(tmps) >= 0 );
2847	#else
2848	XPUSHi( dooneliner("rmdir", tmps) );
2849	#endif
2850	RETURN;
2851	}
2852
2853	/* Directory calls. */
2854
2855	PP(pp_open_dir)
2856	{
2857	dSP;
2858	#if defined(Direntry_t) && defined(HAS_READDIR)
2859	char *dirname = POPp;
2860	GV gv = (GV)POPs;
2861	register IO *io = GvIOn(gv);
2862
2863	if (!io)
2864	goto nope;
2865
2866	if (IoDIRP(io))
2867	closedir(IoDIRP(io));
2868	if (!(IoDIRP(io) = opendir(dirname)))
2869	goto nope;
2870
2871	RETPUSHYES;
2872	nope:
2873	if (!errno)
2874	SETERRNO(EBADF,RMS$_DIR);
2875	RETPUSHUNDEF;
2876	#else
2877	DIE(no_dir_func, "opendir");
2878	#endif
2879	}
2880
2881	PP(pp_readdir)
2882	{
2883	dSP;
2884	#if defined(Direntry_t) && defined(HAS_READDIR)
2885	#ifndef I_DIRENT
2886	Direntry_t readdir _((DIR ));
2887	#endif
2888	register Direntry_t *dp;
2889	GV gv = (GV)POPs;
2890	register IO *io = GvIOn(gv);
2891	SV *sv;
2892
2893	if (!io \|\| !IoDIRP(io))
2894	goto nope;
2895
2896	if (GIMME == G_ARRAY) {
2897	/SUPPRESS 560/
2898	while (dp = (Direntry_t *)readdir(IoDIRP(io))) {
2899	#ifdef DIRNAMLEN
2900	sv = newSVpv(dp->d_name, dp->d_namlen);
2901	#else
2902	sv = newSVpv(dp->d_name, 0);
2903	#endif
2904	#ifndef INCOMPLETE_TAINTS
2905	SvTAINTED_on(sv);
2906	#endif
2907	XPUSHs(sv_2mortal(sv));
2908	}
2909	}
2910	else {
2911	if (!(dp = (Direntry_t *)readdir(IoDIRP(io))))
2912	goto nope;
2913	#ifdef DIRNAMLEN
2914	sv = newSVpv(dp->d_name, dp->d_namlen);
2915	#else
2916	sv = newSVpv(dp->d_name, 0);
2917	#endif
2918	#ifndef INCOMPLETE_TAINTS
2919	SvTAINTED_on(sv);
2920	#endif
2921	XPUSHs(sv_2mortal(sv));
2922	sv = perl_get_sv("_INO", TRUE);
2923	#ifdef BSD
2924	sv_setiv(sv, dp->d_fileno);
2925	#else
2926	sv_setiv(sv, dp->d_ino);
2927	#endif
2928	}
2929	RETURN;
2930
2931	nope:
2932	if (!errno)
2933	SETERRNO(EBADF,RMS$_ISI);
2934	if (GIMME == G_ARRAY)
2935	RETURN;
2936	else
2937	RETPUSHUNDEF;
2938	#else
2939	DIE(no_dir_func, "readdir");
2940	#endif
2941	}
2942
2943	PP(pp_telldir)
2944	{
2945	dSP; dTARGET;
2946	#if defined(HAS_TELLDIR) \|\| defined(telldir)
2947	#if !defined(telldir) && !defined(HAS_TELLDIR_PROTOTYPE)
2948	long telldir _((DIR *));
2949	#endif
2950	GV gv = (GV)POPs;
2951	register IO *io = GvIOn(gv);
2952
2953	if (!io \|\| !IoDIRP(io))
2954	goto nope;
2955
2956	PUSHi( telldir(IoDIRP(io)) );
2957	RETURN;
2958	nope:
2959	if (!errno)
2960	SETERRNO(EBADF,RMS$_ISI);
2961	RETPUSHUNDEF;
2962	#else
2963	DIE(no_dir_func, "telldir");
2964	#endif
2965	}
2966
2967	PP(pp_seekdir)
2968	{
2969	dSP;
2970	#if defined(HAS_SEEKDIR) \|\| defined(seekdir)
2971	long along = POPl;
2972	GV gv = (GV)POPs;
2973	register IO *io = GvIOn(gv);
2974
2975	if (!io \|\| !IoDIRP(io))
2976	goto nope;
2977
2978	(void)seekdir(IoDIRP(io), along);
2979
2980	RETPUSHYES;
2981	nope:
2982	if (!errno)
2983	SETERRNO(EBADF,RMS$_ISI);
2984	RETPUSHUNDEF;
2985	#else
2986	DIE(no_dir_func, "seekdir");
2987	#endif
2988	}
2989
2990	PP(pp_rewinddir)
2991	{
2992	dSP;
2993	#if defined(HAS_REWINDDIR) \|\| defined(rewinddir)
2994	GV gv = (GV)POPs;
2995	register IO *io = GvIOn(gv);
2996
2997	if (!io \|\| !IoDIRP(io))
2998	goto nope;
2999
3000	(void)rewinddir(IoDIRP(io));
3001	RETPUSHYES;
3002	nope:
3003	if (!errno)
3004	SETERRNO(EBADF,RMS$_ISI);
3005	RETPUSHUNDEF;
3006	#else
3007	DIE(no_dir_func, "rewinddir");
3008	#endif
3009	}
3010
3011	PP(pp_closedir)
3012	{
3013	dSP;
3014	#if defined(Direntry_t) && defined(HAS_READDIR)
3015	GV gv = (GV)POPs;
3016	register IO *io = GvIOn(gv);
3017
3018	if (!io \|\| !IoDIRP(io))
3019	goto nope;
3020
3021	#ifdef VOID_CLOSEDIR
3022	closedir(IoDIRP(io));
3023	#else
3024	if (closedir(IoDIRP(io)) < 0) {
3025	IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
3026	goto nope;
3027	}
3028	#endif
3029	IoDIRP(io) = 0;
3030
3031	RETPUSHYES;
3032	nope:
3033	if (!errno)
3034	SETERRNO(EBADF,RMS$_IFI);
3035	RETPUSHUNDEF;
3036	#else
3037	DIE(no_dir_func, "closedir");
3038	#endif
3039	}
3040
3041	/* Process control. */
3042
3043	PP(pp_fork)
3044	{
3045	#ifdef HAS_FORK
3046	dSP; dTARGET;
3047	int childpid;
3048	GV *tmpgv;
3049
3050	EXTEND(SP, 1);
3051	childpid = fork();
3052	if (childpid < 0)
3053	RETSETUNDEF;
3054	if (!childpid) {
3055	/SUPPRESS 560/
3056	if (tmpgv = gv_fetchpv("$", TRUE, SVt_PV))
3057	sv_setiv(GvSV(tmpgv), (IV)getpid());
3058	hv_clear(pidstatus); /* no kids, so don't wait for 'em */
3059	}
3060	PUSHi(childpid);
3061	RETURN;
3062	#else
3063	DIE(no_func, "Unsupported function fork");
3064	#endif
3065	}
3066
3067	PP(pp_wait)
3068	{
3069	#if !defined(DOSISH) \|\| defined(OS2)
3070	dSP; dTARGET;
3071	int childpid;
3072	int argflags;
3073
3074	childpid = wait4pid(-1, &argflags, 0);
3075	STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
3076	XPUSHi(childpid);
3077	RETURN;
3078	#else
3079	DIE(no_func, "Unsupported function wait");
3080	#endif
3081	}
3082
3083	PP(pp_waitpid)
3084	{
3085	#if !defined(DOSISH) \|\| defined(OS2)
3086	dSP; dTARGET;
3087	int childpid;
3088	int optype;
3089	int argflags;
3090
3091	optype = POPi;
3092	childpid = TOPi;
3093	childpid = wait4pid(childpid, &argflags, optype);
3094	STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
3095	SETi(childpid);
3096	RETURN;
3097	#else
3098	DIE(no_func, "Unsupported function wait");
3099	#endif
3100	}
3101
3102	PP(pp_system)
3103	{
3104	dSP; dMARK; dORIGMARK; dTARGET;
3105	I32 value;
3106	int childpid;
3107	int result;
3108	int status;
3109	Sigsave_t ihand,qhand; /* place to save signals during system() */
3110
3111	if (SP - MARK == 1) {
3112	if (tainting) {
3113	char *junk = SvPV(TOPs, na);
3114	TAINT_ENV();
3115	TAINT_PROPER("system");
3116	}
3117	}
3118	#if (defined(HAS_FORK) \|\| defined(AMIGAOS)) && !defined(VMS) && !defined(OS2)
3119	while ((childpid = vfork()) == -1) {
3120	if (errno != EAGAIN) {
3121	value = -1;
3122	SP = ORIGMARK;
3123	PUSHi(value);
3124	RETURN;
3125	}
3126	sleep(5);
3127	}
3128	if (childpid > 0) {
3129	rsignal_save(SIGINT, SIG_IGN, &ihand);
3130	rsignal_save(SIGQUIT, SIG_IGN, &qhand);
3131	do {
3132	result = wait4pid(childpid, &status, 0);
3133	} while (result == -1 && errno == EINTR);
3134	(void)rsignal_restore(SIGINT, &ihand);
3135	(void)rsignal_restore(SIGQUIT, &qhand);
3136	STATUS_NATIVE_SET(result == -1 ? -1 : status);
3137	do_execfree(); /* free any memory child malloced on vfork */
3138	SP = ORIGMARK;
3139	PUSHi(STATUS_CURRENT);
3140	RETURN;
3141	}
3142	if (op->op_flags & OPf_STACKED) {
3143	SV really = ++MARK;
3144	value = (I32)do_aexec(really, MARK, SP);
3145	}
3146	else if (SP - MARK != 1)
3147	value = (I32)do_aexec(Nullsv, MARK, SP);
3148	else {
3149	value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), na));
3150	}
3151	_exit(-1);
3152	#else /* ! FORK or VMS or OS/2 */
3153	if (op->op_flags & OPf_STACKED) {
3154	SV really = ++MARK;
3155	value = (I32)do_aspawn(really, MARK, SP);
3156	}
3157	else if (SP - MARK != 1)
3158	value = (I32)do_aspawn(Nullsv, MARK, SP);
3159	else {
3160	value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), na));
3161	}
3162	STATUS_NATIVE_SET(value);
3163	do_execfree();
3164	SP = ORIGMARK;
3165	PUSHi(STATUS_CURRENT);
3166	#endif /* !FORK or VMS */
3167	RETURN;
3168	}
3169
3170	PP(pp_exec)
3171	{
3172	dSP; dMARK; dORIGMARK; dTARGET;
3173	I32 value;
3174
3175	if (op->op_flags & OPf_STACKED) {
3176	SV really = ++MARK;
3177	value = (I32)do_aexec(really, MARK, SP);
3178	}
3179	else if (SP - MARK != 1)
3180	#ifdef VMS
3181	value = (I32)vms_do_aexec(Nullsv, MARK, SP);
3182	#else
3183	value = (I32)do_aexec(Nullsv, MARK, SP);
3184	#endif
3185	else {
3186	if (tainting) {
3187	char junk = SvPV(SP, na);
3188	TAINT_ENV();
3189	TAINT_PROPER("exec");
3190	}
3191	#ifdef VMS
3192	value = (I32)vms_do_exec(SvPVx(sv_mortalcopy(*SP), na));
3193	#else
3194	value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), na));
3195	#endif
3196	}
3197	SP = ORIGMARK;
3198	PUSHi(value);
3199	RETURN;
3200	}
3201
3202	PP(pp_kill)
3203	{
3204	dSP; dMARK; dTARGET;
3205	I32 value;
3206	#ifdef HAS_KILL
3207	value = (I32)apply(op->op_type, MARK, SP);
3208	SP = MARK;
3209	PUSHi(value);
3210	RETURN;
3211	#else
3212	DIE(no_func, "Unsupported function kill");
3213	#endif
3214	}
3215
3216	PP(pp_getppid)
3217	{
3218	#ifdef HAS_GETPPID
3219	dSP; dTARGET;
3220	XPUSHi( getppid() );
3221	RETURN;
3222	#else
3223	DIE(no_func, "getppid");
3224	#endif
3225	}
3226
3227	PP(pp_getpgrp)
3228	{
3229	#ifdef HAS_GETPGRP
3230	dSP; dTARGET;
3231	int pid;
3232	I32 value;
3233
3234	if (MAXARG < 1)
3235	pid = 0;
3236	else
3237	pid = SvIVx(POPs);
3238	#ifdef BSD_GETPGRP
3239	value = (I32)BSD_GETPGRP(pid);
3240	#else
3241	if (pid != 0 && pid != getpid())
3242	DIE("POSIX getpgrp can't take an argument");
3243	value = (I32)getpgrp();
3244	#endif
3245	XPUSHi(value);
3246	RETURN;
3247	#else
3248	DIE(no_func, "getpgrp()");
3249	#endif
3250	}
3251
3252	PP(pp_setpgrp)
3253	{
3254	#ifdef HAS_SETPGRP
3255	dSP; dTARGET;
3256	int pgrp;
3257	int pid;
3258	if (MAXARG < 2) {
3259	pgrp = 0;
3260	pid = 0;
3261	}
3262	else {
3263	pgrp = POPi;
3264	pid = TOPi;
3265	}
3266
3267	TAINT_PROPER("setpgrp");
3268	#ifdef BSD_SETPGRP
3269	SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
3270	#else
3271	if ((pgrp != 0 && pgrp != getpid()) \|\| (pid != 0 && pid != getpid()))
3272	DIE("POSIX setpgrp can't take an argument");
3273	SETi( setpgrp() >= 0 );
3274	#endif /* USE_BSDPGRP */
3275	RETURN;
3276	#else
3277	DIE(no_func, "setpgrp()");
3278	#endif
3279	}
3280
3281	PP(pp_getpriority)
3282	{
3283	dSP; dTARGET;
3284	int which;
3285	int who;
3286	#ifdef HAS_GETPRIORITY
3287	who = POPi;
3288	which = TOPi;
3289	SETi( getpriority(which, who) );
3290	RETURN;
3291	#else
3292	DIE(no_func, "getpriority()");
3293	#endif
3294	}
3295
3296	PP(pp_setpriority)
3297	{
3298	dSP; dTARGET;
3299	int which;
3300	int who;
3301	int niceval;
3302	#ifdef HAS_SETPRIORITY
3303	niceval = POPi;
3304	who = POPi;
3305	which = TOPi;
3306	TAINT_PROPER("setpriority");
3307	SETi( setpriority(which, who, niceval) >= 0 );
3308	RETURN;
3309	#else
3310	DIE(no_func, "setpriority()");
3311	#endif
3312	}
3313
3314	/* Time calls. */
3315
3316	PP(pp_time)
3317	{
3318	dSP; dTARGET;
3319	#ifdef BIG_TIME
3320	XPUSHn( time(Null(Time_t*)) );
3321	#else
3322	XPUSHi( time(Null(Time_t*)) );
3323	#endif
3324	RETURN;
3325	}
3326
3327	/* XXX The POSIX name is CLK_TCK; it is to be preferred
3328	to HZ. Probably. For now, assume that if the system
3329	defines HZ, it does so correctly. (Will this break
3330	on VMS?)
3331	Probably we ought to use _sysconf(_SC_CLK_TCK), if
3332	it's supported. --AD 9/96.
3333	*/
3334
3335	#ifndef HZ
3336	# ifdef CLK_TCK
3337	# define HZ CLK_TCK
3338	# else
3339	# define HZ 60
3340	# endif
3341	#endif
3342
3343	PP(pp_tms)
3344	{
3345	dSP;
3346
3347	#ifndef HAS_TIMES
3348	DIE("times not implemented");
3349	#else
3350	EXTEND(SP, 4);
3351
3352	#ifndef VMS
3353	(void)times(&timesbuf);
3354	#else
3355	(void)times((tbuffer_t )&timesbuf); / time.h uses different name for */
3356	/* struct tms, though same data */
3357	/* is returned. */
3358	#endif
3359
3360	PUSHs(sv_2mortal(newSVnv(((double)timesbuf.tms_utime)/HZ)));
3361	if (GIMME == G_ARRAY) {
3362	PUSHs(sv_2mortal(newSVnv(((double)timesbuf.tms_stime)/HZ)));
3363	PUSHs(sv_2mortal(newSVnv(((double)timesbuf.tms_cutime)/HZ)));
3364	PUSHs(sv_2mortal(newSVnv(((double)timesbuf.tms_cstime)/HZ)));
3365	}
3366	RETURN;
3367	#endif /* HAS_TIMES */
3368	}
3369
3370	PP(pp_localtime)
3371	{
3372	return pp_gmtime(ARGS);
3373	}
3374
3375	PP(pp_gmtime)
3376	{
3377	dSP;
3378	Time_t when;
3379	struct tm *tmbuf;
3380	static char *dayname[] = {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
3381	static char *monname[] = {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
3382	"Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
3383
3384	if (MAXARG < 1)
3385	(void)time(&when);
3386	else
3387	#ifdef BIG_TIME
3388	when = (Time_t)SvNVx(POPs);
3389	#else
3390	when = (Time_t)SvIVx(POPs);
3391	#endif
3392
3393	if (op->op_type == OP_LOCALTIME)
3394	tmbuf = localtime(&when);
3395	else
3396	tmbuf = gmtime(&when);
3397
3398	EXTEND(SP, 9);
3399	EXTEND_MORTAL(9);
3400	if (GIMME != G_ARRAY) {
3401	dTARGET;
3402	SV *tsv;
3403	if (!tmbuf)
3404	RETPUSHUNDEF;
3405	tsv = newSVpvf("%s %s %2d %02d:%02d:%02d %d",
3406	dayname[tmbuf->tm_wday],
3407	monname[tmbuf->tm_mon],
3408	tmbuf->tm_mday,
3409	tmbuf->tm_hour,
3410	tmbuf->tm_min,
3411	tmbuf->tm_sec,
3412	tmbuf->tm_year + 1900);
3413	PUSHs(sv_2mortal(tsv));
3414	}
3415	else if (tmbuf) {
3416	PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_sec)));
3417	PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_min)));
3418	PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_hour)));
3419	PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_mday)));
3420	PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_mon)));
3421	PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_year)));
3422	PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_wday)));
3423	PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_yday)));
3424	PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_isdst)));
3425	}
3426	RETURN;
3427	}
3428
3429	PP(pp_alarm)
3430	{
3431	dSP; dTARGET;
3432	int anum;
3433	#ifdef HAS_ALARM
3434	anum = POPi;
3435	anum = alarm((unsigned int)anum);
3436	EXTEND(SP, 1);
3437	if (anum < 0)
3438	RETPUSHUNDEF;
3439	PUSHi((I32)anum);
3440	RETURN;
3441	#else
3442	DIE(no_func, "Unsupported function alarm");
3443	#endif
3444	}
3445
3446	PP(pp_sleep)
3447	{
3448	dSP; dTARGET;
3449	I32 duration;
3450	Time_t lasttime;
3451	Time_t when;
3452
3453	(void)time(&lasttime);
3454	if (MAXARG < 1)
3455	Pause();
3456	else {
3457	duration = POPi;
3458	sleep((unsigned int)duration);
3459	}
3460	(void)time(&when);
3461	XPUSHi(when - lasttime);
3462	RETURN;
3463	}
3464
3465	/* Shared memory. */
3466
3467	PP(pp_shmget)
3468	{
3469	return pp_semget(ARGS);
3470	}
3471
3472	PP(pp_shmctl)
3473	{
3474	return pp_semctl(ARGS);
3475	}
3476
3477	PP(pp_shmread)
3478	{
3479	return pp_shmwrite(ARGS);
3480	}
3481
3482	PP(pp_shmwrite)
3483	{
3484	#if defined(HAS_MSG) \|\| defined(HAS_SEM) \|\| defined(HAS_SHM)
3485	dSP; dMARK; dTARGET;
3486	I32 value = (I32)(do_shmio(op->op_type, MARK, SP) >= 0);
3487	SP = MARK;
3488	PUSHi(value);
3489	RETURN;
3490	#else
3491	return pp_semget(ARGS);
3492	#endif
3493	}
3494
3495	/* Message passing. */
3496
3497	PP(pp_msgget)
3498	{
3499	return pp_semget(ARGS);
3500	}
3501
3502	PP(pp_msgctl)
3503	{
3504	return pp_semctl(ARGS);
3505	}
3506
3507	PP(pp_msgsnd)
3508	{
3509	#if defined(HAS_MSG) \|\| defined(HAS_SEM) \|\| defined(HAS_SHM)
3510	dSP; dMARK; dTARGET;
3511	I32 value = (I32)(do_msgsnd(MARK, SP) >= 0);
3512	SP = MARK;
3513	PUSHi(value);
3514	RETURN;
3515	#else
3516	return pp_semget(ARGS);
3517	#endif
3518	}
3519
3520	PP(pp_msgrcv)
3521	{
3522	#if defined(HAS_MSG) \|\| defined(HAS_SEM) \|\| defined(HAS_SHM)
3523	dSP; dMARK; dTARGET;
3524	I32 value = (I32)(do_msgrcv(MARK, SP) >= 0);
3525	SP = MARK;
3526	PUSHi(value);
3527	RETURN;
3528	#else
3529	return pp_semget(ARGS);
3530	#endif
3531	}
3532
3533	/* Semaphores. */
3534
3535	PP(pp_semget)
3536	{
3537	#if defined(HAS_MSG) \|\| defined(HAS_SEM) \|\| defined(HAS_SHM)
3538	dSP; dMARK; dTARGET;
3539	int anum = do_ipcget(op->op_type, MARK, SP);
3540	SP = MARK;
3541	if (anum == -1)
3542	RETPUSHUNDEF;
3543	PUSHi(anum);
3544	RETURN;
3545	#else
3546	DIE("System V IPC is not implemented on this machine");
3547	#endif
3548	}
3549
3550	PP(pp_semctl)
3551	{
3552	#if defined(HAS_MSG) \|\| defined(HAS_SEM) \|\| defined(HAS_SHM)
3553	dSP; dMARK; dTARGET;
3554	int anum = do_ipcctl(op->op_type, MARK, SP);
3555	SP = MARK;
3556	if (anum == -1)
3557	RETSETUNDEF;
3558	if (anum != 0) {
3559	PUSHi(anum);
3560	}
3561	else {
3562	PUSHp(zero_but_true, ZBTLEN);
3563	}
3564	RETURN;
3565	#else
3566	return pp_semget(ARGS);
3567	#endif
3568	}
3569
3570	PP(pp_semop)
3571	{
3572	#if defined(HAS_MSG) \|\| defined(HAS_SEM) \|\| defined(HAS_SHM)
3573	dSP; dMARK; dTARGET;
3574	I32 value = (I32)(do_semop(MARK, SP) >= 0);
3575	SP = MARK;
3576	PUSHi(value);
3577	RETURN;
3578	#else
3579	return pp_semget(ARGS);
3580	#endif
3581	}
3582
3583	/* Get system info. */
3584
3585	PP(pp_ghbyname)
3586	{
3587	#ifdef HAS_SOCKET
3588	return pp_ghostent(ARGS);
3589	#else
3590	DIE(no_sock_func, "gethostbyname");
3591	#endif
3592	}
3593
3594	PP(pp_ghbyaddr)
3595	{
3596	#ifdef HAS_SOCKET
3597	return pp_ghostent(ARGS);
3598	#else
3599	DIE(no_sock_func, "gethostbyaddr");
3600	#endif
3601	}
3602
3603	PP(pp_ghostent)
3604	{
3605	dSP;
3606	#ifdef HAS_SOCKET
3607	I32 which = op->op_type;
3608	register char **elem;
3609	register SV *sv;
3610	struct hostent *gethostbyname();
3611	struct hostent *gethostbyaddr();
3612	#ifdef HAS_GETHOSTENT
3613	struct hostent *gethostent();
3614	#endif
3615	struct hostent *hent;
3616	unsigned long len;
3617
3618	EXTEND(SP, 10);
3619	if (which == OP_GHBYNAME) {
3620	hent = gethostbyname(POPp);
3621	}
3622	else if (which == OP_GHBYADDR) {
3623	int addrtype = POPi;
3624	SV *addrsv = POPs;
3625	STRLEN addrlen;
3626	char *addr = SvPV(addrsv, addrlen);
3627
3628	hent = gethostbyaddr(addr, addrlen, addrtype);
3629	}
3630	else
3631	#ifdef HAS_GETHOSTENT
3632	hent = gethostent();
3633	#else
3634	DIE("gethostent not implemented");
3635	#endif
3636
3637	#ifdef HOST_NOT_FOUND
3638	if (!hent)
3639	STATUS_NATIVE_SET(h_errno);
3640	#endif
3641
3642	if (GIMME != G_ARRAY) {
3643	PUSHs(sv = sv_newmortal());
3644	if (hent) {
3645	if (which == OP_GHBYNAME) {
3646	if (hent->h_addr)
3647	sv_setpvn(sv, hent->h_addr, hent->h_length);
3648	}
3649	else
3650	sv_setpv(sv, (char*)hent->h_name);
3651	}
3652	RETURN;
3653	}
3654
3655	if (hent) {
3656	PUSHs(sv = sv_mortalcopy(&sv_no));
3657	sv_setpv(sv, (char*)hent->h_name);
3658	PUSHs(sv = sv_mortalcopy(&sv_no));
3659	for (elem = hent->h_aliases; elem && *elem; elem++) {
3660	sv_catpv(sv, *elem);
3661	if (elem[1])
3662	sv_catpvn(sv, " ", 1);
3663	}
3664	PUSHs(sv = sv_mortalcopy(&sv_no));
3665	sv_setiv(sv, (IV)hent->h_addrtype);
3666	PUSHs(sv = sv_mortalcopy(&sv_no));
3667	len = hent->h_length;
3668	sv_setiv(sv, (IV)len);
3669	#ifdef h_addr
3670	for (elem = hent->h_addr_list; elem && *elem; elem++) {
3671	XPUSHs(sv = sv_mortalcopy(&sv_no));
3672	sv_setpvn(sv, *elem, len);
3673	}
3674	#else
3675	PUSHs(sv = sv_mortalcopy(&sv_no));
3676	if (hent->h_addr)
3677	sv_setpvn(sv, hent->h_addr, len);
3678	#endif /* h_addr */
3679	}
3680	RETURN;
3681	#else
3682	DIE(no_sock_func, "gethostent");
3683	#endif
3684	}
3685
3686	PP(pp_gnbyname)
3687	{
3688	#ifdef HAS_SOCKET
3689	return pp_gnetent(ARGS);
3690	#else
3691	DIE(no_sock_func, "getnetbyname");
3692	#endif
3693	}
3694
3695	PP(pp_gnbyaddr)
3696	{
3697	#ifdef HAS_SOCKET
3698	return pp_gnetent(ARGS);
3699	#else
3700	DIE(no_sock_func, "getnetbyaddr");
3701	#endif
3702	}
3703
3704	PP(pp_gnetent)
3705	{
3706	dSP;
3707	#ifdef HAS_SOCKET
3708	I32 which = op->op_type;
3709	register char **elem;
3710	register SV *sv;
3711	struct netent *getnetbyname();
3712	struct netent *getnetbyaddr();
3713	struct netent *getnetent();
3714	struct netent *nent;
3715
3716	if (which == OP_GNBYNAME)
3717	nent = getnetbyname(POPp);
3718	else if (which == OP_GNBYADDR) {
3719	int addrtype = POPi;
3720	unsigned long addr = U_L(POPn);
3721	nent = getnetbyaddr((long)addr, addrtype);
3722	}
3723	else
3724	nent = getnetent();
3725
3726	EXTEND(SP, 4);
3727	if (GIMME != G_ARRAY) {
3728	PUSHs(sv = sv_newmortal());
3729	if (nent) {
3730	if (which == OP_GNBYNAME)
3731	sv_setiv(sv, (IV)nent->n_net);
3732	else
3733	sv_setpv(sv, nent->n_name);
3734	}
3735	RETURN;
3736	}
3737
3738	if (nent) {
3739	PUSHs(sv = sv_mortalcopy(&sv_no));
3740	sv_setpv(sv, nent->n_name);
3741	PUSHs(sv = sv_mortalcopy(&sv_no));
3742	for (elem = nent->n_aliases; elem && *elem; elem++) {
3743	sv_catpv(sv, *elem);
3744	if (elem[1])
3745	sv_catpvn(sv, " ", 1);
3746	}
3747	PUSHs(sv = sv_mortalcopy(&sv_no));
3748	sv_setiv(sv, (IV)nent->n_addrtype);
3749	PUSHs(sv = sv_mortalcopy(&sv_no));
3750	sv_setiv(sv, (IV)nent->n_net);
3751	}
3752
3753	RETURN;
3754	#else
3755	DIE(no_sock_func, "getnetent");
3756	#endif
3757	}
3758
3759	PP(pp_gpbyname)
3760	{
3761	#ifdef HAS_SOCKET
3762	return pp_gprotoent(ARGS);
3763	#else
3764	DIE(no_sock_func, "getprotobyname");
3765	#endif
3766	}
3767
3768	PP(pp_gpbynumber)
3769	{
3770	#ifdef HAS_SOCKET
3771	return pp_gprotoent(ARGS);
3772	#else
3773	DIE(no_sock_func, "getprotobynumber");
3774	#endif
3775	}
3776
3777	PP(pp_gprotoent)
3778	{
3779	dSP;
3780	#ifdef HAS_SOCKET
3781	I32 which = op->op_type;
3782	register char **elem;
3783	register SV *sv;
3784	struct protoent *getprotobyname();
3785	struct protoent *getprotobynumber();
3786	struct protoent *getprotoent();
3787	struct protoent *pent;
3788
3789	if (which == OP_GPBYNAME)
3790	pent = getprotobyname(POPp);
3791	else if (which == OP_GPBYNUMBER)
3792	pent = getprotobynumber(POPi);
3793	else
3794	pent = getprotoent();
3795
3796	EXTEND(SP, 3);
3797	if (GIMME != G_ARRAY) {
3798	PUSHs(sv = sv_newmortal());
3799	if (pent) {
3800	if (which == OP_GPBYNAME)
3801	sv_setiv(sv, (IV)pent->p_proto);
3802	else
3803	sv_setpv(sv, pent->p_name);
3804	}
3805	RETURN;
3806	}
3807
3808	if (pent) {
3809	PUSHs(sv = sv_mortalcopy(&sv_no));
3810	sv_setpv(sv, pent->p_name);
3811	PUSHs(sv = sv_mortalcopy(&sv_no));
3812	for (elem = pent->p_aliases; elem && *elem; elem++) {
3813	sv_catpv(sv, *elem);
3814	if (elem[1])
3815	sv_catpvn(sv, " ", 1);
3816	}
3817	PUSHs(sv = sv_mortalcopy(&sv_no));
3818	sv_setiv(sv, (IV)pent->p_proto);
3819	}
3820
3821	RETURN;
3822	#else
3823	DIE(no_sock_func, "getprotoent");
3824	#endif
3825	}
3826
3827	PP(pp_gsbyname)
3828	{
3829	#ifdef HAS_SOCKET
3830	return pp_gservent(ARGS);
3831	#else
3832	DIE(no_sock_func, "getservbyname");
3833	#endif
3834	}
3835
3836	PP(pp_gsbyport)
3837	{
3838	#ifdef HAS_SOCKET
3839	return pp_gservent(ARGS);
3840	#else
3841	DIE(no_sock_func, "getservbyport");
3842	#endif
3843	}
3844
3845	PP(pp_gservent)
3846	{
3847	dSP;
3848	#ifdef HAS_SOCKET
3849	I32 which = op->op_type;
3850	register char **elem;
3851	register SV *sv;
3852	struct servent *getservbyname();
3853	struct servent *getservbynumber();
3854	struct servent *getservent();
3855	struct servent *sent;
3856
3857	if (which == OP_GSBYNAME) {
3858	char *proto = POPp;
3859	char *name = POPp;
3860
3861	if (proto && !*proto)
3862	proto = Nullch;
3863
3864	sent = getservbyname(name, proto);
3865	}
3866	else if (which == OP_GSBYPORT) {
3867	char *proto = POPp;
3868	unsigned short port = POPu;
3869
3870	#ifdef HAS_HTONS
3871	port = htons(port);
3872	#endif
3873	sent = getservbyport(port, proto);
3874	}
3875	else
3876	sent = getservent();
3877
3878	EXTEND(SP, 4);
3879	if (GIMME != G_ARRAY) {
3880	PUSHs(sv = sv_newmortal());
3881	if (sent) {
3882	if (which == OP_GSBYNAME) {
3883	#ifdef HAS_NTOHS
3884	sv_setiv(sv, (IV)ntohs(sent->s_port));
3885	#else
3886	sv_setiv(sv, (IV)(sent->s_port));
3887	#endif
3888	}
3889	else
3890	sv_setpv(sv, sent->s_name);
3891	}
3892	RETURN;
3893	}
3894
3895	if (sent) {
3896	PUSHs(sv = sv_mortalcopy(&sv_no));
3897	sv_setpv(sv, sent->s_name);
3898	PUSHs(sv = sv_mortalcopy(&sv_no));
3899	for (elem = sent->s_aliases; elem && *elem; elem++) {
3900	sv_catpv(sv, *elem);
3901	if (elem[1])
3902	sv_catpvn(sv, " ", 1);
3903	}
3904	PUSHs(sv = sv_mortalcopy(&sv_no));
3905	#ifdef HAS_NTOHS
3906	sv_setiv(sv, (IV)ntohs(sent->s_port));
3907	#else
3908	sv_setiv(sv, (IV)(sent->s_port));
3909	#endif
3910	PUSHs(sv = sv_mortalcopy(&sv_no));
3911	sv_setpv(sv, sent->s_proto);
3912	}
3913
3914	RETURN;
3915	#else
3916	DIE(no_sock_func, "getservent");
3917	#endif
3918	}
3919
3920	PP(pp_shostent)
3921	{
3922	dSP;
3923	#ifdef HAS_SOCKET
3924	sethostent(TOPi);
3925	RETSETYES;
3926	#else
3927	DIE(no_sock_func, "sethostent");
3928	#endif
3929	}
3930
3931	PP(pp_snetent)
3932	{
3933	dSP;
3934	#ifdef HAS_SOCKET
3935	setnetent(TOPi);
3936	RETSETYES;
3937	#else
3938	DIE(no_sock_func, "setnetent");
3939	#endif
3940	}
3941
3942	PP(pp_sprotoent)
3943	{
3944	dSP;
3945	#ifdef HAS_SOCKET
3946	setprotoent(TOPi);
3947	RETSETYES;
3948	#else
3949	DIE(no_sock_func, "setprotoent");
3950	#endif
3951	}
3952
3953	PP(pp_sservent)
3954	{
3955	dSP;
3956	#ifdef HAS_SOCKET
3957	setservent(TOPi);
3958	RETSETYES;
3959	#else
3960	DIE(no_sock_func, "setservent");
3961	#endif
3962	}
3963
3964	PP(pp_ehostent)
3965	{
3966	dSP;
3967	#ifdef HAS_SOCKET
3968	endhostent();
3969	EXTEND(sp,1);
3970	RETPUSHYES;
3971	#else
3972	DIE(no_sock_func, "endhostent");
3973	#endif
3974	}
3975
3976	PP(pp_enetent)
3977	{
3978	dSP;
3979	#ifdef HAS_SOCKET
3980	endnetent();
3981	EXTEND(sp,1);
3982	RETPUSHYES;
3983	#else
3984	DIE(no_sock_func, "endnetent");
3985	#endif
3986	}
3987
3988	PP(pp_eprotoent)
3989	{
3990	dSP;
3991	#ifdef HAS_SOCKET
3992	endprotoent();
3993	EXTEND(sp,1);
3994	RETPUSHYES;
3995	#else
3996	DIE(no_sock_func, "endprotoent");
3997	#endif
3998	}
3999
4000	PP(pp_eservent)
4001	{
4002	dSP;
4003	#ifdef HAS_SOCKET
4004	endservent();
4005	EXTEND(sp,1);
4006	RETPUSHYES;
4007	#else
4008	DIE(no_sock_func, "endservent");
4009	#endif
4010	}
4011
4012	PP(pp_gpwnam)
4013	{
4014	#ifdef HAS_PASSWD
4015	return pp_gpwent(ARGS);
4016	#else
4017	DIE(no_func, "getpwnam");
4018	#endif
4019	}
4020
4021	PP(pp_gpwuid)
4022	{
4023	#ifdef HAS_PASSWD
4024	return pp_gpwent(ARGS);
4025	#else
4026	DIE(no_func, "getpwuid");
4027	#endif
4028	}
4029
4030	PP(pp_gpwent)
4031	{
4032	dSP;
4033	#ifdef HAS_PASSWD
4034	I32 which = op->op_type;
4035	register SV *sv;
4036	struct passwd *pwent;
4037
4038	if (which == OP_GPWNAM)
4039	pwent = getpwnam(POPp);
4040	else if (which == OP_GPWUID)
4041	pwent = getpwuid(POPi);
4042	else
4043	pwent = (struct passwd *)getpwent();
4044
4045	EXTEND(SP, 10);
4046	if (GIMME != G_ARRAY) {
4047	PUSHs(sv = sv_newmortal());
4048	if (pwent) {
4049	if (which == OP_GPWNAM)
4050	sv_setiv(sv, (IV)pwent->pw_uid);
4051	else
4052	sv_setpv(sv, pwent->pw_name);
4053	}
4054	RETURN;
4055	}
4056
4057	if (pwent) {
4058	PUSHs(sv = sv_mortalcopy(&sv_no));
4059	sv_setpv(sv, pwent->pw_name);
4060	PUSHs(sv = sv_mortalcopy(&sv_no));
4061	sv_setpv(sv, pwent->pw_passwd);
4062	PUSHs(sv = sv_mortalcopy(&sv_no));
4063	sv_setiv(sv, (IV)pwent->pw_uid);
4064	PUSHs(sv = sv_mortalcopy(&sv_no));
4065	sv_setiv(sv, (IV)pwent->pw_gid);
4066	PUSHs(sv = sv_mortalcopy(&sv_no));
4067	#ifdef PWCHANGE
4068	sv_setiv(sv, (IV)pwent->pw_change);
4069	#else
4070	#ifdef PWQUOTA
4071	sv_setiv(sv, (IV)pwent->pw_quota);
4072	#else
4073	#ifdef PWAGE
4074	sv_setpv(sv, pwent->pw_age);
4075	#endif
4076	#endif
4077	#endif
4078	PUSHs(sv = sv_mortalcopy(&sv_no));
4079	#ifdef PWCLASS
4080	sv_setpv(sv, pwent->pw_class);
4081	#else
4082	#ifdef PWCOMMENT
4083	sv_setpv(sv, pwent->pw_comment);
4084	#endif
4085	#endif
4086	PUSHs(sv = sv_mortalcopy(&sv_no));
4087	sv_setpv(sv, pwent->pw_gecos);
4088	#ifndef INCOMPLETE_TAINTS
4089	SvTAINTED_on(sv);
4090	#endif
4091	PUSHs(sv = sv_mortalcopy(&sv_no));
4092	sv_setpv(sv, pwent->pw_dir);
4093	PUSHs(sv = sv_mortalcopy(&sv_no));
4094	sv_setpv(sv, pwent->pw_shell);
4095	#ifdef PWEXPIRE
4096	PUSHs(sv = sv_mortalcopy(&sv_no));
4097	sv_setiv(sv, (IV)pwent->pw_expire);
4098	#endif
4099	}
4100	RETURN;
4101	#else
4102	DIE(no_func, "getpwent");
4103	#endif
4104	}
4105
4106	PP(pp_spwent)
4107	{
4108	dSP;
4109	#if defined(HAS_PASSWD) && !defined(CYGWIN32)
4110	setpwent();
4111	RETPUSHYES;
4112	#else
4113	DIE(no_func, "setpwent");
4114	#endif
4115	}
4116
4117	PP(pp_epwent)
4118	{
4119	dSP;
4120	#ifdef HAS_PASSWD
4121	endpwent();
4122	RETPUSHYES;
4123	#else
4124	DIE(no_func, "endpwent");
4125	#endif
4126	}
4127
4128	PP(pp_ggrnam)
4129	{
4130	#ifdef HAS_GROUP
4131	return pp_ggrent(ARGS);
4132	#else
4133	DIE(no_func, "getgrnam");
4134	#endif
4135	}
4136
4137	PP(pp_ggrgid)
4138	{
4139	#ifdef HAS_GROUP
4140	return pp_ggrent(ARGS);
4141	#else
4142	DIE(no_func, "getgrgid");
4143	#endif
4144	}
4145
4146	PP(pp_ggrent)
4147	{
4148	dSP;
4149	#ifdef HAS_GROUP
4150	I32 which = op->op_type;
4151	register char **elem;
4152	register SV *sv;
4153	struct group *grent;
4154
4155	if (which == OP_GGRNAM)
4156	grent = (struct group *)getgrnam(POPp);
4157	else if (which == OP_GGRGID)
4158	grent = (struct group *)getgrgid(POPi);
4159	else
4160	grent = (struct group *)getgrent();
4161
4162	EXTEND(SP, 4);
4163	if (GIMME != G_ARRAY) {
4164	PUSHs(sv = sv_newmortal());
4165	if (grent) {
4166	if (which == OP_GGRNAM)
4167	sv_setiv(sv, (IV)grent->gr_gid);
4168	else
4169	sv_setpv(sv, grent->gr_name);
4170	}
4171	RETURN;
4172	}
4173
4174	if (grent) {
4175	PUSHs(sv = sv_mortalcopy(&sv_no));
4176	sv_setpv(sv, grent->gr_name);
4177	PUSHs(sv = sv_mortalcopy(&sv_no));
4178	sv_setpv(sv, grent->gr_passwd);
4179	PUSHs(sv = sv_mortalcopy(&sv_no));
4180	sv_setiv(sv, (IV)grent->gr_gid);
4181	PUSHs(sv = sv_mortalcopy(&sv_no));
4182	for (elem = grent->gr_mem; elem && *elem; elem++) {
4183	sv_catpv(sv, *elem);
4184	if (elem[1])
4185	sv_catpvn(sv, " ", 1);
4186	}
4187	}
4188
4189	RETURN;
4190	#else
4191	DIE(no_func, "getgrent");
4192	#endif
4193	}
4194
4195	PP(pp_sgrent)
4196	{
4197	dSP;
4198	#ifdef HAS_GROUP
4199	setgrent();
4200	RETPUSHYES;
4201	#else
4202	DIE(no_func, "setgrent");
4203	#endif
4204	}
4205
4206	PP(pp_egrent)
4207	{
4208	dSP;
4209	#ifdef HAS_GROUP
4210	endgrent();
4211	RETPUSHYES;
4212	#else
4213	DIE(no_func, "endgrent");
4214	#endif
4215	}
4216
4217	PP(pp_getlogin)
4218	{
4219	dSP; dTARGET;
4220	#ifdef HAS_GETLOGIN
4221	char *tmps;
4222	EXTEND(SP, 1);
4223	if (!(tmps = getlogin()))
4224	RETPUSHUNDEF;
4225	PUSHp(tmps, strlen(tmps));
4226	RETURN;
4227	#else
4228	DIE(no_func, "getlogin");
4229	#endif
4230	}
4231
4232	/* Miscellaneous. */
4233
4234	PP(pp_syscall)
4235	{
4236	#ifdef HAS_SYSCALL
4237	dSP; dMARK; dORIGMARK; dTARGET;
4238	register I32 items = SP - MARK;
4239	unsigned long a[20];
4240	register I32 i = 0;
4241	I32 retval = -1;
4242	MAGIC *mg;
4243
4244	if (tainting) {
4245	while (++MARK <= SP) {
4246	if (SvTAINTED(*MARK)) {
4247	TAINT;
4248	break;
4249	}
4250	}
4251	MARK = ORIGMARK;
4252	TAINT_PROPER("syscall");
4253	}
4254
4255	/* This probably won't work on machines where sizeof(long) != sizeof(int)
4256	* or where sizeof(long) != sizeof(char*). But such machines will
4257	* not likely have syscall implemented either, so who cares?
4258	*/
4259	while (++MARK <= SP) {
4260	if (SvNIOK(*MARK) \|\| !i)
4261	a[i++] = SvIV(*MARK);
4262	else if (*MARK == &sv_undef)
4263	a[i++] = 0;
4264	else
4265	a[i++] = (unsigned long)SvPV_force(*MARK, na);
4266	if (i > 15)
4267	break;
4268	}
4269	switch (items) {
4270	default:
4271	DIE("Too many args to syscall");
4272	case 0:
4273	DIE("Too few args to syscall");
4274	case 1:
4275	retval = syscall(a[0]);
4276	break;
4277	case 2:
4278	retval = syscall(a[0],a[1]);
4279	break;
4280	case 3:
4281	retval = syscall(a[0],a[1],a[2]);
4282	break;
4283	case 4:
4284	retval = syscall(a[0],a[1],a[2],a[3]);
4285	break;
4286	case 5:
4287	retval = syscall(a[0],a[1],a[2],a[3],a[4]);
4288	break;
4289	case 6:
4290	retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
4291	break;
4292	case 7:
4293	retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
4294	break;
4295	case 8:
4296	retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
4297	break;
4298	#ifdef atarist
4299	case 9:
4300	retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
4301	break;
4302	case 10:
4303	retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
4304	break;
4305	case 11:
4306	retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
4307	a[10]);
4308	break;
4309	case 12:
4310	retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
4311	a[10],a[11]);
4312	break;
4313	case 13:
4314	retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
4315	a[10],a[11],a[12]);
4316	break;
4317	case 14:
4318	retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
4319	a[10],a[11],a[12],a[13]);
4320	break;
4321	#endif /* atarist */
4322	}
4323	SP = ORIGMARK;
4324	PUSHi(retval);
4325	RETURN;
4326	#else
4327	DIE(no_func, "syscall");
4328	#endif
4329	}
4330
4331	#ifdef FCNTL_EMULATE_FLOCK
4332
4333	/* XXX Emulate flock() with fcntl().
4334	What's really needed is a good file locking module.
4335	*/
4336
4337	static int
4338	fcntl_emulate_flock(fd, operation)
4339	int fd;
4340	int operation;
4341	{
4342	struct flock flock;
4343
4344	switch (operation & ~LOCK_NB) {
4345	case LOCK_SH:
4346	flock.l_type = F_RDLCK;
4347	break;
4348	case LOCK_EX:
4349	flock.l_type = F_WRLCK;
4350	break;
4351	case LOCK_UN:
4352	flock.l_type = F_UNLCK;
4353	break;
4354	default:
4355	errno = EINVAL;
4356	return -1;
4357	}
4358	flock.l_whence = SEEK_SET;
4359	flock.l_start = flock.l_len = 0L;
4360
4361	return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
4362	}
4363
4364	#endif /* FCNTL_EMULATE_FLOCK */
4365
4366	#ifdef LOCKF_EMULATE_FLOCK
4367
4368	/* XXX Emulate flock() with lockf(). This is just to increase
4369	portability of scripts. The calls are not completely
4370	interchangeable. What's really needed is a good file
4371	locking module.
4372	*/
4373
4374	/* The lockf() constants might have been defined in <unistd.h>.
4375	Unfortunately, <unistd.h> causes troubles on some mixed
4376	(BSD/POSIX) systems, such as SunOS 4.1.3.
4377
4378	Further, the lockf() constants aren't POSIX, so they might not be
4379	visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
4380	just stick in the SVID values and be done with it. Sigh.
4381	*/
4382
4383	# ifndef F_ULOCK
4384	# define F_ULOCK 0 /* Unlock a previously locked region */
4385	# endif
4386	# ifndef F_LOCK
4387	# define F_LOCK 1 /* Lock a region for exclusive use */
4388	# endif
4389	# ifndef F_TLOCK
4390	# define F_TLOCK 2 /* Test and lock a region for exclusive use */
4391	# endif
4392	# ifndef F_TEST
4393	# define F_TEST 3 /* Test a region for other processes locks */
4394	# endif
4395
4396	static int
4397	lockf_emulate_flock (fd, operation)
4398	int fd;
4399	int operation;
4400	{
4401	int i;
4402	int save_errno;
4403	Off_t pos;
4404
4405	/* flock locks entire file so for lockf we need to do the same */
4406	save_errno = errno;
4407	pos = lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
4408	if (pos > 0) /* is seekable and needs to be repositioned */
4409	if (lseek(fd, (Off_t)0, SEEK_SET) < 0)
4410	pos = -1; /* seek failed, so don't seek back afterwards */
4411	errno = save_errno;
4412
4413	switch (operation) {
4414
4415	/* LOCK_SH - get a shared lock */
4416	case LOCK_SH:
4417	/* LOCK_EX - get an exclusive lock */
4418	case LOCK_EX:
4419	i = lockf (fd, F_LOCK, 0);
4420	break;
4421
4422	/* LOCK_SH\|LOCK_NB - get a non-blocking shared lock */
4423	case LOCK_SH\|LOCK_NB:
4424	/* LOCK_EX\|LOCK_NB - get a non-blocking exclusive lock */
4425	case LOCK_EX\|LOCK_NB:
4426	i = lockf (fd, F_TLOCK, 0);
4427	if (i == -1)
4428	if ((errno == EAGAIN) \|\| (errno == EACCES))
4429	errno = EWOULDBLOCK;
4430	break;
4431
4432	/* LOCK_UN - unlock (non-blocking is a no-op) */
4433	case LOCK_UN:
4434	case LOCK_UN\|LOCK_NB:
4435	i = lockf (fd, F_ULOCK, 0);
4436	break;
4437
4438	/* Default - can't decipher operation */
4439	default:
4440	i = -1;
4441	errno = EINVAL;
4442	break;
4443	}
4444
4445	if (pos > 0) /* need to restore position of the handle */
4446	lseek(fd, pos, SEEK_SET); /* ignore error here */
4447
4448	return (i);
4449	}
4450
4451	#endif /* LOCKF_EMULATE_FLOCK */

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

Download in other formats: