Context Navigation

pp_sys.c @ 20079

Visit:

Revision 20079, 120.9 KB checked in by zacheiss, 21 years ago (diff)
Merge with perl 5.8.3.

Line
1	/* pp_sys.c
2	*
3	* Copyright (C) 1995, 1996, 1997, 1998, 1999,
4	* 2000, 2001, 2002, 2003, by Larry Wall and others
5	*
6	* You may distribute under the terms of either the GNU General Public
7	* License or the Artistic License, as specified in the README file.
8	*
9	*/
10
11	/*
12	* But only a short way ahead its floor and the walls on either side were
13	* cloven by a great fissure, out of which the red glare came, now leaping
14	* up, now dying down into darkness; and all the while far below there was
15	* a rumour and a trouble as of great engines throbbing and labouring.
16	*/
17
18	#include "EXTERN.h"
19	#define PERL_IN_PP_SYS_C
20	#include "perl.h"
21
22	#ifdef I_SHADOW
23	/* Shadow password support for solaris - pdo@cs.umd.edu
24	* Not just Solaris: at least HP-UX, IRIX, Linux.
25	* The API is from SysV.
26	*
27	* There are at least two more shadow interfaces,
28	* see the comments in pp_gpwent().
29	*
30	* --jhi */
31	# ifdef __hpux__
32	/* There is a MAXINT coming from <shadow.h> <- <hpsecurity.h> <- <values.h>
33	* and another MAXINT from "perl.h" <- <sys/param.h>. */
34	# undef MAXINT
35	# endif
36	# include <shadow.h>
37	#endif
38
39	#ifdef HAS_SYSCALL
40	#ifdef __cplusplus
41	extern "C" int syscall(unsigned long,...);
42	#endif
43	#endif
44
45	#ifdef I_SYS_WAIT
46	# include <sys/wait.h>
47	#endif
48
49	#ifdef I_SYS_RESOURCE
50	# include <sys/resource.h>
51	#endif
52
53	#ifdef NETWARE
54	NETDB_DEFINE_CONTEXT
55	#endif
56
57	#ifdef HAS_SELECT
58	# ifdef I_SYS_SELECT
59	# include <sys/select.h>
60	# endif
61	#endif
62
63	/* XXX Configure test needed.
64	h_errno might not be a simple 'int', especially for multi-threaded
65	applications, see "extern int errno in perl.h". Creating such
66	a test requires taking into account the differences between
67	compiling multithreaded and singlethreaded ($ccflags et al).
68	HOST_NOT_FOUND is typically defined in <netdb.h>.
69	*/
70	#if defined(HOST_NOT_FOUND) && !defined(h_errno) && !defined(__CYGWIN__)
71	extern int h_errno;
72	#endif
73
74	#ifdef HAS_PASSWD
75	# ifdef I_PWD
76	# include <pwd.h>
77	# else
78	# if !defined(VMS)
79	struct passwd getpwnam (char );
80	struct passwd *getpwuid (Uid_t);
81	# endif
82	# endif
83	# ifdef HAS_GETPWENT
84	#ifndef getpwent
85	struct passwd *getpwent (void);
86	#elif defined (VMS) && defined (my_getpwent)
87	struct passwd *Perl_my_getpwent (void);
88	#endif
89	# endif
90	#endif
91
92	#ifdef HAS_GROUP
93	# ifdef I_GRP
94	# include <grp.h>
95	# else
96	struct group getgrnam (char );
97	struct group *getgrgid (Gid_t);
98	# endif
99	# ifdef HAS_GETGRENT
100	#ifndef getgrent
101	struct group *getgrent (void);
102	#endif
103	# endif
104	#endif
105
106	#ifdef I_UTIME
107	# if defined(_MSC_VER) \|\| defined(__MINGW32__)
108	# include <sys/utime.h>
109	# else
110	# include <utime.h>
111	# endif
112	#endif
113
114	#ifdef HAS_CHSIZE
115	# ifdef my_chsize /* Probably #defined to Perl_my_chsize in embed.h */
116	# undef my_chsize
117	# endif
118	# define my_chsize PerlLIO_chsize
119	#endif
120
121	#ifdef HAS_FLOCK
122	# define FLOCK flock
123	#else /* no flock() */
124
125	/* fcntl.h might not have been included, even if it exists, because
126	the current Configure only sets I_FCNTL if it's needed to pick up
127	the *_OK constants. Make sure it has been included before testing
128	the fcntl() locking constants. */
129	# if defined(HAS_FCNTL) && !defined(I_FCNTL)
130	# include <fcntl.h>
131	# endif
132
133	# if defined(HAS_FCNTL) && defined(FCNTL_CAN_LOCK)
134	# define FLOCK fcntl_emulate_flock
135	# define FCNTL_EMULATE_FLOCK
136	# else /* no flock() or fcntl(F_SETLK,...) */
137	# ifdef HAS_LOCKF
138	# define FLOCK lockf_emulate_flock
139	# define LOCKF_EMULATE_FLOCK
140	# endif /* lockf */
141	# endif /* no flock() or fcntl(F_SETLK,...) */
142
143	# ifdef FLOCK
144	static int FLOCK (int, int);
145
146	/*
147	* These are the flock() constants. Since this sytems doesn't have
148	* flock(), the values of the constants are probably not available.
149	*/
150	# ifndef LOCK_SH
151	# define LOCK_SH 1
152	# endif
153	# ifndef LOCK_EX
154	# define LOCK_EX 2
155	# endif
156	# ifndef LOCK_NB
157	# define LOCK_NB 4
158	# endif
159	# ifndef LOCK_UN
160	# define LOCK_UN 8
161	# endif
162	# endif /* emulating flock() */
163
164	#endif /* no flock() */
165
166	#define ZBTLEN 10
167	static char zero_but_true[ZBTLEN + 1] = "0 but true";
168
169	#if defined(I_SYS_ACCESS) && !defined(R_OK)
170	# include <sys/access.h>
171	#endif
172
173	#if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
174	# define FD_CLOEXEC 1 /* NeXT needs this */
175	#endif
176
177	#include "reentr.h"
178
179	#ifdef __Lynx__
180	/* Missing protos on LynxOS */
181	void sethostent(int);
182	void endhostent(void);
183	void setnetent(int);
184	void endnetent(void);
185	void setprotoent(int);
186	void endprotoent(void);
187	void setservent(int);
188	void endservent(void);
189	#endif
190
191	#undef PERL_EFF_ACCESS_R_OK /* EFFective uid/gid ACCESS R_OK */
192	#undef PERL_EFF_ACCESS_W_OK
193	#undef PERL_EFF_ACCESS_X_OK
194
195	/* F_OK unused: if stat() cannot find it... */
196
197	#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_ACCESS) && defined(EFF_ONLY_OK) && !defined(NO_EFF_ONLY_OK)
198	/* Digital UNIX (when the EFF_ONLY_OK gets fixed), UnixWare */
199	# define PERL_EFF_ACCESS_R_OK(p) (access((p), R_OK \| EFF_ONLY_OK))
200	# define PERL_EFF_ACCESS_W_OK(p) (access((p), W_OK \| EFF_ONLY_OK))
201	# define PERL_EFF_ACCESS_X_OK(p) (access((p), X_OK \| EFF_ONLY_OK))
202	#endif
203
204	#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_EACCESS)
205	# ifdef I_SYS_SECURITY
206	# include <sys/security.h>
207	# endif
208	# ifdef ACC_SELF
209	/* HP SecureWare */
210	# define PERL_EFF_ACCESS_R_OK(p) (eaccess((p), R_OK, ACC_SELF))
211	# define PERL_EFF_ACCESS_W_OK(p) (eaccess((p), W_OK, ACC_SELF))
212	# define PERL_EFF_ACCESS_X_OK(p) (eaccess((p), X_OK, ACC_SELF))
213	# else
214	/* SCO */
215	# define PERL_EFF_ACCESS_R_OK(p) (eaccess((p), R_OK))
216	# define PERL_EFF_ACCESS_W_OK(p) (eaccess((p), W_OK))
217	# define PERL_EFF_ACCESS_X_OK(p) (eaccess((p), X_OK))
218	# endif
219	#endif
220
221	#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_ACCESSX) && defined(ACC_SELF)
222	/* AIX */
223	# define PERL_EFF_ACCESS_R_OK(p) (accessx((p), R_OK, ACC_SELF))
224	# define PERL_EFF_ACCESS_W_OK(p) (accessx((p), W_OK, ACC_SELF))
225	# define PERL_EFF_ACCESS_X_OK(p) (accessx((p), X_OK, ACC_SELF))
226	#endif
227
228	#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_ACCESS) \
229	&& (defined(HAS_SETREUID) \|\| defined(HAS_SETRESUID) \
230	\|\| defined(HAS_SETREGID) \|\| defined(HAS_SETRESGID))
231	/* The Hard Way. */
232	STATIC int
233	S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
234	{
235	Uid_t ruid = getuid();
236	Uid_t euid = geteuid();
237	Gid_t rgid = getgid();
238	Gid_t egid = getegid();
239	int res;
240
241	LOCK_CRED_MUTEX;
242	#if !defined(HAS_SETREUID) && !defined(HAS_SETRESUID)
243	Perl_croak(aTHX_ "switching effective uid is not implemented");
244	#else
245	#ifdef HAS_SETREUID
246	if (setreuid(euid, ruid))
247	#else
248	#ifdef HAS_SETRESUID
249	if (setresuid(euid, ruid, (Uid_t)-1))
250	#endif
251	#endif
252	Perl_croak(aTHX_ "entering effective uid failed");
253	#endif
254
255	#if !defined(HAS_SETREGID) && !defined(HAS_SETRESGID)
256	Perl_croak(aTHX_ "switching effective gid is not implemented");
257	#else
258	#ifdef HAS_SETREGID
259	if (setregid(egid, rgid))
260	#else
261	#ifdef HAS_SETRESGID
262	if (setresgid(egid, rgid, (Gid_t)-1))
263	#endif
264	#endif
265	Perl_croak(aTHX_ "entering effective gid failed");
266	#endif
267
268	res = access(path, mode);
269
270	#ifdef HAS_SETREUID
271	if (setreuid(ruid, euid))
272	#else
273	#ifdef HAS_SETRESUID
274	if (setresuid(ruid, euid, (Uid_t)-1))
275	#endif
276	#endif
277	Perl_croak(aTHX_ "leaving effective uid failed");
278
279	#ifdef HAS_SETREGID
280	if (setregid(rgid, egid))
281	#else
282	#ifdef HAS_SETRESGID
283	if (setresgid(rgid, egid, (Gid_t)-1))
284	#endif
285	#endif
286	Perl_croak(aTHX_ "leaving effective gid failed");
287	UNLOCK_CRED_MUTEX;
288
289	return res;
290	}
291	# define PERL_EFF_ACCESS_R_OK(p) (emulate_eaccess((p), R_OK))
292	# define PERL_EFF_ACCESS_W_OK(p) (emulate_eaccess((p), W_OK))
293	# define PERL_EFF_ACCESS_X_OK(p) (emulate_eaccess((p), X_OK))
294	#endif
295
296	#if !defined(PERL_EFF_ACCESS_R_OK)
297	/* With it or without it: anyway you get a warning: either that
298	it is unused, or it is declared static and never defined.
299	*/
300	STATIC int
301	S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
302	{
303	Perl_croak(aTHX_ "switching effective uid is not implemented");
304	/NOTREACHED/
305	return -1;
306	}
307	#endif
308
309	PP(pp_backtick)
310	{
311	dSP; dTARGET;
312	PerlIO *fp;
313	STRLEN n_a;
314	char *tmps = POPpx;
315	I32 gimme = GIMME_V;
316	char *mode = "r";
317
318	TAINT_PROPER("``");
319	if (PL_op->op_private & OPpOPEN_IN_RAW)
320	mode = "rb";
321	else if (PL_op->op_private & OPpOPEN_IN_CRLF)
322	mode = "rt";
323	fp = PerlProc_popen(tmps, mode);
324	if (fp) {
325	char *type = NULL;
326	if (PL_curcop->cop_io) {
327	type = SvPV_nolen(PL_curcop->cop_io);
328	}
329	if (type && *type)
330	PerlIO_apply_layers(aTHX_ fp,mode,type);
331
332	if (gimme == G_VOID) {
333	char tmpbuf[256];
334	while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0)
335	/SUPPRESS 530/
336	;
337	}
338	else if (gimme == G_SCALAR) {
339	SV *oldrs = PL_rs;
340	PL_rs = &PL_sv_undef;
341	sv_setpv(TARG, ""); /* note that this preserves previous buffer */
342	while (sv_gets(TARG, fp, SvCUR(TARG)) != Nullch)
343	/SUPPRESS 530/
344	;
345	PL_rs = oldrs;
346	XPUSHs(TARG);
347	SvTAINTED_on(TARG);
348	}
349	else {
350	SV *sv;
351
352	for (;;) {
353	sv = NEWSV(56, 79);
354	if (sv_gets(sv, fp, 0) == Nullch) {
355	SvREFCNT_dec(sv);
356	break;
357	}
358	XPUSHs(sv_2mortal(sv));
359	if (SvLEN(sv) - SvCUR(sv) > 20) {
360	SvLEN_set(sv, SvCUR(sv)+1);
361	Renew(SvPVX(sv), SvLEN(sv), char);
362	}
363	SvTAINTED_on(sv);
364	}
365	}
366	STATUS_NATIVE_SET(PerlProc_pclose(fp));
367	TAINT; /* "I believe that this is not gratuitous!" */
368	}
369	else {
370	STATUS_NATIVE_SET(-1);
371	if (gimme == G_SCALAR)
372	RETPUSHUNDEF;
373	}
374
375	RETURN;
376	}
377
378	PP(pp_glob)
379	{
380	OP *result;
381	tryAMAGICunTARGET(iter, -1);
382
383	/* Note that we only ever get here if File::Glob fails to load
384	* without at the same time croaking, for some reason, or if
385	* perl was built with PERL_EXTERNAL_GLOB */
386
387	ENTER;
388
389	#ifndef VMS
390	if (PL_tainting) {
391	/*
392	* The external globbing program may use things we can't control,
393	* so for security reasons we must assume the worst.
394	*/
395	TAINT;
396	taint_proper(PL_no_security, "glob");
397	}
398	#endif /* !VMS */
399
400	SAVESPTR(PL_last_in_gv); /* We don't want this to be permanent. */
401	PL_last_in_gv = (GV)PL_stack_sp--;
402
403	SAVESPTR(PL_rs); /* This is not permanent, either. */
404	PL_rs = sv_2mortal(newSVpvn("\000", 1));
405	#ifndef DOSISH
406	#ifndef CSH
407	*SvPVX(PL_rs) = '\n';
408	#endif /* !CSH */
409	#endif /* !DOSISH */
410
411	result = do_readline();
412	LEAVE;
413	return result;
414	}
415
416	PP(pp_rcatline)
417	{
418	PL_last_in_gv = cGVOP_gv;
419	return do_readline();
420	}
421
422	PP(pp_warn)
423	{
424	dSP; dMARK;
425	SV *tmpsv;
426	char *tmps;
427	STRLEN len;
428	if (SP - MARK != 1) {
429	dTARGET;
430	do_join(TARG, &PL_sv_no, MARK, SP);
431	tmpsv = TARG;
432	SP = MARK + 1;
433	}
434	else {
435	tmpsv = TOPs;
436	}
437	tmps = SvPV(tmpsv, len);
438	if ((!tmps \|\| !len) && PL_errgv) {
439	SV *error = ERRSV;
440	(void)SvUPGRADE(error, SVt_PV);
441	if (SvPOK(error) && SvCUR(error))
442	sv_catpv(error, "\t...caught");
443	tmpsv = error;
444	tmps = SvPV(tmpsv, len);
445	}
446	if (!tmps \|\| !len)
447	tmpsv = sv_2mortal(newSVpvn("Warning: something's wrong", 26));
448
449	Perl_warn(aTHX_ "%"SVf, tmpsv);
450	RETSETYES;
451	}
452
453	PP(pp_die)
454	{
455	dSP; dMARK;
456	char *tmps;
457	SV *tmpsv;
458	STRLEN len;
459	bool multiarg = 0;
460	#ifdef VMS
461	VMSISH_HUSHED = VMSISH_HUSHED \|\| (PL_op->op_private & OPpHUSH_VMSISH);
462	#endif
463	if (SP - MARK != 1) {
464	dTARGET;
465	do_join(TARG, &PL_sv_no, MARK, SP);
466	tmpsv = TARG;
467	tmps = SvPV(tmpsv, len);
468	multiarg = 1;
469	SP = MARK + 1;
470	}
471	else {
472	tmpsv = TOPs;
473	tmps = SvROK(tmpsv) ? Nullch : SvPV(tmpsv, len);
474	}
475	if (!tmps \|\| !len) {
476	SV *error = ERRSV;
477	(void)SvUPGRADE(error, SVt_PV);
478	if (multiarg ? SvROK(error) : SvROK(tmpsv)) {
479	if (!multiarg)
480	SvSetSV(error,tmpsv);
481	else if (sv_isobject(error)) {
482	HV *stash = SvSTASH(SvRV(error));
483	GV *gv = gv_fetchmethod(stash, "PROPAGATE");
484	if (gv) {
485	SV *file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0));
486	SV *line = sv_2mortal(newSVuv(CopLINE(PL_curcop)));
487	EXTEND(SP, 3);
488	PUSHMARK(SP);
489	PUSHs(error);
490	PUSHs(file);
491	PUSHs(line);
492	PUTBACK;
493	call_sv((SV*)GvCV(gv),
494	G_SCALAR\|G_EVAL\|G_KEEPERR);
495	sv_setsv(error,*PL_stack_sp--);
496	}
497	}
498	DIE(aTHX_ Nullformat);
499	}
500	else {
501	if (SvPOK(error) && SvCUR(error))
502	sv_catpv(error, "\t...propagated");
503	tmpsv = error;
504	tmps = SvPV(tmpsv, len);
505	}
506	}
507	if (!tmps \|\| !len)
508	tmpsv = sv_2mortal(newSVpvn("Died", 4));
509
510	DIE(aTHX_ "%"SVf, tmpsv);
511	}
512
513	/* I/O. */
514
515	PP(pp_open)
516	{
517	dSP;
518	dMARK; dORIGMARK;
519	dTARGET;
520	GV *gv;
521	SV *sv;
522	IO *io;
523	char *tmps;
524	STRLEN len;
525	MAGIC *mg;
526	bool ok;
527
528	gv = (GV )++MARK;
529	if (!isGV(gv))
530	DIE(aTHX_ PL_no_usym, "filehandle");
531	if ((io = GvIOp(gv)))
532	IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
533
534	if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
535	/* Method's args are same as ours ... */
536	/* ... except handle is replaced by the object */
537	MARK-- = SvTIED_obj((SV)io, mg);
538	PUSHMARK(MARK);
539	PUTBACK;
540	ENTER;
541	call_method("OPEN", G_SCALAR);
542	LEAVE;
543	SPAGAIN;
544	RETURN;
545	}
546
547	if (MARK < SP) {
548	sv = *++MARK;
549	}
550	else {
551	sv = GvSV(gv);
552	}
553
554	tmps = SvPV(sv, len);
555	ok = do_openn(gv, tmps, len, FALSE, O_RDONLY, 0, Nullfp, MARK+1, (SP-MARK));
556	SP = ORIGMARK;
557	if (ok)
558	PUSHi( (I32)PL_forkprocess );
559	else if (PL_forkprocess == 0) /* we are a new child */
560	PUSHi(0);
561	else
562	RETPUSHUNDEF;
563	RETURN;
564	}
565
566	PP(pp_close)
567	{
568	dSP;
569	GV *gv;
570	IO *io;
571	MAGIC *mg;
572
573	if (MAXARG == 0)
574	gv = PL_defoutgv;
575	else
576	gv = (GV*)POPs;
577
578	if (gv && (io = GvIO(gv))
579	&& (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
580	{
581	PUSHMARK(SP);
582	XPUSHs(SvTIED_obj((SV*)io, mg));
583	PUTBACK;
584	ENTER;
585	call_method("CLOSE", G_SCALAR);
586	LEAVE;
587	SPAGAIN;
588	RETURN;
589	}
590	EXTEND(SP, 1);
591	PUSHs(boolSV(do_close(gv, TRUE)));
592	RETURN;
593	}
594
595	PP(pp_pipe_op)
596	{
597	#ifdef HAS_PIPE
598	dSP;
599	GV *rgv;
600	GV *wgv;
601	register IO *rstio;
602	register IO *wstio;
603	int fd[2];
604
605	wgv = (GV*)POPs;
606	rgv = (GV*)POPs;
607
608	if (!rgv \|\| !wgv)
609	goto badexit;
610
611	if (SvTYPE(rgv) != SVt_PVGV \|\| SvTYPE(wgv) != SVt_PVGV)
612	DIE(aTHX_ PL_no_usym, "filehandle");
613	rstio = GvIOn(rgv);
614	wstio = GvIOn(wgv);
615
616	if (IoIFP(rstio))
617	do_close(rgv, FALSE);
618	if (IoIFP(wstio))
619	do_close(wgv, FALSE);
620
621	if (PerlProc_pipe(fd) < 0)
622	goto badexit;
623
624	IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"PIPE_OPEN_MODE);
625	IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"PIPE_OPEN_MODE);
626	IoOFP(rstio) = IoIFP(rstio);
627	IoIFP(wstio) = IoOFP(wstio);
628	IoTYPE(rstio) = IoTYPE_RDONLY;
629	IoTYPE(wstio) = IoTYPE_WRONLY;
630
631	if (!IoIFP(rstio) \|\| !IoOFP(wstio)) {
632	if (IoIFP(rstio)) PerlIO_close(IoIFP(rstio));
633	else PerlLIO_close(fd[0]);
634	if (IoOFP(wstio)) PerlIO_close(IoOFP(wstio));
635	else PerlLIO_close(fd[1]);
636	goto badexit;
637	}
638	#if defined(HAS_FCNTL) && defined(F_SETFD)
639	fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
640	fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
641	#endif
642	RETPUSHYES;
643
644	badexit:
645	RETPUSHUNDEF;
646	#else
647	DIE(aTHX_ PL_no_func, "pipe");
648	#endif
649	}
650
651	PP(pp_fileno)
652	{
653	dSP; dTARGET;
654	GV *gv;
655	IO *io;
656	PerlIO *fp;
657	MAGIC *mg;
658
659	if (MAXARG < 1)
660	RETPUSHUNDEF;
661	gv = (GV*)POPs;
662
663	if (gv && (io = GvIO(gv))
664	&& (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
665	{
666	PUSHMARK(SP);
667	XPUSHs(SvTIED_obj((SV*)io, mg));
668	PUTBACK;
669	ENTER;
670	call_method("FILENO", G_SCALAR);
671	LEAVE;
672	SPAGAIN;
673	RETURN;
674	}
675
676	if (!gv \|\| !(io = GvIO(gv)) \|\| !(fp = IoIFP(io))) {
677	/* Can't do this because people seem to do things like
678	defined(fileno($foo)) to check whether $foo is a valid fh.
679	if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
680	report_evil_fh(gv, io, PL_op->op_type);
681	*/
682	RETPUSHUNDEF;
683	}
684
685	PUSHi(PerlIO_fileno(fp));
686	RETURN;
687	}
688
689	PP(pp_umask)
690	{
691	dSP; dTARGET;
692	#ifdef HAS_UMASK
693	Mode_t anum;
694
695	if (MAXARG < 1) {
696	anum = PerlLIO_umask(0);
697	(void)PerlLIO_umask(anum);
698	}
699	else
700	anum = PerlLIO_umask(POPi);
701	TAINT_PROPER("umask");
702	XPUSHi(anum);
703	#else
704	/* Only DIE if trying to restrict permissions on `user' (self).
705	* Otherwise it's harmless and more useful to just return undef
706	* since 'group' and 'other' concepts probably don't exist here. */
707	if (MAXARG >= 1 && (POPi & 0700))
708	DIE(aTHX_ "umask not implemented");
709	XPUSHs(&PL_sv_undef);
710	#endif
711	RETURN;
712	}
713
714	PP(pp_binmode)
715	{
716	dSP;
717	GV *gv;
718	IO *io;
719	PerlIO *fp;
720	MAGIC *mg;
721	SV *discp = Nullsv;
722
723	if (MAXARG < 1)
724	RETPUSHUNDEF;
725	if (MAXARG > 1) {
726	discp = POPs;
727	}
728
729	gv = (GV*)POPs;
730
731	if (gv && (io = GvIO(gv))
732	&& (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
733	{
734	PUSHMARK(SP);
735	XPUSHs(SvTIED_obj((SV*)io, mg));
736	if (discp)
737	XPUSHs(discp);
738	PUTBACK;
739	ENTER;
740	call_method("BINMODE", G_SCALAR);
741	LEAVE;
742	SPAGAIN;
743	RETURN;
744	}
745
746	EXTEND(SP, 1);
747	if (!(io = GvIO(gv)) \|\| !(fp = IoIFP(io))) {
748	if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
749	report_evil_fh(gv, io, PL_op->op_type);
750	SETERRNO(EBADF,RMS_IFI);
751	RETPUSHUNDEF;
752	}
753
754	PUTBACK;
755	if (PerlIO_binmode(aTHX_ fp,IoTYPE(io),mode_from_discipline(discp),
756	(discp) ? SvPV_nolen(discp) : Nullch)) {
757	if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
758	if (!PerlIO_binmode(aTHX_ IoOFP(io),IoTYPE(io),
759	mode_from_discipline(discp),
760	(discp) ? SvPV_nolen(discp) : Nullch)) {
761	SPAGAIN;
762	RETPUSHUNDEF;
763	}
764	}
765	SPAGAIN;
766	RETPUSHYES;
767	}
768	else {
769	SPAGAIN;
770	RETPUSHUNDEF;
771	}
772	}
773
774	PP(pp_tie)
775	{
776	dSP;
777	dMARK;
778	SV *varsv;
779	HV* stash;
780	GV *gv;
781	SV *sv;
782	I32 markoff = MARK - PL_stack_base;
783	char *methname;
784	int how = PERL_MAGIC_tied;
785	U32 items;
786
787	varsv = *++MARK;
788	switch(SvTYPE(varsv)) {
789	case SVt_PVHV:
790	methname = "TIEHASH";
791	HvEITER((HV )varsv) = Null(HE );
792	break;
793	case SVt_PVAV:
794	methname = "TIEARRAY";
795	break;
796	case SVt_PVGV:
797	#ifdef GV_UNIQUE_CHECK
798	if (GvUNIQUE((GV*)varsv)) {
799	Perl_croak(aTHX_ "Attempt to tie unique GV");
800	}
801	#endif
802	methname = "TIEHANDLE";
803	how = PERL_MAGIC_tiedscalar;
804	/* For tied filehandles, we apply tiedscalar magic to the IO
805	slot of the GP rather than the GV itself. AMS 20010812 */
806	if (!GvIOp(varsv))
807	GvIOp(varsv) = newIO();
808	varsv = (SV *)GvIOp(varsv);
809	break;
810	default:
811	methname = "TIESCALAR";
812	how = PERL_MAGIC_tiedscalar;
813	break;
814	}
815	items = SP - MARK++;
816	if (sv_isobject(*MARK)) {
817	ENTER;
818	PUSHSTACKi(PERLSI_MAGIC);
819	PUSHMARK(SP);
820	EXTEND(SP,(I32)items);
821	while (items--)
822	PUSHs(*MARK++);
823	PUTBACK;
824	call_method(methname, G_SCALAR);
825	}
826	else {
827	/* Not clear why we don't call call_method here too.
828	* perhaps to get different error message ?
829	*/
830	stash = gv_stashsv(*MARK, FALSE);
831	if (!stash \|\| !(gv = gv_fetchmethod(stash, methname))) {
832	DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"",
833	methname, *MARK);
834	}
835	ENTER;
836	PUSHSTACKi(PERLSI_MAGIC);
837	PUSHMARK(SP);
838	EXTEND(SP,(I32)items);
839	while (items--)
840	PUSHs(*MARK++);
841	PUTBACK;
842	call_sv((SV*)GvCV(gv), G_SCALAR);
843	}
844	SPAGAIN;
845
846	sv = TOPs;
847	POPSTACK;
848	if (sv_isobject(sv)) {
849	sv_unmagic(varsv, how);
850	/* Croak if a self-tie on an aggregate is attempted. */
851	if (varsv == SvRV(sv) &&
852	(SvTYPE(varsv) == SVt_PVAV \|\|
853	SvTYPE(varsv) == SVt_PVHV))
854	Perl_croak(aTHX_
855	"Self-ties of arrays and hashes are not supported");
856	sv_magic(varsv, (SvRV(sv) == varsv ? Nullsv : sv), how, Nullch, 0);
857	}
858	LEAVE;
859	SP = PL_stack_base + markoff;
860	PUSHs(sv);
861	RETURN;
862	}
863
864	PP(pp_untie)
865	{
866	dSP;
867	MAGIC *mg;
868	SV *sv = POPs;
869	char how = (SvTYPE(sv) == SVt_PVHV \|\| SvTYPE(sv) == SVt_PVAV)
870	? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
871
872	if (SvTYPE(sv) == SVt_PVGV && !(sv = (SV *)GvIOp(sv)))
873	RETPUSHYES;
874
875	if ((mg = SvTIED_mg(sv, how))) {
876	SV *obj = SvRV(SvTIED_obj(sv, mg));
877	GV *gv;
878	CV *cv = NULL;
879	if (obj) {
880	if ((gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE)) &&
881	isGV(gv) && (cv = GvCV(gv))) {
882	PUSHMARK(SP);
883	XPUSHs(SvTIED_obj((SV*)gv, mg));
884	XPUSHs(sv_2mortal(newSViv(SvREFCNT(obj)-1)));
885	PUTBACK;
886	ENTER;
887	call_sv((SV *)cv, G_VOID);
888	LEAVE;
889	SPAGAIN;
890	}
891	else if (ckWARN(WARN_UNTIE)) {
892	if (mg && SvREFCNT(obj) > 1)
893	Perl_warner(aTHX_ packWARN(WARN_UNTIE),
894	"untie attempted while %"UVuf" inner references still exist",
895	(UV)SvREFCNT(obj) - 1 ) ;
896	}
897	}
898	}
899	sv_unmagic(sv, how) ;
900	RETPUSHYES;
901	}
902
903	PP(pp_tied)
904	{
905	dSP;
906	MAGIC *mg;
907	SV *sv = POPs;
908	char how = (SvTYPE(sv) == SVt_PVHV \|\| SvTYPE(sv) == SVt_PVAV)
909	? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
910
911	if (SvTYPE(sv) == SVt_PVGV && !(sv = (SV *)GvIOp(sv)))
912	RETPUSHUNDEF;
913
914	if ((mg = SvTIED_mg(sv, how))) {
915	SV *osv = SvTIED_obj(sv, mg);
916	if (osv == mg->mg_obj)
917	osv = sv_mortalcopy(osv);
918	PUSHs(osv);
919	RETURN;
920	}
921	RETPUSHUNDEF;
922	}
923
924	PP(pp_dbmopen)
925	{
926	dSP;
927	HV *hv;
928	dPOPPOPssrl;
929	HV* stash;
930	GV *gv;
931	SV *sv;
932
933	hv = (HV*)POPs;
934
935	sv = sv_mortalcopy(&PL_sv_no);
936	sv_setpv(sv, "AnyDBM_File");
937	stash = gv_stashsv(sv, FALSE);
938	if (!stash \|\| !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
939	PUTBACK;
940	require_pv("AnyDBM_File.pm");
941	SPAGAIN;
942	if (!(gv = gv_fetchmethod(stash, "TIEHASH")))
943	DIE(aTHX_ "No dbm on this machine");
944	}
945
946	ENTER;
947	PUSHMARK(SP);
948
949	EXTEND(SP, 5);
950	PUSHs(sv);
951	PUSHs(left);
952	if (SvIV(right))
953	PUSHs(sv_2mortal(newSVuv(O_RDWR\|O_CREAT)));
954	else
955	PUSHs(sv_2mortal(newSVuv(O_RDWR)));
956	PUSHs(right);
957	PUTBACK;
958	call_sv((SV*)GvCV(gv), G_SCALAR);
959	SPAGAIN;
960
961	if (!sv_isobject(TOPs)) {
962	SP--;
963	PUSHMARK(SP);
964	PUSHs(sv);
965	PUSHs(left);
966	PUSHs(sv_2mortal(newSVuv(O_RDONLY)));
967	PUSHs(right);
968	PUTBACK;
969	call_sv((SV*)GvCV(gv), G_SCALAR);
970	SPAGAIN;
971	}
972
973	if (sv_isobject(TOPs)) {
974	sv_unmagic((SV *) hv, PERL_MAGIC_tied);
975	sv_magic((SV*)hv, TOPs, PERL_MAGIC_tied, Nullch, 0);
976	}
977	LEAVE;
978	RETURN;
979	}
980
981	PP(pp_dbmclose)
982	{
983	return pp_untie();
984	}
985
986	PP(pp_sselect)
987	{
988	#ifdef HAS_SELECT
989	dSP; dTARGET;
990	register I32 i;
991	register I32 j;
992	register char *s;
993	register SV *sv;
994	NV value;
995	I32 maxlen = 0;
996	I32 nfound;
997	struct timeval timebuf;
998	struct timeval *tbuf = &timebuf;
999	I32 growsize;
1000	char *fd_sets[4];
1001	STRLEN n_a;
1002	#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1003	I32 masksize;
1004	I32 offset;
1005	I32 k;
1006
1007	# if BYTEORDER & 0xf0000
1008	# define ORDERBYTE (0x88888888 - BYTEORDER)
1009	# else
1010	# define ORDERBYTE (0x4444 - BYTEORDER)
1011	# endif
1012
1013	#endif
1014
1015	SP -= 4;
1016	for (i = 1; i <= 3; i++) {
1017	if (!SvPOK(SP[i]))
1018	continue;
1019	j = SvCUR(SP[i]);
1020	if (maxlen < j)
1021	maxlen = j;
1022	}
1023
1024	/* little endians can use vecs directly */
1025	#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1026	# ifdef NFDBITS
1027
1028	# ifndef NBBY
1029	# define NBBY 8
1030	# endif
1031
1032	masksize = NFDBITS / NBBY;
1033	# else
1034	masksize = sizeof(long); /* documented int, everyone seems to use long */
1035	# endif
1036	Zero(&fd_sets[0], 4, char*);
1037	#endif
1038
1039	# if SELECT_MIN_BITS == 1
1040	growsize = sizeof(fd_set);
1041	# else
1042	# if defined(__GLIBC__) && defined(__FD_SETSIZE)
1043	# undef SELECT_MIN_BITS
1044	# define SELECT_MIN_BITS __FD_SETSIZE
1045	# endif
1046	/* If SELECT_MIN_BITS is greater than one we most probably will want
1047	* to align the sizes with SELECT_MIN_BITS/8 because for example
1048	* in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
1049	* UNIX, Solaris, NeXT, Darwin) the smallest quantum select() operates
1050	* on (sets/tests/clears bits) is 32 bits. */
1051	growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
1052	# endif
1053
1054	sv = SP[4];
1055	if (SvOK(sv)) {
1056	value = SvNV(sv);
1057	if (value < 0.0)
1058	value = 0.0;
1059	timebuf.tv_sec = (long)value;
1060	value -= (NV)timebuf.tv_sec;
1061	timebuf.tv_usec = (long)(value * 1000000.0);
1062	}
1063	else
1064	tbuf = Null(struct timeval*);
1065
1066	for (i = 1; i <= 3; i++) {
1067	sv = SP[i];
1068	if (!SvOK(sv)) {
1069	fd_sets[i] = 0;
1070	continue;
1071	}
1072	else if (!SvPOK(sv))
1073	SvPV_force(sv,n_a); /* force string conversion */
1074	j = SvLEN(sv);
1075	if (j < growsize) {
1076	Sv_Grow(sv, growsize);
1077	}
1078	j = SvCUR(sv);
1079	s = SvPVX(sv) + j;
1080	while (++j <= growsize) {
1081	*s++ = '\0';
1082	}
1083
1084	#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1085	s = SvPVX(sv);
1086	New(403, fd_sets[i], growsize, char);
1087	for (offset = 0; offset < growsize; offset += masksize) {
1088	for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1089	fd_sets[i][j+offset] = s[(k % masksize) + offset];
1090	}
1091	#else
1092	fd_sets[i] = SvPVX(sv);
1093	#endif
1094	}
1095
1096	#ifdef PERL_IRIX5_SELECT_TIMEVAL_VOID_CAST
1097	/* Can't make just the (void*) conditional because that would be
1098	* cpp #if within cpp macro, and not all compilers like that. */
1099	nfound = PerlSock_select(
1100	maxlen * 8,
1101	(Select_fd_set_t) fd_sets[1],
1102	(Select_fd_set_t) fd_sets[2],
1103	(Select_fd_set_t) fd_sets[3],
1104	(void) tbuf); / Workaround for compiler bug. */
1105	#else
1106	nfound = PerlSock_select(
1107	maxlen * 8,
1108	(Select_fd_set_t) fd_sets[1],
1109	(Select_fd_set_t) fd_sets[2],
1110	(Select_fd_set_t) fd_sets[3],
1111	tbuf);
1112	#endif
1113	for (i = 1; i <= 3; i++) {
1114	if (fd_sets[i]) {
1115	sv = SP[i];
1116	#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1117	s = SvPVX(sv);
1118	for (offset = 0; offset < growsize; offset += masksize) {
1119	for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1120	s[(k % masksize) + offset] = fd_sets[i][j+offset];
1121	}
1122	Safefree(fd_sets[i]);
1123	#endif
1124	SvSETMAGIC(sv);
1125	}
1126	}
1127
1128	PUSHi(nfound);
1129	if (GIMME == G_ARRAY && tbuf) {
1130	value = (NV)(timebuf.tv_sec) +
1131	(NV)(timebuf.tv_usec) / 1000000.0;
1132	PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1133	sv_setnv(sv, value);
1134	}
1135	RETURN;
1136	#else
1137	DIE(aTHX_ "select not implemented");
1138	#endif
1139	}
1140
1141	void
1142	Perl_setdefout(pTHX_ GV *gv)
1143	{
1144	if (gv)
1145	(void)SvREFCNT_inc(gv);
1146	if (PL_defoutgv)
1147	SvREFCNT_dec(PL_defoutgv);
1148	PL_defoutgv = gv;
1149	}
1150
1151	PP(pp_select)
1152	{
1153	dSP; dTARGET;
1154	GV newdefout, egv;
1155	HV *hv;
1156
1157	newdefout = (PL_op->op_private > 0) ? ((GV ) POPs) : (GV ) NULL;
1158
1159	egv = GvEGV(PL_defoutgv);
1160	if (!egv)
1161	egv = PL_defoutgv;
1162	hv = GvSTASH(egv);
1163	if (! hv)
1164	XPUSHs(&PL_sv_undef);
1165	else {
1166	GV gvp = (GV)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
1167	if (gvp && *gvp == egv) {
1168	gv_efullname4(TARG, PL_defoutgv, Nullch, TRUE);
1169	XPUSHTARG;
1170	}
1171	else {
1172	XPUSHs(sv_2mortal(newRV((SV*)egv)));
1173	}
1174	}
1175
1176	if (newdefout) {
1177	if (!GvIO(newdefout))
1178	gv_IOadd(newdefout);
1179	setdefout(newdefout);
1180	}
1181
1182	RETURN;
1183	}
1184
1185	PP(pp_getc)
1186	{
1187	dSP; dTARGET;
1188	GV *gv;
1189	IO *io = NULL;
1190	MAGIC *mg;
1191
1192	if (MAXARG == 0)
1193	gv = PL_stdingv;
1194	else
1195	gv = (GV*)POPs;
1196
1197	if (gv && (io = GvIO(gv))
1198	&& (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
1199	{
1200	I32 gimme = GIMME_V;
1201	PUSHMARK(SP);
1202	XPUSHs(SvTIED_obj((SV*)io, mg));
1203	PUTBACK;
1204	ENTER;
1205	call_method("GETC", gimme);
1206	LEAVE;
1207	SPAGAIN;
1208	if (gimme == G_SCALAR)
1209	SvSetMagicSV_nosteal(TARG, TOPs);
1210	RETURN;
1211	}
1212	if (!gv \|\| do_eof(gv)) { /* make sure we have fp with something */
1213	if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)
1214	&& (!io \|\| (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY)))
1215	report_evil_fh(gv, io, PL_op->op_type);
1216	SETERRNO(EBADF,RMS_IFI);
1217	RETPUSHUNDEF;
1218	}
1219	TAINT;
1220	sv_setpv(TARG, " ");
1221	SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); / should never be EOF */
1222	if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) {
1223	/* Find out how many bytes the char needs */
1224	Size_t len = UTF8SKIP(SvPVX(TARG));
1225	if (len > 1) {
1226	SvGROW(TARG,len+1);
1227	len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1);
1228	SvCUR_set(TARG,1+len);
1229	}
1230	SvUTF8_on(TARG);
1231	}
1232	PUSHTARG;
1233	RETURN;
1234	}
1235
1236	PP(pp_read)
1237	{
1238	return pp_sysread();
1239	}
1240
1241	STATIC OP *
1242	S_doform(pTHX_ CV cv, GV gv, OP *retop)
1243	{
1244	register PERL_CONTEXT *cx;
1245	I32 gimme = GIMME_V;
1246
1247	ENTER;
1248	SAVETMPS;
1249
1250	push_return(retop);
1251	PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
1252	PUSHFORMAT(cx);
1253	PAD_SET_CUR(CvPADLIST(cv), 1);
1254
1255	setdefout(gv); /* locally select filehandle so $% et al work */
1256	return CvSTART(cv);
1257	}
1258
1259	PP(pp_enterwrite)
1260	{
1261	dSP;
1262	register GV *gv;
1263	register IO *io;
1264	GV *fgv;
1265	CV *cv;
1266
1267	if (MAXARG == 0)
1268	gv = PL_defoutgv;
1269	else {
1270	gv = (GV*)POPs;
1271	if (!gv)
1272	gv = PL_defoutgv;
1273	}
1274	EXTEND(SP, 1);
1275	io = GvIO(gv);
1276	if (!io) {
1277	RETPUSHNO;
1278	}
1279	if (IoFMT_GV(io))
1280	fgv = IoFMT_GV(io);
1281	else
1282	fgv = gv;
1283
1284	cv = GvFORM(fgv);
1285	if (!cv) {
1286	char *name = NULL;
1287	if (fgv) {
1288	SV *tmpsv = sv_newmortal();
1289	gv_efullname4(tmpsv, fgv, Nullch, FALSE);
1290	name = SvPV_nolen(tmpsv);
1291	}
1292	if (name && *name)
1293	DIE(aTHX_ "Undefined format \"%s\" called", name);
1294	DIE(aTHX_ "Not a format reference");
1295	}
1296	if (CvCLONE(cv))
1297	cv = (CV)sv_2mortal((SV)cv_clone(cv));
1298
1299	IoFLAGS(io) &= ~IOf_DIDTOP;
1300	return doform(cv,gv,PL_op->op_next);
1301	}
1302
1303	PP(pp_leavewrite)
1304	{
1305	dSP;
1306	GV *gv = cxstack[cxstack_ix].blk_sub.gv;
1307	register IO *io = GvIOp(gv);
1308	PerlIO *ofp = IoOFP(io);
1309	PerlIO *fp;
1310	SV **newsp;
1311	I32 gimme;
1312	register PERL_CONTEXT *cx;
1313
1314	DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
1315	(long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1316	if (!io \|\| !ofp)
1317	goto forget_top;
1318	if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1319	PL_formtarget != PL_toptarget)
1320	{
1321	GV *fgv;
1322	CV *cv;
1323	if (!IoTOP_GV(io)) {
1324	GV *topgv;
1325	SV *topname;
1326
1327	if (!IoTOP_NAME(io)) {
1328	if (!IoFMT_NAME(io))
1329	IoFMT_NAME(io) = savepv(GvNAME(gv));
1330	topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%s_TOP", IoFMT_NAME(io)));
1331	topgv = gv_fetchpv(SvPVX(topname), FALSE, SVt_PVFM);
1332	if ((topgv && GvFORM(topgv)) \|\|
1333	!gv_fetchpv("top",FALSE,SVt_PVFM))
1334	IoTOP_NAME(io) = savepv(SvPVX(topname));
1335	else
1336	IoTOP_NAME(io) = savepv("top");
1337	}
1338	topgv = gv_fetchpv(IoTOP_NAME(io),FALSE, SVt_PVFM);
1339	if (!topgv \|\| !GvFORM(topgv)) {
1340	IoLINES_LEFT(io) = 100000000;
1341	goto forget_top;
1342	}
1343	IoTOP_GV(io) = topgv;
1344	}
1345	if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1346	I32 lines = IoLINES_LEFT(io);
1347	char *s = SvPVX(PL_formtarget);
1348	if (lines <= 0) /* Yow, header didn't even fit!!! */
1349	goto forget_top;
1350	while (lines-- > 0) {
1351	s = strchr(s, '\n');
1352	if (!s)
1353	break;
1354	s++;
1355	}
1356	if (s) {
1357	STRLEN save = SvCUR(PL_formtarget);
1358	SvCUR_set(PL_formtarget, s - SvPVX(PL_formtarget));
1359	do_print(PL_formtarget, ofp);
1360	SvCUR_set(PL_formtarget, save);
1361	sv_chop(PL_formtarget, s);
1362	FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
1363	}
1364	}
1365	if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
1366	do_print(PL_formfeed, ofp);
1367	IoLINES_LEFT(io) = IoPAGE_LEN(io);
1368	IoPAGE(io)++;
1369	PL_formtarget = PL_toptarget;
1370	IoFLAGS(io) \|= IOf_DIDTOP;
1371	fgv = IoTOP_GV(io);
1372	if (!fgv)
1373	DIE(aTHX_ "bad top format reference");
1374	cv = GvFORM(fgv);
1375	{
1376	char *name = NULL;
1377	if (!cv) {
1378	SV *sv = sv_newmortal();
1379	gv_efullname4(sv, fgv, Nullch, FALSE);
1380	name = SvPV_nolen(sv);
1381	}
1382	if (name && *name)
1383	DIE(aTHX_ "Undefined top format \"%s\" called",name);
1384	/* why no:
1385	else
1386	DIE(aTHX_ "Undefined top format called");
1387	?*/
1388	}
1389	if (CvCLONE(cv))
1390	cv = (CV)sv_2mortal((SV)cv_clone(cv));
1391	return doform(cv,gv,PL_op);
1392	}
1393
1394	forget_top:
1395	POPBLOCK(cx,PL_curpm);
1396	POPFORMAT(cx);
1397	LEAVE;
1398
1399	fp = IoOFP(io);
1400	if (!fp) {
1401	if (ckWARN2(WARN_CLOSED,WARN_IO)) {
1402	if (IoIFP(io))
1403	report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1404	else if (ckWARN(WARN_CLOSED))
1405	report_evil_fh(gv, io, PL_op->op_type);
1406	}
1407	PUSHs(&PL_sv_no);
1408	}
1409	else {
1410	if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
1411	if (ckWARN(WARN_IO))
1412	Perl_warner(aTHX_ packWARN(WARN_IO), "page overflow");
1413	}
1414	if (!do_print(PL_formtarget, fp))
1415	PUSHs(&PL_sv_no);
1416	else {
1417	FmLINES(PL_formtarget) = 0;
1418	SvCUR_set(PL_formtarget, 0);
1419	*SvEND(PL_formtarget) = '\0';
1420	if (IoFLAGS(io) & IOf_FLUSH)
1421	(void)PerlIO_flush(fp);
1422	PUSHs(&PL_sv_yes);
1423	}
1424	}
1425	/* bad_ofp: */
1426	PL_formtarget = PL_bodytarget;
1427	PUTBACK;
1428	return pop_return();
1429	}
1430
1431	PP(pp_prtf)
1432	{
1433	dSP; dMARK; dORIGMARK;
1434	GV *gv;
1435	IO *io;
1436	PerlIO *fp;
1437	SV *sv;
1438	MAGIC *mg;
1439
1440	if (PL_op->op_flags & OPf_STACKED)
1441	gv = (GV)++MARK;
1442	else
1443	gv = PL_defoutgv;
1444
1445	if (gv && (io = GvIO(gv))
1446	&& (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
1447	{
1448	if (MARK == ORIGMARK) {
1449	MEXTEND(SP, 1);
1450	++MARK;
1451	Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1452	++SP;
1453	}
1454	PUSHMARK(MARK - 1);
1455	MARK = SvTIED_obj((SV)io, mg);
1456	PUTBACK;
1457	ENTER;
1458	call_method("PRINTF", G_SCALAR);
1459	LEAVE;
1460	SPAGAIN;
1461	MARK = ORIGMARK + 1;
1462	MARK = SP;
1463	SP = MARK;
1464	RETURN;
1465	}
1466
1467	sv = NEWSV(0,0);
1468	if (!(io = GvIO(gv))) {
1469	if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1470	report_evil_fh(gv, io, PL_op->op_type);
1471	SETERRNO(EBADF,RMS_IFI);
1472	goto just_say_no;
1473	}
1474	else if (!(fp = IoOFP(io))) {
1475	if (ckWARN2(WARN_CLOSED,WARN_IO)) {
1476	if (IoIFP(io))
1477	report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1478	else if (ckWARN(WARN_CLOSED))
1479	report_evil_fh(gv, io, PL_op->op_type);
1480	}
1481	SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
1482	goto just_say_no;
1483	}
1484	else {
1485	do_sprintf(sv, SP - MARK, MARK + 1);
1486	if (!do_print(sv, fp))
1487	goto just_say_no;
1488
1489	if (IoFLAGS(io) & IOf_FLUSH)
1490	if (PerlIO_flush(fp) == EOF)
1491	goto just_say_no;
1492	}
1493	SvREFCNT_dec(sv);
1494	SP = ORIGMARK;
1495	PUSHs(&PL_sv_yes);
1496	RETURN;
1497
1498	just_say_no:
1499	SvREFCNT_dec(sv);
1500	SP = ORIGMARK;
1501	PUSHs(&PL_sv_undef);
1502	RETURN;
1503	}
1504
1505	PP(pp_sysopen)
1506	{
1507	dSP;
1508	GV *gv;
1509	SV *sv;
1510	char *tmps;
1511	STRLEN len;
1512	int mode, perm;
1513
1514	if (MAXARG > 3)
1515	perm = POPi;
1516	else
1517	perm = 0666;
1518	mode = POPi;
1519	sv = POPs;
1520	gv = (GV *)POPs;
1521
1522	/* Need TIEHANDLE method ? */
1523
1524	tmps = SvPV(sv, len);
1525	if (do_open(gv, tmps, len, TRUE, mode, perm, Nullfp)) {
1526	IoLINES(GvIOp(gv)) = 0;
1527	PUSHs(&PL_sv_yes);
1528	}
1529	else {
1530	PUSHs(&PL_sv_undef);
1531	}
1532	RETURN;
1533	}
1534
1535	PP(pp_sysread)
1536	{
1537	dSP; dMARK; dORIGMARK; dTARGET;
1538	int offset;
1539	GV *gv;
1540	IO *io;
1541	char *buffer;
1542	SSize_t length;
1543	SSize_t count;
1544	Sock_size_t bufsize;
1545	SV *bufsv;
1546	STRLEN blen;
1547	MAGIC *mg;
1548	int fp_utf8;
1549	Size_t got = 0;
1550	Size_t wanted;
1551	bool charstart = FALSE;
1552	STRLEN charskip = 0;
1553	STRLEN skip = 0;
1554
1555	gv = (GV)++MARK;
1556	if ((PL_op->op_type == OP_READ \|\| PL_op->op_type == OP_SYSREAD)
1557	&& gv && (io = GvIO(gv))
1558	&& (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
1559	{
1560	SV *sv;
1561
1562	PUSHMARK(MARK-1);
1563	MARK = SvTIED_obj((SV)io, mg);
1564	ENTER;
1565	call_method("READ", G_SCALAR);
1566	LEAVE;
1567	SPAGAIN;
1568	sv = POPs;
1569	SP = ORIGMARK;
1570	PUSHs(sv);
1571	RETURN;
1572	}
1573
1574	if (!gv)
1575	goto say_undef;
1576	bufsv = *++MARK;
1577	if (! SvOK(bufsv))
1578	sv_setpvn(bufsv, "", 0);
1579	length = SvIVx(*++MARK);
1580	SETERRNO(0,0);
1581	if (MARK < SP)
1582	offset = SvIVx(*++MARK);
1583	else
1584	offset = 0;
1585	io = GvIO(gv);
1586	if (!io \|\| !IoIFP(io)) {
1587	if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1588	report_evil_fh(gv, io, PL_op->op_type);
1589	SETERRNO(EBADF,RMS_IFI);
1590	goto say_undef;
1591	}
1592	if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
1593	buffer = SvPVutf8_force(bufsv, blen);
1594	/* UTF-8 may not have been set if they are all low bytes */
1595	SvUTF8_on(bufsv);
1596	}
1597	else {
1598	buffer = SvPV_force(bufsv, blen);
1599	}
1600	if (length < 0)
1601	DIE(aTHX_ "Negative length");
1602	wanted = length;
1603
1604	charstart = TRUE;
1605	charskip = 0;
1606	skip = 0;
1607
1608	#ifdef HAS_SOCKET
1609	if (PL_op->op_type == OP_RECV) {
1610	char namebuf[MAXPATHLEN];
1611	#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) \|\| defined(MPE) \|\| defined(__QNXNTO__)
1612	bufsize = sizeof (struct sockaddr_in);
1613	#else
1614	bufsize = sizeof namebuf;
1615	#endif
1616	#ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1617	if (bufsize >= 256)
1618	bufsize = 255;
1619	#endif
1620	buffer = SvGROW(bufsv, (STRLEN)(length+1));
1621	/* 'offset' means 'flags' here */
1622	count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
1623	(struct sockaddr *)namebuf, &bufsize);
1624	if (count < 0)
1625	RETPUSHUNDEF;
1626	#ifdef EPOC
1627	/* Bogus return without padding */
1628	bufsize = sizeof (struct sockaddr_in);
1629	#endif
1630	SvCUR_set(bufsv, count);
1631	*SvEND(bufsv) = '\0';
1632	(void)SvPOK_only(bufsv);
1633	if (fp_utf8)
1634	SvUTF8_on(bufsv);
1635	SvSETMAGIC(bufsv);
1636	/* This should not be marked tainted if the fp is marked clean */
1637	if (!(IoFLAGS(io) & IOf_UNTAINT))
1638	SvTAINTED_on(bufsv);
1639	SP = ORIGMARK;
1640	sv_setpvn(TARG, namebuf, bufsize);
1641	PUSHs(TARG);
1642	RETURN;
1643	}
1644	#else
1645	if (PL_op->op_type == OP_RECV)
1646	DIE(aTHX_ PL_no_sock_func, "recv");
1647	#endif
1648	if (DO_UTF8(bufsv)) {
1649	/* offset adjust in characters not bytes */
1650	blen = sv_len_utf8(bufsv);
1651	}
1652	if (offset < 0) {
1653	if (-offset > (int)blen)
1654	DIE(aTHX_ "Offset outside string");
1655	offset += blen;
1656	}
1657	if (DO_UTF8(bufsv)) {
1658	/* convert offset-as-chars to offset-as-bytes */
1659	offset = utf8_hop((U8 )buffer,offset) - (U8 ) buffer;
1660	}
1661	more_bytes:
1662	bufsize = SvCUR(bufsv);
1663	buffer = SvGROW(bufsv, (STRLEN)(length+offset+1));
1664	if (offset > bufsize) { /* Zero any newly allocated space */
1665	Zero(buffer+bufsize, offset-bufsize, char);
1666	}
1667	buffer = buffer + offset;
1668
1669	if (PL_op->op_type == OP_SYSREAD) {
1670	#ifdef PERL_SOCK_SYSREAD_IS_RECV
1671	if (IoTYPE(io) == IoTYPE_SOCKET) {
1672	count = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
1673	buffer, length, 0);
1674	}
1675	else
1676	#endif
1677	{
1678	count = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
1679	buffer, length);
1680	}
1681	}
1682	else
1683	#ifdef HAS_SOCKET__bad_code_maybe
1684	if (IoTYPE(io) == IoTYPE_SOCKET) {
1685	char namebuf[MAXPATHLEN];
1686	#if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
1687	bufsize = sizeof (struct sockaddr_in);
1688	#else
1689	bufsize = sizeof namebuf;
1690	#endif
1691	count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, 0,
1692	(struct sockaddr *)namebuf, &bufsize);
1693	}
1694	else
1695	#endif
1696	{
1697	count = PerlIO_read(IoIFP(io), buffer, length);
1698	/* PerlIO_read() - like fread() returns 0 on both error and EOF */
1699	if (count == 0 && PerlIO_error(IoIFP(io)))
1700	count = -1;
1701	}
1702	if (count < 0) {
1703	if ((IoTYPE(io) == IoTYPE_WRONLY) && ckWARN(WARN_IO))
1704	report_evil_fh(gv, io, OP_phoney_OUTPUT_ONLY);
1705	goto say_undef;
1706	}
1707	SvCUR_set(bufsv, count+(buffer - SvPVX(bufsv)));
1708	*SvEND(bufsv) = '\0';
1709	(void)SvPOK_only(bufsv);
1710	if (fp_utf8 && !IN_BYTES) {
1711	/* Look at utf8 we got back and count the characters */
1712	char *bend = buffer + count;
1713	while (buffer < bend) {
1714	if (charstart) {
1715	skip = UTF8SKIP(buffer);
1716	charskip = 0;
1717	}
1718	if (buffer - charskip + skip > bend) {
1719	/* partial character - try for rest of it */
1720	length = skip - (bend-buffer);
1721	offset = bend - SvPVX(bufsv);
1722	charstart = FALSE;
1723	charskip += count;
1724	goto more_bytes;
1725	}
1726	else {
1727	got++;
1728	buffer += skip;
1729	charstart = TRUE;
1730	charskip = 0;
1731	}
1732	}
1733	/* If we have not 'got' the number of _characters_ we 'wanted' get some more
1734	provided amount read (count) was what was requested (length)
1735	*/
1736	if (got < wanted && count == length) {
1737	length = wanted - got;
1738	offset = bend - SvPVX(bufsv);
1739	goto more_bytes;
1740	}
1741	/* return value is character count */
1742	count = got;
1743	SvUTF8_on(bufsv);
1744	}
1745	SvSETMAGIC(bufsv);
1746	/* This should not be marked tainted if the fp is marked clean */
1747	if (!(IoFLAGS(io) & IOf_UNTAINT))
1748	SvTAINTED_on(bufsv);
1749	SP = ORIGMARK;
1750	PUSHi(count);
1751	RETURN;
1752
1753	say_undef:
1754	SP = ORIGMARK;
1755	RETPUSHUNDEF;
1756	}
1757
1758	PP(pp_syswrite)
1759	{
1760	dSP;
1761	int items = (SP - PL_stack_base) - TOPMARK;
1762	if (items == 2) {
1763	SV *sv;
1764	EXTEND(SP, 1);
1765	sv = sv_2mortal(newSViv(sv_len(*SP)));
1766	PUSHs(sv);
1767	PUTBACK;
1768	}
1769	return pp_send();
1770	}
1771
1772	PP(pp_send)
1773	{
1774	dSP; dMARK; dORIGMARK; dTARGET;
1775	GV *gv;
1776	IO *io;
1777	SV *bufsv;
1778	char *buffer;
1779	Size_t length;
1780	SSize_t retval;
1781	STRLEN blen;
1782	MAGIC *mg;
1783
1784	gv = (GV)++MARK;
1785	if (PL_op->op_type == OP_SYSWRITE
1786	&& gv && (io = GvIO(gv))
1787	&& (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
1788	{
1789	SV *sv;
1790
1791	PUSHMARK(MARK-1);
1792	MARK = SvTIED_obj((SV)io, mg);
1793	ENTER;
1794	call_method("WRITE", G_SCALAR);
1795	LEAVE;
1796	SPAGAIN;
1797	sv = POPs;
1798	SP = ORIGMARK;
1799	PUSHs(sv);
1800	RETURN;
1801	}
1802	if (!gv)
1803	goto say_undef;
1804	bufsv = *++MARK;
1805	#if Size_t_size > IVSIZE
1806	length = (Size_t)SvNVx(*++MARK);
1807	#else
1808	length = (Size_t)SvIVx(*++MARK);
1809	#endif
1810	if ((SSize_t)length < 0)
1811	DIE(aTHX_ "Negative length");
1812	SETERRNO(0,0);
1813	io = GvIO(gv);
1814	if (!io \|\| !IoIFP(io)) {
1815	retval = -1;
1816	if (ckWARN(WARN_CLOSED))
1817	report_evil_fh(gv, io, PL_op->op_type);
1818	SETERRNO(EBADF,RMS_IFI);
1819	goto say_undef;
1820	}
1821
1822	if (PerlIO_isutf8(IoIFP(io))) {
1823	buffer = SvPVutf8(bufsv, blen);
1824	}
1825	else {
1826	if (DO_UTF8(bufsv)) {
1827	/* Not modifying source SV, so making a temporary copy. */
1828	bufsv = sv_2mortal(newSVsv(bufsv));
1829	sv_utf8_downgrade(bufsv, FALSE);
1830	}
1831	buffer = SvPV(bufsv, blen);
1832	}
1833
1834	if (PL_op->op_type == OP_SYSWRITE) {
1835	IV offset;
1836	if (DO_UTF8(bufsv)) {
1837	/* length and offset are in chars */
1838	blen = sv_len_utf8(bufsv);
1839	}
1840	if (MARK < SP) {
1841	offset = SvIVx(*++MARK);
1842	if (offset < 0) {
1843	if (-offset > (IV)blen)
1844	DIE(aTHX_ "Offset outside string");
1845	offset += blen;
1846	} else if (offset >= (IV)blen && blen > 0)
1847	DIE(aTHX_ "Offset outside string");
1848	} else
1849	offset = 0;
1850	if (length > blen - offset)
1851	length = blen - offset;
1852	if (DO_UTF8(bufsv)) {
1853	buffer = (char)utf8_hop((U8 )buffer, offset);
1854	length = utf8_hop((U8 )buffer, length) - (U8 )buffer;
1855	}
1856	else {
1857	buffer = buffer+offset;
1858	}
1859	#ifdef PERL_SOCK_SYSWRITE_IS_SEND
1860	if (IoTYPE(io) == IoTYPE_SOCKET) {
1861	retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
1862	buffer, length, 0);
1863	}
1864	else
1865	#endif
1866	{
1867	/* See the note at doio.c:do_print about filesize limits. --jhi */
1868	retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
1869	buffer, length);
1870	}
1871	}
1872	#ifdef HAS_SOCKET
1873	else if (SP > MARK) {
1874	char *sockbuf;
1875	STRLEN mlen;
1876	sockbuf = SvPVx(*++MARK, mlen);
1877	/* length is really flags */
1878	retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
1879	length, (struct sockaddr *)sockbuf, mlen);
1880	}
1881	else
1882	/* length is really flags */
1883	retval = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, length);
1884	#else
1885	else
1886	DIE(aTHX_ PL_no_sock_func, "send");
1887	#endif
1888	if (retval < 0)
1889	goto say_undef;
1890	SP = ORIGMARK;
1891	if (DO_UTF8(bufsv))
1892	retval = utf8_length((U8)buffer, (U8)buffer + retval);
1893	#if Size_t_size > IVSIZE
1894	PUSHn(retval);
1895	#else
1896	PUSHi(retval);
1897	#endif
1898	RETURN;
1899
1900	say_undef:
1901	SP = ORIGMARK;
1902	RETPUSHUNDEF;
1903	}
1904
1905	PP(pp_recv)
1906	{
1907	return pp_sysread();
1908	}
1909
1910	PP(pp_eof)
1911	{
1912	dSP;
1913	GV *gv;
1914	IO *io;
1915	MAGIC *mg;
1916
1917	if (MAXARG == 0) {
1918	if (PL_op->op_flags & OPf_SPECIAL) { /* eof() */
1919	IO *io;
1920	gv = PL_last_in_gv = GvEGV(PL_argvgv);
1921	io = GvIO(gv);
1922	if (io && !IoIFP(io)) {
1923	if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) {
1924	IoLINES(io) = 0;
1925	IoFLAGS(io) &= ~IOf_START;
1926	do_open(gv, "-", 1, FALSE, O_RDONLY, 0, Nullfp);
1927	sv_setpvn(GvSV(gv), "-", 1);
1928	SvSETMAGIC(GvSV(gv));
1929	}
1930	else if (!nextargv(gv))
1931	RETPUSHYES;
1932	}
1933	}
1934	else
1935	gv = PL_last_in_gv; /* eof */
1936	}
1937	else
1938	gv = PL_last_in_gv = (GV)POPs; / eof(FH) */
1939
1940	if (gv && (io = GvIO(gv))
1941	&& (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
1942	{
1943	PUSHMARK(SP);
1944	XPUSHs(SvTIED_obj((SV*)io, mg));
1945	PUTBACK;
1946	ENTER;
1947	call_method("EOF", G_SCALAR);
1948	LEAVE;
1949	SPAGAIN;
1950	RETURN;
1951	}
1952
1953	PUSHs(boolSV(!gv \|\| do_eof(gv)));
1954	RETURN;
1955	}
1956
1957	PP(pp_tell)
1958	{
1959	dSP; dTARGET;
1960	GV *gv;
1961	IO *io;
1962	MAGIC *mg;
1963
1964	if (MAXARG == 0)
1965	gv = PL_last_in_gv;
1966	else
1967	gv = PL_last_in_gv = (GV*)POPs;
1968
1969	if (gv && (io = GvIO(gv))
1970	&& (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
1971	{
1972	PUSHMARK(SP);
1973	XPUSHs(SvTIED_obj((SV*)io, mg));
1974	PUTBACK;
1975	ENTER;
1976	call_method("TELL", G_SCALAR);
1977	LEAVE;
1978	SPAGAIN;
1979	RETURN;
1980	}
1981
1982	#if LSEEKSIZE > IVSIZE
1983	PUSHn( do_tell(gv) );
1984	#else
1985	PUSHi( do_tell(gv) );
1986	#endif
1987	RETURN;
1988	}
1989
1990	PP(pp_seek)
1991	{
1992	return pp_sysseek();
1993	}
1994
1995	PP(pp_sysseek)
1996	{
1997	dSP;
1998	GV *gv;
1999	IO *io;
2000	int whence = POPi;
2001	#if LSEEKSIZE > IVSIZE
2002	Off_t offset = (Off_t)SvNVx(POPs);
2003	#else
2004	Off_t offset = (Off_t)SvIVx(POPs);
2005	#endif
2006	MAGIC *mg;
2007
2008	gv = PL_last_in_gv = (GV*)POPs;
2009
2010	if (gv && (io = GvIO(gv))
2011	&& (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
2012	{
2013	PUSHMARK(SP);
2014	XPUSHs(SvTIED_obj((SV*)io, mg));
2015	#if LSEEKSIZE > IVSIZE
2016	XPUSHs(sv_2mortal(newSVnv((NV) offset)));
2017	#else
2018	XPUSHs(sv_2mortal(newSViv(offset)));
2019	#endif
2020	XPUSHs(sv_2mortal(newSViv(whence)));
2021	PUTBACK;
2022	ENTER;
2023	call_method("SEEK", G_SCALAR);
2024	LEAVE;
2025	SPAGAIN;
2026	RETURN;
2027	}
2028
2029	if (PL_op->op_type == OP_SEEK)
2030	PUSHs(boolSV(do_seek(gv, offset, whence)));
2031	else {
2032	Off_t sought = do_sysseek(gv, offset, whence);
2033	if (sought < 0)
2034	PUSHs(&PL_sv_undef);
2035	else {
2036	SV* sv = sought ?
2037	#if LSEEKSIZE > IVSIZE
2038	newSVnv((NV)sought)
2039	#else
2040	newSViv(sought)
2041	#endif
2042	: newSVpvn(zero_but_true, ZBTLEN);
2043	PUSHs(sv_2mortal(sv));
2044	}
2045	}
2046	RETURN;
2047	}
2048
2049	PP(pp_truncate)
2050	{
2051	dSP;
2052	/* There seems to be no consensus on the length type of truncate()
2053	* and ftruncate(), both off_t and size_t have supporters. In
2054	* general one would think that when using large files, off_t is
2055	* at least as wide as size_t, so using an off_t should be okay. */
2056	/* XXX Configure probe for the length type of truncate() needed XXX /
2057	Off_t len;
2058
2059	#if Off_t_size > IVSIZE
2060	len = (Off_t)POPn;
2061	#else
2062	len = (Off_t)POPi;
2063	#endif
2064	/* Checking for length < 0 is problematic as the type might or
2065	* might not be signed: if it is not, clever compilers will moan. */
2066	/* XXX Configure probe for the signedness of the length type of truncate() needed? XXX /
2067	SETERRNO(0,0);
2068	#if defined(HAS_TRUNCATE) \|\| defined(HAS_CHSIZE) \|\| defined(F_FREESP)
2069	{
2070	STRLEN n_a;
2071	int result = 1;
2072	GV *tmpgv;
2073	IO *io;
2074
2075	if (PL_op->op_flags & OPf_SPECIAL) {
2076	tmpgv = gv_fetchpv(POPpx, FALSE, SVt_PVIO);
2077
2078	do_ftruncate_gv:
2079	if (!GvIO(tmpgv))
2080	result = 0;
2081	else {
2082	PerlIO *fp;
2083	io = GvIOp(tmpgv);
2084	do_ftruncate_io:
2085	TAINT_PROPER("truncate");
2086	if (!(fp = IoIFP(io))) {
2087	result = 0;
2088	}
2089	else {
2090	PerlIO_flush(fp);
2091	#ifdef HAS_TRUNCATE
2092	if (ftruncate(PerlIO_fileno(fp), len) < 0)
2093	#else
2094	if (my_chsize(PerlIO_fileno(fp), len) < 0)
2095	#endif
2096	result = 0;
2097	}
2098	}
2099	}
2100	else {
2101	SV *sv = POPs;
2102	char *name;
2103
2104	if (SvTYPE(sv) == SVt_PVGV) {
2105	tmpgv = (GV)sv; / main::FRED for example /
2106	goto do_ftruncate_gv;
2107	}
2108	else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2109	tmpgv = (GV) SvRV(sv); / \main::FRED for example /
2110	goto do_ftruncate_gv;
2111	}
2112	else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2113	io = (IO) SvRV(sv); / main::FRED{IO} for example /
2114	goto do_ftruncate_io;
2115	}
2116
2117	name = SvPV(sv, n_a);
2118	TAINT_PROPER("truncate");
2119	#ifdef HAS_TRUNCATE
2120	if (truncate(name, len) < 0)
2121	result = 0;
2122	#else
2123	{
2124	int tmpfd;
2125
2126	if ((tmpfd = PerlLIO_open(name, O_RDWR)) < 0)
2127	result = 0;
2128	else {
2129	if (my_chsize(tmpfd, len) < 0)
2130	result = 0;
2131	PerlLIO_close(tmpfd);
2132	}
2133	}
2134	#endif
2135	}
2136
2137	if (result)
2138	RETPUSHYES;
2139	if (!errno)
2140	SETERRNO(EBADF,RMS_IFI);
2141	RETPUSHUNDEF;
2142	}
2143	#else
2144	DIE(aTHX_ "truncate not implemented");
2145	#endif
2146	}
2147
2148	PP(pp_fcntl)
2149	{
2150	return pp_ioctl();
2151	}
2152
2153	PP(pp_ioctl)
2154	{
2155	dSP; dTARGET;
2156	SV *argsv = POPs;
2157	unsigned int func = POPu;
2158	int optype = PL_op->op_type;
2159	char *s;
2160	IV retval;
2161	GV gv = (GV)POPs;
2162	IO *io = gv ? GvIOn(gv) : 0;
2163
2164	if (!io \|\| !argsv \|\| !IoIFP(io)) {
2165	if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2166	report_evil_fh(gv, io, PL_op->op_type);
2167	SETERRNO(EBADF,RMS_IFI); /* well, sort of... */
2168	RETPUSHUNDEF;
2169	}
2170
2171	if (SvPOK(argsv) \|\| !SvNIOK(argsv)) {
2172	STRLEN len;
2173	STRLEN need;
2174	s = SvPV_force(argsv, len);
2175	need = IOCPARM_LEN(func);
2176	if (len < need) {
2177	s = Sv_Grow(argsv, need + 1);
2178	SvCUR_set(argsv, need);
2179	}
2180
2181	s[SvCUR(argsv)] = 17; /* a little sanity check here */
2182	}
2183	else {
2184	retval = SvIV(argsv);
2185	s = INT2PTR(char,retval); / ouch */
2186	}
2187
2188	TAINT_PROPER(optype == OP_IOCTL ? "ioctl" : "fcntl");
2189
2190	if (optype == OP_IOCTL)
2191	#ifdef HAS_IOCTL
2192	retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
2193	#else
2194	DIE(aTHX_ "ioctl is not implemented");
2195	#endif
2196	else
2197	#ifndef HAS_FCNTL
2198	DIE(aTHX_ "fcntl is not implemented");
2199	#else
2200	#if defined(OS2) && defined(__EMX__)
2201	retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
2202	#else
2203	retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
2204	#endif
2205	#endif
2206
2207	#if defined(HAS_IOCTL) \|\| defined(HAS_FCNTL)
2208	if (SvPOK(argsv)) {
2209	if (s[SvCUR(argsv)] != 17)
2210	DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
2211	OP_NAME(PL_op));
2212	s[SvCUR(argsv)] = 0; /* put our null back */
2213	SvSETMAGIC(argsv); /* Assume it has changed */
2214	}
2215
2216	if (retval == -1)
2217	RETPUSHUNDEF;
2218	if (retval != 0) {
2219	PUSHi(retval);
2220	}
2221	else {
2222	PUSHp(zero_but_true, ZBTLEN);
2223	}
2224	#endif
2225	RETURN;
2226	}
2227
2228	PP(pp_flock)
2229	{
2230	#ifdef FLOCK
2231	dSP; dTARGET;
2232	I32 value;
2233	int argtype;
2234	GV *gv;
2235	IO *io = NULL;
2236	PerlIO *fp;
2237
2238	argtype = POPi;
2239	if (MAXARG == 0)
2240	gv = PL_last_in_gv;
2241	else
2242	gv = (GV*)POPs;
2243	if (gv && (io = GvIO(gv)))
2244	fp = IoIFP(io);
2245	else {
2246	fp = Nullfp;
2247	io = NULL;
2248	}
2249	if (fp) {
2250	(void)PerlIO_flush(fp);
2251	value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
2252	}
2253	else {
2254	if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2255	report_evil_fh(gv, io, PL_op->op_type);
2256	value = 0;
2257	SETERRNO(EBADF,RMS_IFI);
2258	}
2259	PUSHi(value);
2260	RETURN;
2261	#else
2262	DIE(aTHX_ PL_no_func, "flock()");
2263	#endif
2264	}
2265
2266	/* Sockets. */
2267
2268	PP(pp_socket)
2269	{
2270	#ifdef HAS_SOCKET
2271	dSP;
2272	GV *gv;
2273	register IO *io;
2274	int protocol = POPi;
2275	int type = POPi;
2276	int domain = POPi;
2277	int fd;
2278
2279	gv = (GV*)POPs;
2280	io = gv ? GvIOn(gv) : NULL;
2281
2282	if (!gv \|\| !io) {
2283	if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2284	report_evil_fh(gv, io, PL_op->op_type);
2285	if (IoIFP(io))
2286	do_close(gv, FALSE);
2287	SETERRNO(EBADF,LIB_INVARG);
2288	RETPUSHUNDEF;
2289	}
2290
2291	if (IoIFP(io))
2292	do_close(gv, FALSE);
2293
2294	TAINT_PROPER("socket");
2295	fd = PerlSock_socket(domain, type, protocol);
2296	if (fd < 0)
2297	RETPUSHUNDEF;
2298	IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
2299	IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2300	IoTYPE(io) = IoTYPE_SOCKET;
2301	if (!IoIFP(io) \|\| !IoOFP(io)) {
2302	if (IoIFP(io)) PerlIO_close(IoIFP(io));
2303	if (IoOFP(io)) PerlIO_close(IoOFP(io));
2304	if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
2305	RETPUSHUNDEF;
2306	}
2307	#if defined(HAS_FCNTL) && defined(F_SETFD)
2308	fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2309	#endif
2310
2311	#ifdef EPOC
2312	setbuf( IoIFP(io), NULL); /* EPOC gets confused about sockets */
2313	#endif
2314
2315	RETPUSHYES;
2316	#else
2317	DIE(aTHX_ PL_no_sock_func, "socket");
2318	#endif
2319	}
2320
2321	PP(pp_sockpair)
2322	{
2323	#if defined (HAS_SOCKETPAIR) \|\| (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
2324	dSP;
2325	GV *gv1;
2326	GV *gv2;
2327	register IO *io1;
2328	register IO *io2;
2329	int protocol = POPi;
2330	int type = POPi;
2331	int domain = POPi;
2332	int fd[2];
2333
2334	gv2 = (GV*)POPs;
2335	gv1 = (GV*)POPs;
2336	io1 = gv1 ? GvIOn(gv1) : NULL;
2337	io2 = gv2 ? GvIOn(gv2) : NULL;
2338	if (!gv1 \|\| !gv2 \|\| !io1 \|\| !io2) {
2339	if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
2340	if (!gv1 \|\| !io1)
2341	report_evil_fh(gv1, io1, PL_op->op_type);
2342	if (!gv2 \|\| !io2)
2343	report_evil_fh(gv1, io2, PL_op->op_type);
2344	}
2345	if (IoIFP(io1))
2346	do_close(gv1, FALSE);
2347	if (IoIFP(io2))
2348	do_close(gv2, FALSE);
2349	RETPUSHUNDEF;
2350	}
2351
2352	if (IoIFP(io1))
2353	do_close(gv1, FALSE);
2354	if (IoIFP(io2))
2355	do_close(gv2, FALSE);
2356
2357	TAINT_PROPER("socketpair");
2358	if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
2359	RETPUSHUNDEF;
2360	IoIFP(io1) = PerlIO_fdopen(fd[0], "r"SOCKET_OPEN_MODE);
2361	IoOFP(io1) = PerlIO_fdopen(fd[0], "w"SOCKET_OPEN_MODE);
2362	IoTYPE(io1) = IoTYPE_SOCKET;
2363	IoIFP(io2) = PerlIO_fdopen(fd[1], "r"SOCKET_OPEN_MODE);
2364	IoOFP(io2) = PerlIO_fdopen(fd[1], "w"SOCKET_OPEN_MODE);
2365	IoTYPE(io2) = IoTYPE_SOCKET;
2366	if (!IoIFP(io1) \|\| !IoOFP(io1) \|\| !IoIFP(io2) \|\| !IoOFP(io2)) {
2367	if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2368	if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2369	if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2370	if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2371	if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2372	if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2373	RETPUSHUNDEF;
2374	}
2375	#if defined(HAS_FCNTL) && defined(F_SETFD)
2376	fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
2377	fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
2378	#endif
2379
2380	RETPUSHYES;
2381	#else
2382	DIE(aTHX_ PL_no_sock_func, "socketpair");
2383	#endif
2384	}
2385
2386	PP(pp_bind)
2387	{
2388	#ifdef HAS_SOCKET
2389	dSP;
2390	#ifdef MPE /* Requires PRIV mode to bind() to ports < 1024 */
2391	extern void GETPRIVMODE();
2392	extern void GETUSERMODE();
2393	#endif
2394	SV *addrsv = POPs;
2395	char *addr;
2396	GV gv = (GV)POPs;
2397	register IO *io = GvIOn(gv);
2398	STRLEN len;
2399	int bind_ok = 0;
2400	#ifdef MPE
2401	int mpeprivmode = 0;
2402	#endif
2403
2404	if (!io \|\| !IoIFP(io))
2405	goto nuts;
2406
2407	addr = SvPV(addrsv, len);
2408	TAINT_PROPER("bind");
2409	#ifdef MPE /* Deal with MPE bind() peculiarities */
2410	if (((struct sockaddr *)addr)->sa_family == AF_INET) {
2411	/* The address MUST stupidly be zero. */
2412	((struct sockaddr_in *)addr)->sin_addr.s_addr = INADDR_ANY;
2413	/* PRIV mode is required to bind() to ports < 1024. */
2414	if (((struct sockaddr_in *)addr)->sin_port < 1024 &&
2415	((struct sockaddr_in *)addr)->sin_port > 0) {
2416	GETPRIVMODE(); /* If this fails, we are aborted by MPE/iX. */
2417	mpeprivmode = 1;
2418	}
2419	}
2420	#endif /* MPE */
2421	if (PerlSock_bind(PerlIO_fileno(IoIFP(io)),
2422	(struct sockaddr *)addr, len) >= 0)
2423	bind_ok = 1;
2424
2425	#ifdef MPE /* Switch back to USER mode */
2426	if (mpeprivmode)
2427	GETUSERMODE();
2428	#endif /* MPE */
2429
2430	if (bind_ok)
2431	RETPUSHYES;
2432	else
2433	RETPUSHUNDEF;
2434
2435	nuts:
2436	if (ckWARN(WARN_CLOSED))
2437	report_evil_fh(gv, io, PL_op->op_type);
2438	SETERRNO(EBADF,SS_IVCHAN);
2439	RETPUSHUNDEF;
2440	#else
2441	DIE(aTHX_ PL_no_sock_func, "bind");
2442	#endif
2443	}
2444
2445	PP(pp_connect)
2446	{
2447	#ifdef HAS_SOCKET
2448	dSP;
2449	SV *addrsv = POPs;
2450	char *addr;
2451	GV gv = (GV)POPs;
2452	register IO *io = GvIOn(gv);
2453	STRLEN len;
2454
2455	if (!io \|\| !IoIFP(io))
2456	goto nuts;
2457
2458	addr = SvPV(addrsv, len);
2459	TAINT_PROPER("connect");
2460	if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
2461	RETPUSHYES;
2462	else
2463	RETPUSHUNDEF;
2464
2465	nuts:
2466	if (ckWARN(WARN_CLOSED))
2467	report_evil_fh(gv, io, PL_op->op_type);
2468	SETERRNO(EBADF,SS_IVCHAN);
2469	RETPUSHUNDEF;
2470	#else
2471	DIE(aTHX_ PL_no_sock_func, "connect");
2472	#endif
2473	}
2474
2475	PP(pp_listen)
2476	{
2477	#ifdef HAS_SOCKET
2478	dSP;
2479	int backlog = POPi;
2480	GV gv = (GV)POPs;
2481	register IO *io = gv ? GvIOn(gv) : NULL;
2482
2483	if (!gv \|\| !io \|\| !IoIFP(io))
2484	goto nuts;
2485
2486	if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2487	RETPUSHYES;
2488	else
2489	RETPUSHUNDEF;
2490
2491	nuts:
2492	if (ckWARN(WARN_CLOSED))
2493	report_evil_fh(gv, io, PL_op->op_type);
2494	SETERRNO(EBADF,SS_IVCHAN);
2495	RETPUSHUNDEF;
2496	#else
2497	DIE(aTHX_ PL_no_sock_func, "listen");
2498	#endif
2499	}
2500
2501	PP(pp_accept)
2502	{
2503	#ifdef HAS_SOCKET
2504	dSP; dTARGET;
2505	GV *ngv;
2506	GV *ggv;
2507	register IO *nstio;
2508	register IO *gstio;
2509	char namebuf[MAXPATHLEN];
2510	#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) \|\| defined(MPE) \|\| defined(__QNXNTO__)
2511	Sock_size_t len = sizeof (struct sockaddr_in);
2512	#else
2513	Sock_size_t len = sizeof namebuf;
2514	#endif
2515	int fd;
2516
2517	ggv = (GV*)POPs;
2518	ngv = (GV*)POPs;
2519
2520	if (!ngv)
2521	goto badexit;
2522	if (!ggv)
2523	goto nuts;
2524
2525	gstio = GvIO(ggv);
2526	if (!gstio \|\| !IoIFP(gstio))
2527	goto nuts;
2528
2529	nstio = GvIOn(ngv);
2530	fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
2531	if (fd < 0)
2532	goto badexit;
2533	if (IoIFP(nstio))
2534	do_close(ngv, FALSE);
2535	IoIFP(nstio) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);
2536	IoOFP(nstio) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2537	IoTYPE(nstio) = IoTYPE_SOCKET;
2538	if (!IoIFP(nstio) \|\| !IoOFP(nstio)) {
2539	if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2540	if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2541	if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2542	goto badexit;
2543	}
2544	#if defined(HAS_FCNTL) && defined(F_SETFD)
2545	fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2546	#endif
2547
2548	#ifdef EPOC
2549	len = sizeof (struct sockaddr_in); /* EPOC somehow truncates info */
2550	setbuf( IoIFP(nstio), NULL); /* EPOC gets confused about sockets */
2551	#endif
2552	#ifdef __SCO_VERSION__
2553	len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
2554	#endif
2555
2556	PUSHp(namebuf, len);
2557	RETURN;
2558
2559	nuts:
2560	if (ckWARN(WARN_CLOSED))
2561	report_evil_fh(ggv, ggv ? GvIO(ggv) : 0, PL_op->op_type);
2562	SETERRNO(EBADF,SS_IVCHAN);
2563
2564	badexit:
2565	RETPUSHUNDEF;
2566
2567	#else
2568	DIE(aTHX_ PL_no_sock_func, "accept");
2569	#endif
2570	}
2571
2572	PP(pp_shutdown)
2573	{
2574	#ifdef HAS_SOCKET
2575	dSP; dTARGET;
2576	int how = POPi;
2577	GV gv = (GV)POPs;
2578	register IO *io = GvIOn(gv);
2579
2580	if (!io \|\| !IoIFP(io))
2581	goto nuts;
2582
2583	PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2584	RETURN;
2585
2586	nuts:
2587	if (ckWARN(WARN_CLOSED))
2588	report_evil_fh(gv, io, PL_op->op_type);
2589	SETERRNO(EBADF,SS_IVCHAN);
2590	RETPUSHUNDEF;
2591	#else
2592	DIE(aTHX_ PL_no_sock_func, "shutdown");
2593	#endif
2594	}
2595
2596	PP(pp_gsockopt)
2597	{
2598	#ifdef HAS_SOCKET
2599	return pp_ssockopt();
2600	#else
2601	DIE(aTHX_ PL_no_sock_func, "getsockopt");
2602	#endif
2603	}
2604
2605	PP(pp_ssockopt)
2606	{
2607	#ifdef HAS_SOCKET
2608	dSP;
2609	int optype = PL_op->op_type;
2610	SV *sv;
2611	int fd;
2612	unsigned int optname;
2613	unsigned int lvl;
2614	GV *gv;
2615	register IO *io;
2616	Sock_size_t len;
2617
2618	if (optype == OP_GSOCKOPT)
2619	sv = sv_2mortal(NEWSV(22, 257));
2620	else
2621	sv = POPs;
2622	optname = (unsigned int) POPi;
2623	lvl = (unsigned int) POPi;
2624
2625	gv = (GV*)POPs;
2626	io = GvIOn(gv);
2627	if (!io \|\| !IoIFP(io))
2628	goto nuts;
2629
2630	fd = PerlIO_fileno(IoIFP(io));
2631	switch (optype) {
2632	case OP_GSOCKOPT:
2633	SvGROW(sv, 257);
2634	(void)SvPOK_only(sv);
2635	SvCUR_set(sv,256);
2636	*SvEND(sv) ='\0';
2637	len = SvCUR(sv);
2638	if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2639	goto nuts2;
2640	SvCUR_set(sv, len);
2641	*SvEND(sv) ='\0';
2642	PUSHs(sv);
2643	break;
2644	case OP_SSOCKOPT: {
2645	char *buf;
2646	int aint;
2647	if (SvPOKp(sv)) {
2648	STRLEN l;
2649	buf = SvPV(sv, l);
2650	len = l;
2651	}
2652	else {
2653	aint = (int)SvIV(sv);
2654	buf = (char*)&aint;
2655	len = sizeof(int);
2656	}
2657	if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2658	goto nuts2;
2659	PUSHs(&PL_sv_yes);
2660	}
2661	break;
2662	}
2663	RETURN;
2664
2665	nuts:
2666	if (ckWARN(WARN_CLOSED))
2667	report_evil_fh(gv, io, optype);
2668	SETERRNO(EBADF,SS_IVCHAN);
2669	nuts2:
2670	RETPUSHUNDEF;
2671
2672	#else
2673	DIE(aTHX_ PL_no_sock_func, "setsockopt");
2674	#endif
2675	}
2676
2677	PP(pp_getsockname)
2678	{
2679	#ifdef HAS_SOCKET
2680	return pp_getpeername();
2681	#else
2682	DIE(aTHX_ PL_no_sock_func, "getsockname");
2683	#endif
2684	}
2685
2686	PP(pp_getpeername)
2687	{
2688	#ifdef HAS_SOCKET
2689	dSP;
2690	int optype = PL_op->op_type;
2691	SV *sv;
2692	int fd;
2693	GV gv = (GV)POPs;
2694	register IO *io = GvIOn(gv);
2695	Sock_size_t len;
2696
2697	if (!io \|\| !IoIFP(io))
2698	goto nuts;
2699
2700	sv = sv_2mortal(NEWSV(22, 257));
2701	(void)SvPOK_only(sv);
2702	len = 256;
2703	SvCUR_set(sv, len);
2704	*SvEND(sv) ='\0';
2705	fd = PerlIO_fileno(IoIFP(io));
2706	switch (optype) {
2707	case OP_GETSOCKNAME:
2708	if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2709	goto nuts2;
2710	break;
2711	case OP_GETPEERNAME:
2712	if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2713	goto nuts2;
2714	#if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2715	{
2716	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";
2717	/* If the call succeeded, make sure we don't have a zeroed port/addr */
2718	if (((struct sockaddr *)SvPVX(sv))->sa_family == AF_INET &&
2719	!memcmp((char *)SvPVX(sv) + sizeof(u_short), nowhere,
2720	sizeof(u_short) + sizeof(struct in_addr))) {
2721	goto nuts2;
2722	}
2723	}
2724	#endif
2725	break;
2726	}
2727	#ifdef BOGUS_GETNAME_RETURN
2728	/* Interactive Unix, getpeername() and getsockname()
2729	does not return valid namelen */
2730	if (len == BOGUS_GETNAME_RETURN)
2731	len = sizeof(struct sockaddr);
2732	#endif
2733	SvCUR_set(sv, len);
2734	*SvEND(sv) ='\0';
2735	PUSHs(sv);
2736	RETURN;
2737
2738	nuts:
2739	if (ckWARN(WARN_CLOSED))
2740	report_evil_fh(gv, io, optype);
2741	SETERRNO(EBADF,SS_IVCHAN);
2742	nuts2:
2743	RETPUSHUNDEF;
2744
2745	#else
2746	DIE(aTHX_ PL_no_sock_func, "getpeername");
2747	#endif
2748	}
2749
2750	/* Stat calls. */
2751
2752	PP(pp_lstat)
2753	{
2754	return pp_stat();
2755	}
2756
2757	PP(pp_stat)
2758	{
2759	dSP;
2760	GV *gv;
2761	I32 gimme;
2762	I32 max = 13;
2763	STRLEN n_a;
2764
2765	if (PL_op->op_flags & OPf_REF) {
2766	gv = cGVOP_gv;
2767	if (PL_op->op_type == OP_LSTAT) {
2768	if (gv != PL_defgv) {
2769	if (ckWARN(WARN_IO))
2770	Perl_warner(aTHX_ packWARN(WARN_IO),
2771	"lstat() on filehandle %s", GvENAME(gv));
2772	} else if (PL_laststype != OP_LSTAT)
2773	Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2774	}
2775
2776	do_fstat:
2777	if (gv != PL_defgv) {
2778	PL_laststype = OP_STAT;
2779	PL_statgv = gv;
2780	sv_setpv(PL_statname, "");
2781	PL_laststatval = (GvIO(gv) && IoIFP(GvIOp(gv))
2782	? PerlLIO_fstat(PerlIO_fileno(IoIFP(GvIOn(gv))), &PL_statcache) : -1);
2783	}
2784	if (PL_laststatval < 0) {
2785	if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2786	report_evil_fh(gv, GvIO(gv), PL_op->op_type);
2787	max = 0;
2788	}
2789	}
2790	else {
2791	SV* sv = POPs;
2792	if (SvTYPE(sv) == SVt_PVGV) {
2793	gv = (GV*)sv;
2794	goto do_fstat;
2795	}
2796	else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2797	gv = (GV*)SvRV(sv);
2798	if (PL_op->op_type == OP_LSTAT && ckWARN(WARN_IO))
2799	Perl_warner(aTHX_ packWARN(WARN_IO),
2800	"lstat() on filehandle %s", GvENAME(gv));
2801	goto do_fstat;
2802	}
2803	sv_setpv(PL_statname, SvPV(sv,n_a));
2804	PL_statgv = Nullgv;
2805	#ifdef HAS_LSTAT
2806	PL_laststype = PL_op->op_type;
2807	if (PL_op->op_type == OP_LSTAT)
2808	PL_laststatval = PerlLIO_lstat(SvPV(PL_statname, n_a), &PL_statcache);
2809	else
2810	#endif
2811	PL_laststatval = PerlLIO_stat(SvPV(PL_statname, n_a), &PL_statcache);
2812	if (PL_laststatval < 0) {
2813	if (ckWARN(WARN_NEWLINE) && strchr(SvPV(PL_statname, n_a), '\n'))
2814	Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
2815	max = 0;
2816	}
2817	}
2818
2819	gimme = GIMME_V;
2820	if (gimme != G_ARRAY) {
2821	if (gimme != G_VOID)
2822	XPUSHs(boolSV(max));
2823	RETURN;
2824	}
2825	if (max) {
2826	EXTEND(SP, max);
2827	EXTEND_MORTAL(max);
2828	PUSHs(sv_2mortal(newSViv(PL_statcache.st_dev)));
2829	PUSHs(sv_2mortal(newSViv(PL_statcache.st_ino)));
2830	PUSHs(sv_2mortal(newSVuv(PL_statcache.st_mode)));
2831	PUSHs(sv_2mortal(newSVuv(PL_statcache.st_nlink)));
2832	#if Uid_t_size > IVSIZE
2833	PUSHs(sv_2mortal(newSVnv(PL_statcache.st_uid)));
2834	#else
2835	# if Uid_t_sign <= 0
2836	PUSHs(sv_2mortal(newSViv(PL_statcache.st_uid)));
2837	# else
2838	PUSHs(sv_2mortal(newSVuv(PL_statcache.st_uid)));
2839	# endif
2840	#endif
2841	#if Gid_t_size > IVSIZE
2842	PUSHs(sv_2mortal(newSVnv(PL_statcache.st_gid)));
2843	#else
2844	# if Gid_t_sign <= 0
2845	PUSHs(sv_2mortal(newSViv(PL_statcache.st_gid)));
2846	# else
2847	PUSHs(sv_2mortal(newSVuv(PL_statcache.st_gid)));
2848	# endif
2849	#endif
2850	#ifdef USE_STAT_RDEV
2851	PUSHs(sv_2mortal(newSViv(PL_statcache.st_rdev)));
2852	#else
2853	PUSHs(sv_2mortal(newSVpvn("", 0)));
2854	#endif
2855	#if Off_t_size > IVSIZE
2856	PUSHs(sv_2mortal(newSVnv((NV)PL_statcache.st_size)));
2857	#else
2858	PUSHs(sv_2mortal(newSViv(PL_statcache.st_size)));
2859	#endif
2860	#ifdef BIG_TIME
2861	PUSHs(sv_2mortal(newSVnv(PL_statcache.st_atime)));
2862	PUSHs(sv_2mortal(newSVnv(PL_statcache.st_mtime)));
2863	PUSHs(sv_2mortal(newSVnv(PL_statcache.st_ctime)));
2864	#else
2865	PUSHs(sv_2mortal(newSViv(PL_statcache.st_atime)));
2866	PUSHs(sv_2mortal(newSViv(PL_statcache.st_mtime)));
2867	PUSHs(sv_2mortal(newSViv(PL_statcache.st_ctime)));
2868	#endif
2869	#ifdef USE_STAT_BLOCKS
2870	PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blksize)));
2871	PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blocks)));
2872	#else
2873	PUSHs(sv_2mortal(newSVpvn("", 0)));
2874	PUSHs(sv_2mortal(newSVpvn("", 0)));
2875	#endif
2876	}
2877	RETURN;
2878	}
2879
2880	PP(pp_ftrread)
2881	{
2882	I32 result;
2883	dSP;
2884	#if defined(HAS_ACCESS) && defined(R_OK)
2885	STRLEN n_a;
2886	if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) {
2887	result = access(POPpx, R_OK);
2888	if (result == 0)
2889	RETPUSHYES;
2890	if (result < 0)
2891	RETPUSHUNDEF;
2892	RETPUSHNO;
2893	}
2894	else
2895	result = my_stat();
2896	#else
2897	result = my_stat();
2898	#endif
2899	SPAGAIN;
2900	if (result < 0)
2901	RETPUSHUNDEF;
2902	if (cando(S_IRUSR, 0, &PL_statcache))
2903	RETPUSHYES;
2904	RETPUSHNO;
2905	}
2906
2907	PP(pp_ftrwrite)
2908	{
2909	I32 result;
2910	dSP;
2911	#if defined(HAS_ACCESS) && defined(W_OK)
2912	STRLEN n_a;
2913	if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) {
2914	result = access(POPpx, W_OK);
2915	if (result == 0)
2916	RETPUSHYES;
2917	if (result < 0)
2918	RETPUSHUNDEF;
2919	RETPUSHNO;
2920	}
2921	else
2922	result = my_stat();
2923	#else
2924	result = my_stat();
2925	#endif
2926	SPAGAIN;
2927	if (result < 0)
2928	RETPUSHUNDEF;
2929	if (cando(S_IWUSR, 0, &PL_statcache))
2930	RETPUSHYES;
2931	RETPUSHNO;
2932	}
2933
2934	PP(pp_ftrexec)
2935	{
2936	I32 result;
2937	dSP;
2938	#if defined(HAS_ACCESS) && defined(X_OK)
2939	STRLEN n_a;
2940	if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) {
2941	result = access(POPpx, X_OK);
2942	if (result == 0)
2943	RETPUSHYES;
2944	if (result < 0)
2945	RETPUSHUNDEF;
2946	RETPUSHNO;
2947	}
2948	else
2949	result = my_stat();
2950	#else
2951	result = my_stat();
2952	#endif
2953	SPAGAIN;
2954	if (result < 0)
2955	RETPUSHUNDEF;
2956	if (cando(S_IXUSR, 0, &PL_statcache))
2957	RETPUSHYES;
2958	RETPUSHNO;
2959	}
2960
2961	PP(pp_fteread)
2962	{
2963	I32 result;
2964	dSP;
2965	#ifdef PERL_EFF_ACCESS_R_OK
2966	STRLEN n_a;
2967	if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) {
2968	result = PERL_EFF_ACCESS_R_OK(POPpx);
2969	if (result == 0)
2970	RETPUSHYES;
2971	if (result < 0)
2972	RETPUSHUNDEF;
2973	RETPUSHNO;
2974	}
2975	else
2976	result = my_stat();
2977	#else
2978	result = my_stat();
2979	#endif
2980	SPAGAIN;
2981	if (result < 0)
2982	RETPUSHUNDEF;
2983	if (cando(S_IRUSR, 1, &PL_statcache))
2984	RETPUSHYES;
2985	RETPUSHNO;
2986	}
2987
2988	PP(pp_ftewrite)
2989	{
2990	I32 result;
2991	dSP;
2992	#ifdef PERL_EFF_ACCESS_W_OK
2993	STRLEN n_a;
2994	if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) {
2995	result = PERL_EFF_ACCESS_W_OK(POPpx);
2996	if (result == 0)
2997	RETPUSHYES;
2998	if (result < 0)
2999	RETPUSHUNDEF;
3000	RETPUSHNO;
3001	}
3002	else
3003	result = my_stat();
3004	#else
3005	result = my_stat();
3006	#endif
3007	SPAGAIN;
3008	if (result < 0)
3009	RETPUSHUNDEF;
3010	if (cando(S_IWUSR, 1, &PL_statcache))
3011	RETPUSHYES;
3012	RETPUSHNO;
3013	}
3014
3015	PP(pp_fteexec)
3016	{
3017	I32 result;
3018	dSP;
3019	#ifdef PERL_EFF_ACCESS_X_OK
3020	STRLEN n_a;
3021	if ((PL_op->op_private & OPpFT_ACCESS) && SvPOK(TOPs)) {
3022	result = PERL_EFF_ACCESS_X_OK(POPpx);
3023	if (result == 0)
3024	RETPUSHYES;
3025	if (result < 0)
3026	RETPUSHUNDEF;
3027	RETPUSHNO;
3028	}
3029	else
3030	result = my_stat();
3031	#else
3032	result = my_stat();
3033	#endif
3034	SPAGAIN;
3035	if (result < 0)
3036	RETPUSHUNDEF;
3037	if (cando(S_IXUSR, 1, &PL_statcache))
3038	RETPUSHYES;
3039	RETPUSHNO;
3040	}
3041
3042	PP(pp_ftis)
3043	{
3044	I32 result = my_stat();
3045	dSP;
3046	if (result < 0)
3047	RETPUSHUNDEF;
3048	RETPUSHYES;
3049	}
3050
3051	PP(pp_fteowned)
3052	{
3053	return pp_ftrowned();
3054	}
3055
3056	PP(pp_ftrowned)
3057	{
3058	I32 result = my_stat();
3059	dSP;
3060	if (result < 0)
3061	RETPUSHUNDEF;
3062	if (PL_statcache.st_uid == (PL_op->op_type == OP_FTEOWNED ?
3063	PL_euid : PL_uid) )
3064	RETPUSHYES;
3065	RETPUSHNO;
3066	}
3067
3068	PP(pp_ftzero)
3069	{
3070	I32 result = my_stat();
3071	dSP;
3072	if (result < 0)
3073	RETPUSHUNDEF;
3074	if (PL_statcache.st_size == 0)
3075	RETPUSHYES;
3076	RETPUSHNO;
3077	}
3078
3079	PP(pp_ftsize)
3080	{
3081	I32 result = my_stat();
3082	dSP; dTARGET;
3083	if (result < 0)
3084	RETPUSHUNDEF;
3085	#if Off_t_size > IVSIZE
3086	PUSHn(PL_statcache.st_size);
3087	#else
3088	PUSHi(PL_statcache.st_size);
3089	#endif
3090	RETURN;
3091	}
3092
3093	PP(pp_ftmtime)
3094	{
3095	I32 result = my_stat();
3096	dSP; dTARGET;
3097	if (result < 0)
3098	RETPUSHUNDEF;
3099	PUSHn( (((NV)PL_basetime - PL_statcache.st_mtime)) / 86400.0 );
3100	RETURN;
3101	}
3102
3103	PP(pp_ftatime)
3104	{
3105	I32 result = my_stat();
3106	dSP; dTARGET;
3107	if (result < 0)
3108	RETPUSHUNDEF;
3109	PUSHn( (((NV)PL_basetime - PL_statcache.st_atime)) / 86400.0 );
3110	RETURN;
3111	}
3112
3113	PP(pp_ftctime)
3114	{
3115	I32 result = my_stat();
3116	dSP; dTARGET;
3117	if (result < 0)
3118	RETPUSHUNDEF;
3119	PUSHn( (((NV)PL_basetime - PL_statcache.st_ctime)) / 86400.0 );
3120	RETURN;
3121	}
3122
3123	PP(pp_ftsock)
3124	{
3125	I32 result = my_stat();
3126	dSP;
3127	if (result < 0)
3128	RETPUSHUNDEF;
3129	if (S_ISSOCK(PL_statcache.st_mode))
3130	RETPUSHYES;
3131	RETPUSHNO;
3132	}
3133
3134	PP(pp_ftchr)
3135	{
3136	I32 result = my_stat();
3137	dSP;
3138	if (result < 0)
3139	RETPUSHUNDEF;
3140	if (S_ISCHR(PL_statcache.st_mode))
3141	RETPUSHYES;
3142	RETPUSHNO;
3143	}
3144
3145	PP(pp_ftblk)
3146	{
3147	I32 result = my_stat();
3148	dSP;
3149	if (result < 0)
3150	RETPUSHUNDEF;
3151	if (S_ISBLK(PL_statcache.st_mode))
3152	RETPUSHYES;
3153	RETPUSHNO;
3154	}
3155
3156	PP(pp_ftfile)
3157	{
3158	I32 result = my_stat();
3159	dSP;
3160	if (result < 0)
3161	RETPUSHUNDEF;
3162	if (S_ISREG(PL_statcache.st_mode))
3163	RETPUSHYES;
3164	RETPUSHNO;
3165	}
3166
3167	PP(pp_ftdir)
3168	{
3169	I32 result = my_stat();
3170	dSP;
3171	if (result < 0)
3172	RETPUSHUNDEF;
3173	if (S_ISDIR(PL_statcache.st_mode))
3174	RETPUSHYES;
3175	RETPUSHNO;
3176	}
3177
3178	PP(pp_ftpipe)
3179	{
3180	I32 result = my_stat();
3181	dSP;
3182	if (result < 0)
3183	RETPUSHUNDEF;
3184	if (S_ISFIFO(PL_statcache.st_mode))
3185	RETPUSHYES;
3186	RETPUSHNO;
3187	}
3188
3189	PP(pp_ftlink)
3190	{
3191	I32 result = my_lstat();
3192	dSP;
3193	if (result < 0)
3194	RETPUSHUNDEF;
3195	if (S_ISLNK(PL_statcache.st_mode))
3196	RETPUSHYES;
3197	RETPUSHNO;
3198	}
3199
3200	PP(pp_ftsuid)
3201	{
3202	dSP;
3203	#ifdef S_ISUID
3204	I32 result = my_stat();
3205	SPAGAIN;
3206	if (result < 0)
3207	RETPUSHUNDEF;
3208	if (PL_statcache.st_mode & S_ISUID)
3209	RETPUSHYES;
3210	#endif
3211	RETPUSHNO;
3212	}
3213
3214	PP(pp_ftsgid)
3215	{
3216	dSP;
3217	#ifdef S_ISGID
3218	I32 result = my_stat();
3219	SPAGAIN;
3220	if (result < 0)
3221	RETPUSHUNDEF;
3222	if (PL_statcache.st_mode & S_ISGID)
3223	RETPUSHYES;
3224	#endif
3225	RETPUSHNO;
3226	}
3227
3228	PP(pp_ftsvtx)
3229	{
3230	dSP;
3231	#ifdef S_ISVTX
3232	I32 result = my_stat();
3233	SPAGAIN;
3234	if (result < 0)
3235	RETPUSHUNDEF;
3236	if (PL_statcache.st_mode & S_ISVTX)
3237	RETPUSHYES;
3238	#endif
3239	RETPUSHNO;
3240	}
3241
3242	PP(pp_fttty)
3243	{
3244	dSP;
3245	int fd;
3246	GV *gv;
3247	char *tmps = Nullch;
3248	STRLEN n_a;
3249
3250	if (PL_op->op_flags & OPf_REF)
3251	gv = cGVOP_gv;
3252	else if (isGV(TOPs))
3253	gv = (GV*)POPs;
3254	else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3255	gv = (GV*)SvRV(POPs);
3256	else
3257	gv = gv_fetchpv(tmps = POPpx, FALSE, SVt_PVIO);
3258
3259	if (GvIO(gv) && IoIFP(GvIOp(gv)))
3260	fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3261	else if (tmps && isDIGIT(*tmps))
3262	fd = atoi(tmps);
3263	else
3264	RETPUSHUNDEF;
3265	if (PerlLIO_isatty(fd))
3266	RETPUSHYES;
3267	RETPUSHNO;
3268	}
3269
3270	#if defined(atarist) /* this will work with atariST. Configure will
3271	make guesses for other systems. */
3272	# define FILE_base(f) ((f)->_base)
3273	# define FILE_ptr(f) ((f)->_ptr)
3274	# define FILE_cnt(f) ((f)->_cnt)
3275	# define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
3276	#endif
3277
3278	PP(pp_fttext)
3279	{
3280	dSP;
3281	I32 i;
3282	I32 len;
3283	I32 odd = 0;
3284	STDCHAR tbuf[512];
3285	register STDCHAR *s;
3286	register IO *io;
3287	register SV *sv;
3288	GV *gv;
3289	STRLEN n_a;
3290	PerlIO *fp;
3291
3292	if (PL_op->op_flags & OPf_REF)
3293	gv = cGVOP_gv;
3294	else if (isGV(TOPs))
3295	gv = (GV*)POPs;
3296	else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3297	gv = (GV*)SvRV(POPs);
3298	else
3299	gv = Nullgv;
3300
3301	if (gv) {
3302	EXTEND(SP, 1);
3303	if (gv == PL_defgv) {
3304	if (PL_statgv)
3305	io = GvIO(PL_statgv);
3306	else {
3307	sv = PL_statname;
3308	goto really_filename;
3309	}
3310	}
3311	else {
3312	PL_statgv = gv;
3313	PL_laststatval = -1;
3314	sv_setpv(PL_statname, "");
3315	io = GvIO(PL_statgv);
3316	}
3317	if (io && IoIFP(io)) {
3318	if (! PerlIO_has_base(IoIFP(io)))
3319	DIE(aTHX_ "-T and -B not implemented on filehandles");
3320	PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3321	if (PL_laststatval < 0)
3322	RETPUSHUNDEF;
3323	if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3324	if (PL_op->op_type == OP_FTTEXT)
3325	RETPUSHNO;
3326	else
3327	RETPUSHYES;
3328	}
3329	if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3330	i = PerlIO_getc(IoIFP(io));
3331	if (i != EOF)
3332	(void)PerlIO_ungetc(IoIFP(io),i);
3333	}
3334	if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
3335	RETPUSHYES;
3336	len = PerlIO_get_bufsiz(IoIFP(io));
3337	s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3338	/* sfio can have large buffers - limit to 512 */
3339	if (len > 512)
3340	len = 512;
3341	}
3342	else {
3343	if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
3344	gv = cGVOP_gv;
3345	report_evil_fh(gv, GvIO(gv), PL_op->op_type);
3346	}
3347	SETERRNO(EBADF,RMS_IFI);
3348	RETPUSHUNDEF;
3349	}
3350	}
3351	else {
3352	sv = POPs;
3353	really_filename:
3354	PL_statgv = Nullgv;
3355	PL_laststatval = -1;
3356	PL_laststype = OP_STAT;
3357	sv_setpv(PL_statname, SvPV(sv, n_a));
3358	if (!(fp = PerlIO_open(SvPVX(PL_statname), "r"))) {
3359	if (ckWARN(WARN_NEWLINE) && strchr(SvPV(PL_statname, n_a), '\n'))
3360	Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3361	RETPUSHUNDEF;
3362	}
3363	PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3364	if (PL_laststatval < 0) {
3365	(void)PerlIO_close(fp);
3366	RETPUSHUNDEF;
3367	}
3368	PerlIO_binmode(aTHX_ fp, '<', O_BINARY, Nullch);
3369	len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3370	(void)PerlIO_close(fp);
3371	if (len <= 0) {
3372	if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3373	RETPUSHNO; /* special case NFS directories */
3374	RETPUSHYES; /* null file is anything */
3375	}
3376	s = tbuf;
3377	}
3378
3379	/* now scan s to look for textiness */
3380	/* XXX ASCII dependent code */
3381
3382	#if defined(DOSISH) \|\| defined(USEMYBINMODE)
3383	/* ignore trailing ^Z on short files */
3384	if (len && len < sizeof(tbuf) && tbuf[len-1] == 26)
3385	--len;
3386	#endif
3387
3388	for (i = 0; i < len; i++, s++) {
3389	if (!s) { / null never allowed in text */
3390	odd += len;
3391	break;
3392	}
3393	#ifdef EBCDIC
3394	else if (!(isPRINT(s) \|\| isSPACE(s)))
3395	odd++;
3396	#else
3397	else if (*s & 128) {
3398	#ifdef USE_LOCALE
3399	if (IN_LOCALE_RUNTIME && isALPHA_LC(*s))
3400	continue;
3401	#endif
3402	/* utf8 characters don't count as odd */
3403	if (UTF8_IS_START(*s)) {
3404	int ulen = UTF8SKIP(s);
3405	if (ulen < len - i) {
3406	int j;
3407	for (j = 1; j < ulen; j++) {
3408	if (!UTF8_IS_CONTINUATION(s[j]))
3409	goto not_utf8;
3410	}
3411	--ulen; /* loop does extra increment */
3412	s += ulen;
3413	i += ulen;
3414	continue;
3415	}
3416	}
3417	not_utf8:
3418	odd++;
3419	}
3420	else if (*s < 32 &&
3421	s != '\n' && s != '\r' && *s != '\b' &&
3422	s != '\t' && s != '\f' && *s != 27)
3423	odd++;
3424	#endif
3425	}
3426
3427	if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3428	RETPUSHNO;
3429	else
3430	RETPUSHYES;
3431	}
3432
3433	PP(pp_ftbinary)
3434	{
3435	return pp_fttext();
3436	}
3437
3438	/* File calls. */
3439
3440	PP(pp_chdir)
3441	{
3442	dSP; dTARGET;
3443	char *tmps;
3444	SV **svp;
3445	STRLEN n_a;
3446
3447	if( MAXARG == 1 )
3448	tmps = POPpx;
3449	else
3450	tmps = 0;
3451
3452	if( !tmps \|\| !*tmps ) {
3453	if ( (svp = hv_fetch(GvHVn(PL_envgv), "HOME", 4, FALSE))
3454	\|\| (svp = hv_fetch(GvHVn(PL_envgv), "LOGDIR", 6, FALSE))
3455	#ifdef VMS
3456	\|\| (svp = hv_fetch(GvHVn(PL_envgv), "SYS$LOGIN", 9, FALSE))
3457	#endif
3458	)
3459	{
3460	if( MAXARG == 1 )
3461	deprecate("chdir('') or chdir(undef) as chdir()");
3462	tmps = SvPV(*svp, n_a);
3463	}
3464	else {
3465	PUSHi(0);
3466	TAINT_PROPER("chdir");
3467	RETURN;
3468	}
3469	}
3470
3471	TAINT_PROPER("chdir");
3472	PUSHi( PerlDir_chdir(tmps) >= 0 );
3473	#ifdef VMS
3474	/* Clear the DEFAULT element of ENV so we'll get the new value
3475	* in the future. */
3476	hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3477	#endif
3478	RETURN;
3479	}
3480
3481	PP(pp_chown)
3482	{
3483	#ifdef HAS_CHOWN
3484	dSP; dMARK; dTARGET;
3485	I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3486
3487	SP = MARK;
3488	PUSHi(value);
3489	RETURN;
3490	#else
3491	DIE(aTHX_ PL_no_func, "chown");
3492	#endif
3493	}
3494
3495	PP(pp_chroot)
3496	{
3497	#ifdef HAS_CHROOT
3498	dSP; dTARGET;
3499	STRLEN n_a;
3500	char *tmps = POPpx;
3501	TAINT_PROPER("chroot");
3502	PUSHi( chroot(tmps) >= 0 );
3503	RETURN;
3504	#else
3505	DIE(aTHX_ PL_no_func, "chroot");
3506	#endif
3507	}
3508
3509	PP(pp_unlink)
3510	{
3511	dSP; dMARK; dTARGET;
3512	I32 value;
3513	value = (I32)apply(PL_op->op_type, MARK, SP);
3514	SP = MARK;
3515	PUSHi(value);
3516	RETURN;
3517	}
3518
3519	PP(pp_chmod)
3520	{
3521	dSP; dMARK; dTARGET;
3522	I32 value;
3523	value = (I32)apply(PL_op->op_type, MARK, SP);
3524	SP = MARK;
3525	PUSHi(value);
3526	RETURN;
3527	}
3528
3529	PP(pp_utime)
3530	{
3531	dSP; dMARK; dTARGET;
3532	I32 value;
3533	value = (I32)apply(PL_op->op_type, MARK, SP);
3534	SP = MARK;
3535	PUSHi(value);
3536	RETURN;
3537	}
3538
3539	PP(pp_rename)
3540	{
3541	dSP; dTARGET;
3542	int anum;
3543	STRLEN n_a;
3544
3545	char *tmps2 = POPpx;
3546	char *tmps = SvPV(TOPs, n_a);
3547	TAINT_PROPER("rename");
3548	#ifdef HAS_RENAME
3549	anum = PerlLIO_rename(tmps, tmps2);
3550	#else
3551	if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3552	if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3553	anum = 1;
3554	else {
3555	if (PL_euid \|\| PerlLIO_stat(tmps2, &PL_statbuf) < 0 \|\| !S_ISDIR(PL_statbuf.st_mode))
3556	(void)UNLINK(tmps2);
3557	if (!(anum = link(tmps, tmps2)))
3558	anum = UNLINK(tmps);
3559	}
3560	}
3561	#endif
3562	SETi( anum >= 0 );
3563	RETURN;
3564	}
3565
3566	PP(pp_link)
3567	{
3568	#ifdef HAS_LINK
3569	dSP; dTARGET;
3570	STRLEN n_a;
3571	char *tmps2 = POPpx;
3572	char *tmps = SvPV(TOPs, n_a);
3573	TAINT_PROPER("link");
3574	SETi( PerlLIO_link(tmps, tmps2) >= 0 );
3575	RETURN;
3576	#else
3577	DIE(aTHX_ PL_no_func, "link");
3578	#endif
3579	}
3580
3581	PP(pp_symlink)
3582	{
3583	#ifdef HAS_SYMLINK
3584	dSP; dTARGET;
3585	STRLEN n_a;
3586	char *tmps2 = POPpx;
3587	char *tmps = SvPV(TOPs, n_a);
3588	TAINT_PROPER("symlink");
3589	SETi( symlink(tmps, tmps2) >= 0 );
3590	RETURN;
3591	#else
3592	DIE(aTHX_ PL_no_func, "symlink");
3593	#endif
3594	}
3595
3596	PP(pp_readlink)
3597	{
3598	dSP;
3599	#ifdef HAS_SYMLINK
3600	dTARGET;
3601	char *tmps;
3602	char buf[MAXPATHLEN];
3603	int len;
3604	STRLEN n_a;
3605
3606	#ifndef INCOMPLETE_TAINTS
3607	TAINT;
3608	#endif
3609	tmps = POPpx;
3610	len = readlink(tmps, buf, sizeof(buf) - 1);
3611	EXTEND(SP, 1);
3612	if (len < 0)
3613	RETPUSHUNDEF;
3614	PUSHp(buf, len);
3615	RETURN;
3616	#else
3617	EXTEND(SP, 1);
3618	RETSETUNDEF; /* just pretend it's a normal file */
3619	#endif
3620	}
3621
3622	#if !defined(HAS_MKDIR) \|\| !defined(HAS_RMDIR)
3623	STATIC int
3624	S_dooneliner(pTHX_ char cmd, char filename)
3625	{
3626	char *save_filename = filename;
3627	char *cmdline;
3628	char *s;
3629	PerlIO *myfp;
3630	int anum = 1;
3631
3632	New(666, cmdline, strlen(cmd) + (strlen(filename) * 2) + 10, char);
3633	strcpy(cmdline, cmd);
3634	strcat(cmdline, " ");
3635	for (s = cmdline + strlen(cmdline); *filename; ) {
3636	*s++ = '\\';
3637	s++ = filename++;
3638	}
3639	strcpy(s, " 2>&1");
3640	myfp = PerlProc_popen(cmdline, "r");
3641	Safefree(cmdline);
3642
3643	if (myfp) {
3644	SV *tmpsv = sv_newmortal();
3645	/* Need to save/restore 'PL_rs' ?? */
3646	s = sv_gets(tmpsv, myfp, 0);
3647	(void)PerlProc_pclose(myfp);
3648	if (s != Nullch) {
3649	int e;
3650	for (e = 1;
3651	#ifdef HAS_SYS_ERRLIST
3652	e <= sys_nerr
3653	#endif
3654	; e++)
3655	{
3656	/* you don't see this */
3657	char *errmsg =
3658	#ifdef HAS_SYS_ERRLIST
3659	sys_errlist[e]
3660	#else
3661	strerror(e)
3662	#endif
3663	;
3664	if (!errmsg)
3665	break;
3666	if (instr(s, errmsg)) {
3667	SETERRNO(e,0);
3668	return 0;
3669	}
3670	}
3671	SETERRNO(0,0);
3672	#ifndef EACCES
3673	#define EACCES EPERM
3674	#endif
3675	if (instr(s, "cannot make"))
3676	SETERRNO(EEXIST,RMS_FEX);
3677	else if (instr(s, "existing file"))
3678	SETERRNO(EEXIST,RMS_FEX);
3679	else if (instr(s, "ile exists"))
3680	SETERRNO(EEXIST,RMS_FEX);
3681	else if (instr(s, "non-exist"))
3682	SETERRNO(ENOENT,RMS_FNF);
3683	else if (instr(s, "does not exist"))
3684	SETERRNO(ENOENT,RMS_FNF);
3685	else if (instr(s, "not empty"))
3686	SETERRNO(EBUSY,SS_DEVOFFLINE);
3687	else if (instr(s, "cannot access"))
3688	SETERRNO(EACCES,RMS_PRV);
3689	else
3690	SETERRNO(EPERM,RMS_PRV);
3691	return 0;
3692	}
3693	else { /* some mkdirs return no failure indication */
3694	anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3695	if (PL_op->op_type == OP_RMDIR)
3696	anum = !anum;
3697	if (anum)
3698	SETERRNO(0,0);
3699	else
3700	SETERRNO(EACCES,RMS_PRV); /* a guess */
3701	}
3702	return anum;
3703	}
3704	else
3705	return 0;
3706	}
3707	#endif
3708
3709	/* This macro removes trailing slashes from a directory name.
3710	* Different operating and file systems take differently to
3711	* trailing slashes. According to POSIX 1003.1 1996 Edition
3712	* any number of trailing slashes should be allowed.
3713	* Thusly we snip them away so that even non-conforming
3714	* systems are happy.
3715	* We should probably do this "filtering" for all
3716	* the functions that expect (potentially) directory names:
3717	* -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3718	* (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3719
3720	#define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV(TOPs, (len)); \
3721	if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3722	do { \
3723	(len)--; \
3724	} while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3725	(tmps) = savepvn((tmps), (len)); \
3726	(copy) = TRUE; \
3727	}
3728
3729	PP(pp_mkdir)
3730	{
3731	dSP; dTARGET;
3732	int mode;
3733	#ifndef HAS_MKDIR
3734	int oldumask;
3735	#endif
3736	STRLEN len;
3737	char *tmps;
3738	bool copy = FALSE;
3739
3740	if (MAXARG > 1)
3741	mode = POPi;
3742	else
3743	mode = 0777;
3744
3745	TRIMSLASHES(tmps,len,copy);
3746
3747	TAINT_PROPER("mkdir");
3748	#ifdef HAS_MKDIR
3749	SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3750	#else
3751	SETi( dooneliner("mkdir", tmps) );
3752	oldumask = PerlLIO_umask(0);
3753	PerlLIO_umask(oldumask);
3754	PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3755	#endif
3756	if (copy)
3757	Safefree(tmps);
3758	RETURN;
3759	}
3760
3761	PP(pp_rmdir)
3762	{
3763	dSP; dTARGET;
3764	STRLEN len;
3765	char *tmps;
3766	bool copy = FALSE;
3767
3768	TRIMSLASHES(tmps,len,copy);
3769	TAINT_PROPER("rmdir");
3770	#ifdef HAS_RMDIR
3771	SETi( PerlDir_rmdir(tmps) >= 0 );
3772	#else
3773	SETi( dooneliner("rmdir", tmps) );
3774	#endif
3775	if (copy)
3776	Safefree(tmps);
3777	RETURN;
3778	}
3779
3780	/* Directory calls. */
3781
3782	PP(pp_open_dir)
3783	{
3784	#if defined(Direntry_t) && defined(HAS_READDIR)
3785	dSP;
3786	STRLEN n_a;
3787	char *dirname = POPpx;
3788	GV gv = (GV)POPs;
3789	register IO *io = GvIOn(gv);
3790
3791	if (!io)
3792	goto nope;
3793
3794	if (IoDIRP(io))
3795	PerlDir_close(IoDIRP(io));
3796	if (!(IoDIRP(io) = PerlDir_open(dirname)))
3797	goto nope;
3798
3799	RETPUSHYES;
3800	nope:
3801	if (!errno)
3802	SETERRNO(EBADF,RMS_DIR);
3803	RETPUSHUNDEF;
3804	#else
3805	DIE(aTHX_ PL_no_dir_func, "opendir");
3806	#endif
3807	}
3808
3809	PP(pp_readdir)
3810	{
3811	#if !defined(Direntry_t) \|\| !defined(HAS_READDIR)
3812	DIE(aTHX_ PL_no_dir_func, "readdir");
3813	#else
3814	#if !defined(I_DIRENT) && !defined(VMS)
3815	Direntry_t readdir (DIR );
3816	#endif
3817	dSP;
3818
3819	SV *sv;
3820	I32 gimme = GIMME;
3821	GV gv = (GV )POPs;
3822	register Direntry_t *dp;
3823	register IO *io = GvIOn(gv);
3824
3825	if (!io \|\| !IoDIRP(io))
3826	goto nope;
3827
3828	do {
3829	dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
3830	if (!dp)
3831	break;
3832	#ifdef DIRNAMLEN
3833	sv = newSVpvn(dp->d_name, dp->d_namlen);
3834	#else
3835	sv = newSVpv(dp->d_name, 0);
3836	#endif
3837	#ifndef INCOMPLETE_TAINTS
3838	if (!(IoFLAGS(io) & IOf_UNTAINT))
3839	SvTAINTED_on(sv);
3840	#endif
3841	XPUSHs(sv_2mortal(sv));
3842	sv = get_sv("_INO", TRUE);
3843	#ifdef BSD
3844	sv_setiv(sv, dp->d_fileno);
3845	#else
3846	sv_setiv(sv, dp->d_ino);
3847	#endif
3848	}
3849	while (gimme == G_ARRAY);
3850
3851	if (!dp && gimme != G_ARRAY)
3852	goto nope;
3853
3854	RETURN;
3855
3856	nope:
3857	if (!errno)
3858	SETERRNO(EBADF,RMS_ISI);
3859	if (GIMME == G_ARRAY)
3860	RETURN;
3861	else
3862	RETPUSHUNDEF;
3863	#endif
3864	}
3865
3866	PP(pp_telldir)
3867	{
3868	#if defined(HAS_TELLDIR) \|\| defined(telldir)
3869	dSP; dTARGET;
3870	/* XXX does _anyone_ need this? --AD 2/20/1998 */
3871	/* XXX netbsd still seemed to.
3872	XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3873	--JHI 1999-Feb-02 */
3874	# if !defined(HAS_TELLDIR_PROTO) \|\| defined(NEED_TELLDIR_PROTO)
3875	long telldir (DIR *);
3876	# endif
3877	GV gv = (GV)POPs;
3878	register IO *io = GvIOn(gv);
3879
3880	if (!io \|\| !IoDIRP(io))
3881	goto nope;
3882
3883	PUSHi( PerlDir_tell(IoDIRP(io)) );
3884	RETURN;
3885	nope:
3886	if (!errno)
3887	SETERRNO(EBADF,RMS_ISI);
3888	RETPUSHUNDEF;
3889	#else
3890	DIE(aTHX_ PL_no_dir_func, "telldir");
3891	#endif
3892	}
3893
3894	PP(pp_seekdir)
3895	{
3896	#if defined(HAS_SEEKDIR) \|\| defined(seekdir)
3897	dSP;
3898	long along = POPl;
3899	GV gv = (GV)POPs;
3900	register IO *io = GvIOn(gv);
3901
3902	if (!io \|\| !IoDIRP(io))
3903	goto nope;
3904
3905	(void)PerlDir_seek(IoDIRP(io), along);
3906
3907	RETPUSHYES;
3908	nope:
3909	if (!errno)
3910	SETERRNO(EBADF,RMS_ISI);
3911	RETPUSHUNDEF;
3912	#else
3913	DIE(aTHX_ PL_no_dir_func, "seekdir");
3914	#endif
3915	}
3916
3917	PP(pp_rewinddir)
3918	{
3919	#if defined(HAS_REWINDDIR) \|\| defined(rewinddir)
3920	dSP;
3921	GV gv = (GV)POPs;
3922	register IO *io = GvIOn(gv);
3923
3924	if (!io \|\| !IoDIRP(io))
3925	goto nope;
3926
3927	(void)PerlDir_rewind(IoDIRP(io));
3928	RETPUSHYES;
3929	nope:
3930	if (!errno)
3931	SETERRNO(EBADF,RMS_ISI);
3932	RETPUSHUNDEF;
3933	#else
3934	DIE(aTHX_ PL_no_dir_func, "rewinddir");
3935	#endif
3936	}
3937
3938	PP(pp_closedir)
3939	{
3940	#if defined(Direntry_t) && defined(HAS_READDIR)
3941	dSP;
3942	GV gv = (GV)POPs;
3943	register IO *io = GvIOn(gv);
3944
3945	if (!io \|\| !IoDIRP(io))
3946	goto nope;
3947
3948	#ifdef VOID_CLOSEDIR
3949	PerlDir_close(IoDIRP(io));
3950	#else
3951	if (PerlDir_close(IoDIRP(io)) < 0) {
3952	IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
3953	goto nope;
3954	}
3955	#endif
3956	IoDIRP(io) = 0;
3957
3958	RETPUSHYES;
3959	nope:
3960	if (!errno)
3961	SETERRNO(EBADF,RMS_IFI);
3962	RETPUSHUNDEF;
3963	#else
3964	DIE(aTHX_ PL_no_dir_func, "closedir");
3965	#endif
3966	}
3967
3968	/* Process control. */
3969
3970	PP(pp_fork)
3971	{
3972	#ifdef HAS_FORK
3973	dSP; dTARGET;
3974	Pid_t childpid;
3975	GV *tmpgv;
3976
3977	EXTEND(SP, 1);
3978	PERL_FLUSHALL_FOR_CHILD;
3979	childpid = PerlProc_fork();
3980	if (childpid < 0)
3981	RETSETUNDEF;
3982	if (!childpid) {
3983	/SUPPRESS 560/
3984	if ((tmpgv = gv_fetchpv("$", TRUE, SVt_PV))) {
3985	SvREADONLY_off(GvSV(tmpgv));
3986	sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3987	SvREADONLY_on(GvSV(tmpgv));
3988	}
3989	#ifdef THREADS_HAVE_PIDS
3990	PL_ppid = (IV)getppid();
3991	#endif
3992	hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
3993	}
3994	PUSHi(childpid);
3995	RETURN;
3996	#else
3997	# if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3998	dSP; dTARGET;
3999	Pid_t childpid;
4000
4001	EXTEND(SP, 1);
4002	PERL_FLUSHALL_FOR_CHILD;
4003	childpid = PerlProc_fork();
4004	if (childpid == -1)
4005	RETSETUNDEF;
4006	PUSHi(childpid);
4007	RETURN;
4008	# else
4009	DIE(aTHX_ PL_no_func, "fork");
4010	# endif
4011	#endif
4012	}
4013
4014	PP(pp_wait)
4015	{
4016	#if (!defined(DOSISH) \|\| defined(OS2) \|\| defined(WIN32)) && !defined(MACOS_TRADITIONAL)
4017	dSP; dTARGET;
4018	Pid_t childpid;
4019	int argflags;
4020
4021	if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4022	childpid = wait4pid(-1, &argflags, 0);
4023	else {
4024	while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4025	errno == EINTR) {
4026	PERL_ASYNC_CHECK();
4027	}
4028	}
4029	# if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4030	/* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4031	STATUS_NATIVE_SET((childpid && childpid != -1) ? argflags : -1);
4032	# else
4033	STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
4034	# endif
4035	XPUSHi(childpid);
4036	RETURN;
4037	#else
4038	DIE(aTHX_ PL_no_func, "wait");
4039	#endif
4040	}
4041
4042	PP(pp_waitpid)
4043	{
4044	#if (!defined(DOSISH) \|\| defined(OS2) \|\| defined(WIN32)) && !defined(MACOS_TRADITIONAL)
4045	dSP; dTARGET;
4046	Pid_t pid;
4047	Pid_t result;
4048	int optype;
4049	int argflags;
4050
4051	optype = POPi;
4052	pid = TOPi;
4053	if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4054	result = wait4pid(pid, &argflags, optype);
4055	else {
4056	while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4057	errno == EINTR) {
4058	PERL_ASYNC_CHECK();
4059	}
4060	}
4061	# if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4062	/* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4063	STATUS_NATIVE_SET((result && result != -1) ? argflags : -1);
4064	# else
4065	STATUS_NATIVE_SET((result > 0) ? argflags : -1);
4066	# endif
4067	SETi(result);
4068	RETURN;
4069	#else
4070	DIE(aTHX_ PL_no_func, "waitpid");
4071	#endif
4072	}
4073
4074	PP(pp_system)
4075	{
4076	dSP; dMARK; dORIGMARK; dTARGET;
4077	I32 value;
4078	STRLEN n_a;
4079	int result;
4080	I32 did_pipes = 0;
4081
4082	if (PL_tainting) {
4083	TAINT_ENV();
4084	while (++MARK <= SP) {
4085	(void)SvPV_nolen(MARK); / stringify for taint check */
4086	if (PL_tainted)
4087	break;
4088	}
4089	MARK = ORIGMARK;
4090	TAINT_PROPER("system");
4091	}
4092	PERL_FLUSHALL_FOR_CHILD;
4093	#if (defined(HAS_FORK) \|\| defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) \|\| defined(PERL_MICRO)
4094	{
4095	Pid_t childpid;
4096	int pp[2];
4097
4098	if (PerlProc_pipe(pp) >= 0)
4099	did_pipes = 1;
4100	while ((childpid = PerlProc_fork()) == -1) {
4101	if (errno != EAGAIN) {
4102	value = -1;
4103	SP = ORIGMARK;
4104	PUSHi(value);
4105	if (did_pipes) {
4106	PerlLIO_close(pp[0]);
4107	PerlLIO_close(pp[1]);
4108	}
4109	RETURN;
4110	}
4111	sleep(5);
4112	}
4113	if (childpid > 0) {
4114	Sigsave_t ihand,qhand; /* place to save signals during system() */
4115	int status;
4116
4117	if (did_pipes)
4118	PerlLIO_close(pp[1]);
4119	#ifndef PERL_MICRO
4120	rsignal_save(SIGINT, SIG_IGN, &ihand);
4121	rsignal_save(SIGQUIT, SIG_IGN, &qhand);
4122	#endif
4123	do {
4124	result = wait4pid(childpid, &status, 0);
4125	} while (result == -1 && errno == EINTR);
4126	#ifndef PERL_MICRO
4127	(void)rsignal_restore(SIGINT, &ihand);
4128	(void)rsignal_restore(SIGQUIT, &qhand);
4129	#endif
4130	STATUS_NATIVE_SET(result == -1 ? -1 : status);
4131	do_execfree(); /* free any memory child malloced on fork */
4132	SP = ORIGMARK;
4133	if (did_pipes) {
4134	int errkid;
4135	int n = 0, n1;
4136
4137	while (n < sizeof(int)) {
4138	n1 = PerlLIO_read(pp[0],
4139	(void)(((char)&errkid)+n),
4140	(sizeof(int)) - n);
4141	if (n1 <= 0)
4142	break;
4143	n += n1;
4144	}
4145	PerlLIO_close(pp[0]);
4146	if (n) { /* Error */
4147	if (n != sizeof(int))
4148	DIE(aTHX_ "panic: kid popen errno read");
4149	errno = errkid; /* Propagate errno from kid */
4150	STATUS_CURRENT = -1;
4151	}
4152	}
4153	PUSHi(STATUS_CURRENT);
4154	RETURN;
4155	}
4156	if (did_pipes) {
4157	PerlLIO_close(pp[0]);
4158	#if defined(HAS_FCNTL) && defined(F_SETFD)
4159	fcntl(pp[1], F_SETFD, FD_CLOEXEC);
4160	#endif
4161	}
4162	if (PL_op->op_flags & OPf_STACKED) {
4163	SV really = ++MARK;
4164	value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4165	}
4166	else if (SP - MARK != 1)
4167	value = (I32)do_aexec5(Nullsv, MARK, SP, pp[1], did_pipes);
4168	else {
4169	value = (I32)do_exec3(SvPVx(sv_mortalcopy(*SP), n_a), pp[1], did_pipes);
4170	}
4171	PerlProc__exit(-1);
4172	}
4173	#else /* ! FORK or VMS or OS/2 */
4174	PL_statusvalue = 0;
4175	result = 0;
4176	if (PL_op->op_flags & OPf_STACKED) {
4177	SV really = ++MARK;
4178	# if defined(WIN32) \|\| defined(OS2)
4179	value = (I32)do_aspawn(really, MARK, SP);
4180	# else
4181	value = (I32)do_aspawn(really, (void )MARK, (void )SP);
4182	# endif
4183	}
4184	else if (SP - MARK != 1) {
4185	# if defined(WIN32) \|\| defined(OS2)
4186	value = (I32)do_aspawn(Nullsv, MARK, SP);
4187	# else
4188	value = (I32)do_aspawn(Nullsv, (void )MARK, (void )SP);
4189	# endif
4190	}
4191	else {
4192	value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
4193	}
4194	if (PL_statusvalue == -1) /* hint that value must be returned as is */
4195	result = 1;
4196	STATUS_NATIVE_SET(value);
4197	do_execfree();
4198	SP = ORIGMARK;
4199	PUSHi(result ? value : STATUS_CURRENT);
4200	#endif /* !FORK or VMS */
4201	RETURN;
4202	}
4203
4204	PP(pp_exec)
4205	{
4206	dSP; dMARK; dORIGMARK; dTARGET;
4207	I32 value;
4208	STRLEN n_a;
4209
4210	if (PL_tainting) {
4211	TAINT_ENV();
4212	while (++MARK <= SP) {
4213	(void)SvPV_nolen(MARK); / stringify for taint check */
4214	if (PL_tainted)
4215	break;
4216	}
4217	MARK = ORIGMARK;
4218	TAINT_PROPER("exec");
4219	}
4220	PERL_FLUSHALL_FOR_CHILD;
4221	if (PL_op->op_flags & OPf_STACKED) {
4222	SV really = ++MARK;
4223	value = (I32)do_aexec(really, MARK, SP);
4224	}
4225	else if (SP - MARK != 1)
4226	#ifdef VMS
4227	value = (I32)vms_do_aexec(Nullsv, MARK, SP);
4228	#else
4229	# ifdef __OPEN_VM
4230	{
4231	(void ) do_aspawn(Nullsv, MARK, SP);
4232	value = 0;
4233	}
4234	# else
4235	value = (I32)do_aexec(Nullsv, MARK, SP);
4236	# endif
4237	#endif
4238	else {
4239	#ifdef VMS
4240	value = (I32)vms_do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
4241	#else
4242	# ifdef __OPEN_VM
4243	(void) do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
4244	value = 0;
4245	# else
4246	value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
4247	# endif
4248	#endif
4249	}
4250
4251	SP = ORIGMARK;
4252	PUSHi(value);
4253	RETURN;
4254	}
4255
4256	PP(pp_kill)
4257	{
4258	#ifdef HAS_KILL
4259	dSP; dMARK; dTARGET;
4260	I32 value;
4261	value = (I32)apply(PL_op->op_type, MARK, SP);
4262	SP = MARK;
4263	PUSHi(value);
4264	RETURN;
4265	#else
4266	DIE(aTHX_ PL_no_func, "kill");
4267	#endif
4268	}
4269
4270	PP(pp_getppid)
4271	{
4272	#ifdef HAS_GETPPID
4273	dSP; dTARGET;
4274	# ifdef THREADS_HAVE_PIDS
4275	XPUSHi( PL_ppid );
4276	# else
4277	XPUSHi( getppid() );
4278	# endif
4279	RETURN;
4280	#else
4281	DIE(aTHX_ PL_no_func, "getppid");
4282	#endif
4283	}
4284
4285	PP(pp_getpgrp)
4286	{
4287	#ifdef HAS_GETPGRP
4288	dSP; dTARGET;
4289	Pid_t pid;
4290	Pid_t pgrp;
4291
4292	if (MAXARG < 1)
4293	pid = 0;
4294	else
4295	pid = SvIVx(POPs);
4296	#ifdef BSD_GETPGRP
4297	pgrp = (I32)BSD_GETPGRP(pid);
4298	#else
4299	if (pid != 0 && pid != PerlProc_getpid())
4300	DIE(aTHX_ "POSIX getpgrp can't take an argument");
4301	pgrp = getpgrp();
4302	#endif
4303	XPUSHi(pgrp);
4304	RETURN;
4305	#else
4306	DIE(aTHX_ PL_no_func, "getpgrp()");
4307	#endif
4308	}
4309
4310	PP(pp_setpgrp)
4311	{
4312	#ifdef HAS_SETPGRP
4313	dSP; dTARGET;
4314	Pid_t pgrp;
4315	Pid_t pid;
4316	if (MAXARG < 2) {
4317	pgrp = 0;
4318	pid = 0;
4319	}
4320	else {
4321	pgrp = POPi;
4322	pid = TOPi;
4323	}
4324
4325	TAINT_PROPER("setpgrp");
4326	#ifdef BSD_SETPGRP
4327	SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4328	#else
4329	if ((pgrp != 0 && pgrp != PerlProc_getpid())
4330	\|\| (pid != 0 && pid != PerlProc_getpid()))
4331	{
4332	DIE(aTHX_ "setpgrp can't take arguments");
4333	}
4334	SETi( setpgrp() >= 0 );
4335	#endif /* USE_BSDPGRP */
4336	RETURN;
4337	#else
4338	DIE(aTHX_ PL_no_func, "setpgrp()");
4339	#endif
4340	}
4341
4342	PP(pp_getpriority)
4343	{
4344	#ifdef HAS_GETPRIORITY
4345	dSP; dTARGET;
4346	int who = POPi;
4347	int which = TOPi;
4348	SETi( getpriority(which, who) );
4349	RETURN;
4350	#else
4351	DIE(aTHX_ PL_no_func, "getpriority()");
4352	#endif
4353	}
4354
4355	PP(pp_setpriority)
4356	{
4357	#ifdef HAS_SETPRIORITY
4358	dSP; dTARGET;
4359	int niceval = POPi;
4360	int who = POPi;
4361	int which = TOPi;
4362	TAINT_PROPER("setpriority");
4363	SETi( setpriority(which, who, niceval) >= 0 );
4364	RETURN;
4365	#else
4366	DIE(aTHX_ PL_no_func, "setpriority()");
4367	#endif
4368	}
4369
4370	/* Time calls. */
4371
4372	PP(pp_time)
4373	{
4374	dSP; dTARGET;
4375	#ifdef BIG_TIME
4376	XPUSHn( time(Null(Time_t*)) );
4377	#else
4378	XPUSHi( time(Null(Time_t*)) );
4379	#endif
4380	RETURN;
4381	}
4382
4383	PP(pp_tms)
4384	{
4385	#ifdef HAS_TIMES
4386	dSP;
4387	EXTEND(SP, 4);
4388	#ifndef VMS
4389	(void)PerlProc_times(&PL_timesbuf);
4390	#else
4391	(void)PerlProc_times((tbuffer_t )&PL_timesbuf); / time.h uses different name for */
4392	/* struct tms, though same data */
4393	/* is returned. */
4394	#endif
4395
4396	PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick)));
4397	if (GIMME == G_ARRAY) {
4398	PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick)));
4399	PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick)));
4400	PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick)));
4401	}
4402	RETURN;
4403	#else
4404	# ifdef PERL_MICRO
4405	dSP;
4406	PUSHs(sv_2mortal(newSVnv((NV)0.0)));
4407	EXTEND(SP, 4);
4408	if (GIMME == G_ARRAY) {
4409	PUSHs(sv_2mortal(newSVnv((NV)0.0)));
4410	PUSHs(sv_2mortal(newSVnv((NV)0.0)));
4411	PUSHs(sv_2mortal(newSVnv((NV)0.0)));
4412	}
4413	RETURN;
4414	# else
4415	DIE(aTHX_ "times not implemented");
4416	# endif
4417	#endif /* HAS_TIMES */
4418	}
4419
4420	PP(pp_localtime)
4421	{
4422	return pp_gmtime();
4423	}
4424
4425	PP(pp_gmtime)
4426	{
4427	dSP;
4428	Time_t when;
4429	struct tm *tmbuf;
4430	static char *dayname[] = {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4431	static char *monname[] = {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4432	"Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4433
4434	if (MAXARG < 1)
4435	(void)time(&when);
4436	else
4437	#ifdef BIG_TIME
4438	when = (Time_t)SvNVx(POPs);
4439	#else
4440	when = (Time_t)SvIVx(POPs);
4441	#endif
4442
4443	if (PL_op->op_type == OP_LOCALTIME)
4444	tmbuf = localtime(&when);
4445	else
4446	tmbuf = gmtime(&when);
4447
4448	if (GIMME != G_ARRAY) {
4449	SV *tsv;
4450	EXTEND(SP, 1);
4451	EXTEND_MORTAL(1);
4452	if (!tmbuf)
4453	RETPUSHUNDEF;
4454	tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %d",
4455	dayname[tmbuf->tm_wday],
4456	monname[tmbuf->tm_mon],
4457	tmbuf->tm_mday,
4458	tmbuf->tm_hour,
4459	tmbuf->tm_min,
4460	tmbuf->tm_sec,
4461	tmbuf->tm_year + 1900);
4462	PUSHs(sv_2mortal(tsv));
4463	}
4464	else if (tmbuf) {
4465	EXTEND(SP, 9);
4466	EXTEND_MORTAL(9);
4467	PUSHs(sv_2mortal(newSViv(tmbuf->tm_sec)));
4468	PUSHs(sv_2mortal(newSViv(tmbuf->tm_min)));
4469	PUSHs(sv_2mortal(newSViv(tmbuf->tm_hour)));
4470	PUSHs(sv_2mortal(newSViv(tmbuf->tm_mday)));
4471	PUSHs(sv_2mortal(newSViv(tmbuf->tm_mon)));
4472	PUSHs(sv_2mortal(newSViv(tmbuf->tm_year)));
4473	PUSHs(sv_2mortal(newSViv(tmbuf->tm_wday)));
4474	PUSHs(sv_2mortal(newSViv(tmbuf->tm_yday)));
4475	PUSHs(sv_2mortal(newSViv(tmbuf->tm_isdst)));
4476	}
4477	RETURN;
4478	}
4479
4480	PP(pp_alarm)
4481	{
4482	#ifdef HAS_ALARM
4483	dSP; dTARGET;
4484	int anum;
4485	anum = POPi;
4486	anum = alarm((unsigned int)anum);
4487	EXTEND(SP, 1);
4488	if (anum < 0)
4489	RETPUSHUNDEF;
4490	PUSHi(anum);
4491	RETURN;
4492	#else
4493	DIE(aTHX_ PL_no_func, "alarm");
4494	#endif
4495	}
4496
4497	PP(pp_sleep)
4498	{
4499	dSP; dTARGET;
4500	I32 duration;
4501	Time_t lasttime;
4502	Time_t when;
4503
4504	(void)time(&lasttime);
4505	if (MAXARG < 1)
4506	PerlProc_pause();
4507	else {
4508	duration = POPi;
4509	PerlProc_sleep((unsigned int)duration);
4510	}
4511	(void)time(&when);
4512	XPUSHi(when - lasttime);
4513	RETURN;
4514	}
4515
4516	/* Shared memory. */
4517
4518	PP(pp_shmget)
4519	{
4520	return pp_semget();
4521	}
4522
4523	PP(pp_shmctl)
4524	{
4525	return pp_semctl();
4526	}
4527
4528	PP(pp_shmread)
4529	{
4530	return pp_shmwrite();
4531	}
4532
4533	PP(pp_shmwrite)
4534	{
4535	#if defined(HAS_MSG) \|\| defined(HAS_SEM) \|\| defined(HAS_SHM)
4536	dSP; dMARK; dTARGET;
4537	I32 value = (I32)(do_shmio(PL_op->op_type, MARK, SP) >= 0);
4538	SP = MARK;
4539	PUSHi(value);
4540	RETURN;
4541	#else
4542	return pp_semget();
4543	#endif
4544	}
4545
4546	/* Message passing. */
4547
4548	PP(pp_msgget)
4549	{
4550	return pp_semget();
4551	}
4552
4553	PP(pp_msgctl)
4554	{
4555	return pp_semctl();
4556	}
4557
4558	PP(pp_msgsnd)
4559	{
4560	#if defined(HAS_MSG) \|\| defined(HAS_SEM) \|\| defined(HAS_SHM)
4561	dSP; dMARK; dTARGET;
4562	I32 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4563	SP = MARK;
4564	PUSHi(value);
4565	RETURN;
4566	#else
4567	return pp_semget();
4568	#endif
4569	}
4570
4571	PP(pp_msgrcv)
4572	{
4573	#if defined(HAS_MSG) \|\| defined(HAS_SEM) \|\| defined(HAS_SHM)
4574	dSP; dMARK; dTARGET;
4575	I32 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4576	SP = MARK;
4577	PUSHi(value);
4578	RETURN;
4579	#else
4580	return pp_semget();
4581	#endif
4582	}
4583
4584	/* Semaphores. */
4585
4586	PP(pp_semget)
4587	{
4588	#if defined(HAS_MSG) \|\| defined(HAS_SEM) \|\| defined(HAS_SHM)
4589	dSP; dMARK; dTARGET;
4590	int anum = do_ipcget(PL_op->op_type, MARK, SP);
4591	SP = MARK;
4592	if (anum == -1)
4593	RETPUSHUNDEF;
4594	PUSHi(anum);
4595	RETURN;
4596	#else
4597	DIE(aTHX_ "System V IPC is not implemented on this machine");
4598	#endif
4599	}
4600
4601	PP(pp_semctl)
4602	{
4603	#if defined(HAS_MSG) \|\| defined(HAS_SEM) \|\| defined(HAS_SHM)
4604	dSP; dMARK; dTARGET;
4605	int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4606	SP = MARK;
4607	if (anum == -1)
4608	RETSETUNDEF;
4609	if (anum != 0) {
4610	PUSHi(anum);
4611	}
4612	else {
4613	PUSHp(zero_but_true, ZBTLEN);
4614	}
4615	RETURN;
4616	#else
4617	return pp_semget();
4618	#endif
4619	}
4620
4621	PP(pp_semop)
4622	{
4623	#if defined(HAS_MSG) \|\| defined(HAS_SEM) \|\| defined(HAS_SHM)
4624	dSP; dMARK; dTARGET;
4625	I32 value = (I32)(do_semop(MARK, SP) >= 0);
4626	SP = MARK;
4627	PUSHi(value);
4628	RETURN;
4629	#else
4630	return pp_semget();
4631	#endif
4632	}
4633
4634	/* Get system info. */
4635
4636	PP(pp_ghbyname)
4637	{
4638	#ifdef HAS_GETHOSTBYNAME
4639	return pp_ghostent();
4640	#else
4641	DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4642	#endif
4643	}
4644
4645	PP(pp_ghbyaddr)
4646	{
4647	#ifdef HAS_GETHOSTBYADDR
4648	return pp_ghostent();
4649	#else
4650	DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4651	#endif
4652	}
4653
4654	PP(pp_ghostent)
4655	{
4656	#if defined(HAS_GETHOSTBYNAME) \|\| defined(HAS_GETHOSTBYADDR) \|\| defined(HAS_GETHOSTENT)
4657	dSP;
4658	I32 which = PL_op->op_type;
4659	register char **elem;
4660	register SV *sv;
4661	#ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4662	struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4663	struct hostent *gethostbyname(Netdb_name_t);
4664	struct hostent *gethostent(void);
4665	#endif
4666	struct hostent *hent;
4667	unsigned long len;
4668	STRLEN n_a;
4669
4670	EXTEND(SP, 10);
4671	if (which == OP_GHBYNAME) {
4672	#ifdef HAS_GETHOSTBYNAME
4673	char* name = POPpbytex;
4674	hent = PerlSock_gethostbyname(name);
4675	#else
4676	DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4677	#endif
4678	}
4679	else if (which == OP_GHBYADDR) {
4680	#ifdef HAS_GETHOSTBYADDR
4681	int addrtype = POPi;
4682	SV *addrsv = POPs;
4683	STRLEN addrlen;
4684	Netdb_host_t addr = (Netdb_host_t) SvPVbyte(addrsv, addrlen);
4685
4686	hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4687	#else
4688	DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4689	#endif
4690	}
4691	else
4692	#ifdef HAS_GETHOSTENT
4693	hent = PerlSock_gethostent();
4694	#else
4695	DIE(aTHX_ PL_no_sock_func, "gethostent");
4696	#endif
4697
4698	#ifdef HOST_NOT_FOUND
4699	if (!hent) {
4700	#ifdef USE_REENTRANT_API
4701	# ifdef USE_GETHOSTENT_ERRNO
4702	h_errno = PL_reentrant_buffer->_gethostent_errno;
4703	# endif
4704	#endif
4705	STATUS_NATIVE_SET(h_errno);
4706	}
4707	#endif
4708
4709	if (GIMME != G_ARRAY) {
4710	PUSHs(sv = sv_newmortal());
4711	if (hent) {
4712	if (which == OP_GHBYNAME) {
4713	if (hent->h_addr)
4714	sv_setpvn(sv, hent->h_addr, hent->h_length);
4715	}
4716	else
4717	sv_setpv(sv, (char*)hent->h_name);
4718	}
4719	RETURN;
4720	}
4721
4722	if (hent) {
4723	PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4724	sv_setpv(sv, (char*)hent->h_name);
4725	PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4726	for (elem = hent->h_aliases; elem && *elem; elem++) {
4727	sv_catpv(sv, *elem);
4728	if (elem[1])
4729	sv_catpvn(sv, " ", 1);
4730	}
4731	PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4732	sv_setiv(sv, (IV)hent->h_addrtype);
4733	PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4734	len = hent->h_length;
4735	sv_setiv(sv, (IV)len);
4736	#ifdef h_addr
4737	for (elem = hent->h_addr_list; elem && *elem; elem++) {
4738	XPUSHs(sv = sv_mortalcopy(&PL_sv_no));
4739	sv_setpvn(sv, *elem, len);
4740	}
4741	#else
4742	PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4743	if (hent->h_addr)
4744	sv_setpvn(sv, hent->h_addr, len);
4745	#endif /* h_addr */
4746	}
4747	RETURN;
4748	#else
4749	DIE(aTHX_ PL_no_sock_func, "gethostent");
4750	#endif
4751	}
4752
4753	PP(pp_gnbyname)
4754	{
4755	#ifdef HAS_GETNETBYNAME
4756	return pp_gnetent();
4757	#else
4758	DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4759	#endif
4760	}
4761
4762	PP(pp_gnbyaddr)
4763	{
4764	#ifdef HAS_GETNETBYADDR
4765	return pp_gnetent();
4766	#else
4767	DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4768	#endif
4769	}
4770
4771	PP(pp_gnetent)
4772	{
4773	#if defined(HAS_GETNETBYNAME) \|\| defined(HAS_GETNETBYADDR) \|\| defined(HAS_GETNETENT)
4774	dSP;
4775	I32 which = PL_op->op_type;
4776	register char **elem;
4777	register SV *sv;
4778	#ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4779	struct netent *getnetbyaddr(Netdb_net_t, int);
4780	struct netent *getnetbyname(Netdb_name_t);
4781	struct netent *getnetent(void);
4782	#endif
4783	struct netent *nent;
4784	STRLEN n_a;
4785
4786	if (which == OP_GNBYNAME){
4787	#ifdef HAS_GETNETBYNAME
4788	char *name = POPpbytex;
4789	nent = PerlSock_getnetbyname(name);
4790	#else
4791	DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4792	#endif
4793	}
4794	else if (which == OP_GNBYADDR) {
4795	#ifdef HAS_GETNETBYADDR
4796	int addrtype = POPi;
4797	Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
4798	nent = PerlSock_getnetbyaddr(addr, addrtype);
4799	#else
4800	DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4801	#endif
4802	}
4803	else
4804	#ifdef HAS_GETNETENT
4805	nent = PerlSock_getnetent();
4806	#else
4807	DIE(aTHX_ PL_no_sock_func, "getnetent");
4808	#endif
4809
4810	#ifdef HOST_NOT_FOUND
4811	if (!nent) {
4812	#ifdef USE_REENTRANT_API
4813	# ifdef USE_GETNETENT_ERRNO
4814	h_errno = PL_reentrant_buffer->_getnetent_errno;
4815	# endif
4816	#endif
4817	STATUS_NATIVE_SET(h_errno);
4818	}
4819	#endif
4820
4821	EXTEND(SP, 4);
4822	if (GIMME != G_ARRAY) {
4823	PUSHs(sv = sv_newmortal());
4824	if (nent) {
4825	if (which == OP_GNBYNAME)
4826	sv_setiv(sv, (IV)nent->n_net);
4827	else
4828	sv_setpv(sv, nent->n_name);
4829	}
4830	RETURN;
4831	}
4832
4833	if (nent) {
4834	PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4835	sv_setpv(sv, nent->n_name);
4836	PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4837	for (elem = nent->n_aliases; elem && *elem; elem++) {
4838	sv_catpv(sv, *elem);
4839	if (elem[1])
4840	sv_catpvn(sv, " ", 1);
4841	}
4842	PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4843	sv_setiv(sv, (IV)nent->n_addrtype);
4844	PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4845	sv_setiv(sv, (IV)nent->n_net);
4846	}
4847
4848	RETURN;
4849	#else
4850	DIE(aTHX_ PL_no_sock_func, "getnetent");
4851	#endif
4852	}
4853
4854	PP(pp_gpbyname)
4855	{
4856	#ifdef HAS_GETPROTOBYNAME
4857	return pp_gprotoent();
4858	#else
4859	DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4860	#endif
4861	}
4862
4863	PP(pp_gpbynumber)
4864	{
4865	#ifdef HAS_GETPROTOBYNUMBER
4866	return pp_gprotoent();
4867	#else
4868	DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4869	#endif
4870	}
4871
4872	PP(pp_gprotoent)
4873	{
4874	#if defined(HAS_GETPROTOBYNAME) \|\| defined(HAS_GETPROTOBYNUMBER) \|\| defined(HAS_GETPROTOENT)
4875	dSP;
4876	I32 which = PL_op->op_type;
4877	register char **elem;
4878	register SV *sv;
4879	#ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4880	struct protoent *getprotobyname(Netdb_name_t);
4881	struct protoent *getprotobynumber(int);
4882	struct protoent *getprotoent(void);
4883	#endif
4884	struct protoent *pent;
4885	STRLEN n_a;
4886
4887	if (which == OP_GPBYNAME) {
4888	#ifdef HAS_GETPROTOBYNAME
4889	char* name = POPpbytex;
4890	pent = PerlSock_getprotobyname(name);
4891	#else
4892	DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4893	#endif
4894	}
4895	else if (which == OP_GPBYNUMBER) {
4896	#ifdef HAS_GETPROTOBYNUMBER
4897	int number = POPi;
4898	pent = PerlSock_getprotobynumber(number);
4899	#else
4900	DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4901	#endif
4902	}
4903	else
4904	#ifdef HAS_GETPROTOENT
4905	pent = PerlSock_getprotoent();
4906	#else
4907	DIE(aTHX_ PL_no_sock_func, "getprotoent");
4908	#endif
4909
4910	EXTEND(SP, 3);
4911	if (GIMME != G_ARRAY) {
4912	PUSHs(sv = sv_newmortal());
4913	if (pent) {
4914	if (which == OP_GPBYNAME)
4915	sv_setiv(sv, (IV)pent->p_proto);
4916	else
4917	sv_setpv(sv, pent->p_name);
4918	}
4919	RETURN;
4920	}
4921
4922	if (pent) {
4923	PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4924	sv_setpv(sv, pent->p_name);
4925	PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4926	for (elem = pent->p_aliases; elem && *elem; elem++) {
4927	sv_catpv(sv, *elem);
4928	if (elem[1])
4929	sv_catpvn(sv, " ", 1);
4930	}
4931	PUSHs(sv = sv_mortalcopy(&PL_sv_no));
4932	sv_setiv(sv, (IV)pent->p_proto);
4933	}
4934
4935	RETURN;
4936	#else
4937	DIE(aTHX_ PL_no_sock_func, "getprotoent");
4938	#endif
4939	}
4940
4941	PP(pp_gsbyname)
4942	{
4943	#ifdef HAS_GETSERVBYNAME
4944	return pp_gservent();
4945	#else
4946	DIE(aTHX_ PL_no_sock_func, "getservbyname");
4947	#endif
4948	}
4949
4950	PP(pp_gsbyport)
4951	{
4952	#ifdef HAS_GETSERVBYPORT
4953	return pp_gservent();
4954	#else
4955	DIE(aTHX_ PL_no_sock_func, "getservbyport");
4956	#endif
4957	}
4958
4959	PP(pp_gservent)
4960	{
4961	#if defined(HAS_GETSERVBYNAME) \|\| defined(HAS_GETSERVBYPORT) \|\| defined(HAS_GETSERVENT)
4962	dSP;
4963	I32 which = PL_op->op_type;
4964	register char **elem;
4965	register SV *sv;
4966	#ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4967	struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
4968	struct servent *getservbyport(int, Netdb_name_t);
4969	struct servent *getservent(void);
4970	#endif
4971	struct servent *sent;
4972	STRLEN n_a;
4973
4974	if (which == OP_GSBYNAME) {
4975	#ifdef HAS_GETSERVBYNAME
4976	char *proto = POPpbytex;
4977	char *name = POPpbytex;
4978
4979	if (proto && !*proto)
4980	proto = Nullch;
4981
4982	sent = PerlSock_getservbyname(name, proto);
4983	#else
4984	DIE(aTHX_ PL_no_sock_func, "getservbyname");
4985	#endif
4986	}
4987	else if (which == OP_GSBYPORT) {
4988	#ifdef HAS_GETSERVBYPORT
4989	char *proto = POPpbytex;
4990	unsigned short port = (unsigned short)POPu;
4991
4992	if (proto && !*proto)
4993	proto = Nullch;
4994
4995	#ifdef HAS_HTONS
4996	port = PerlSock_htons(port);
4997	#endif
4998	sent = PerlSock_getservbyport(port, proto);
4999	#else
5000	DIE(aTHX_ PL_no_sock_func, "getservbyport");
5001	#endif
5002	}
5003	else
5004	#ifdef HAS_GETSERVENT
5005	sent = PerlSock_getservent();
5006	#else
5007	DIE(aTHX_ PL_no_sock_func, "getservent");
5008	#endif
5009
5010	EXTEND(SP, 4);
5011	if (GIMME != G_ARRAY) {
5012	PUSHs(sv = sv_newmortal());
5013	if (sent) {
5014	if (which == OP_GSBYNAME) {
5015	#ifdef HAS_NTOHS
5016	sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
5017	#else
5018	sv_setiv(sv, (IV)(sent->s_port));
5019	#endif
5020	}
5021	else
5022	sv_setpv(sv, sent->s_name);
5023	}
5024	RETURN;
5025	}
5026
5027	if (sent) {
5028	PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5029	sv_setpv(sv, sent->s_name);
5030	PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5031	for (elem = sent->s_aliases; elem && *elem; elem++) {
5032	sv_catpv(sv, *elem);
5033	if (elem[1])
5034	sv_catpvn(sv, " ", 1);
5035	}
5036	PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5037	#ifdef HAS_NTOHS
5038	sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
5039	#else
5040	sv_setiv(sv, (IV)(sent->s_port));
5041	#endif
5042	PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5043	sv_setpv(sv, sent->s_proto);
5044	}
5045
5046	RETURN;
5047	#else
5048	DIE(aTHX_ PL_no_sock_func, "getservent");
5049	#endif
5050	}
5051
5052	PP(pp_shostent)
5053	{
5054	#ifdef HAS_SETHOSTENT
5055	dSP;
5056	PerlSock_sethostent(TOPi);
5057	RETSETYES;
5058	#else
5059	DIE(aTHX_ PL_no_sock_func, "sethostent");
5060	#endif
5061	}
5062
5063	PP(pp_snetent)
5064	{
5065	#ifdef HAS_SETNETENT
5066	dSP;
5067	PerlSock_setnetent(TOPi);
5068	RETSETYES;
5069	#else
5070	DIE(aTHX_ PL_no_sock_func, "setnetent");
5071	#endif
5072	}
5073
5074	PP(pp_sprotoent)
5075	{
5076	#ifdef HAS_SETPROTOENT
5077	dSP;
5078	PerlSock_setprotoent(TOPi);
5079	RETSETYES;
5080	#else
5081	DIE(aTHX_ PL_no_sock_func, "setprotoent");
5082	#endif
5083	}
5084
5085	PP(pp_sservent)
5086	{
5087	#ifdef HAS_SETSERVENT
5088	dSP;
5089	PerlSock_setservent(TOPi);
5090	RETSETYES;
5091	#else
5092	DIE(aTHX_ PL_no_sock_func, "setservent");
5093	#endif
5094	}
5095
5096	PP(pp_ehostent)
5097	{
5098	#ifdef HAS_ENDHOSTENT
5099	dSP;
5100	PerlSock_endhostent();
5101	EXTEND(SP,1);
5102	RETPUSHYES;
5103	#else
5104	DIE(aTHX_ PL_no_sock_func, "endhostent");
5105	#endif
5106	}
5107
5108	PP(pp_enetent)
5109	{
5110	#ifdef HAS_ENDNETENT
5111	dSP;
5112	PerlSock_endnetent();
5113	EXTEND(SP,1);
5114	RETPUSHYES;
5115	#else
5116	DIE(aTHX_ PL_no_sock_func, "endnetent");
5117	#endif
5118	}
5119
5120	PP(pp_eprotoent)
5121	{
5122	#ifdef HAS_ENDPROTOENT
5123	dSP;
5124	PerlSock_endprotoent();
5125	EXTEND(SP,1);
5126	RETPUSHYES;
5127	#else
5128	DIE(aTHX_ PL_no_sock_func, "endprotoent");
5129	#endif
5130	}
5131
5132	PP(pp_eservent)
5133	{
5134	#ifdef HAS_ENDSERVENT
5135	dSP;
5136	PerlSock_endservent();
5137	EXTEND(SP,1);
5138	RETPUSHYES;
5139	#else
5140	DIE(aTHX_ PL_no_sock_func, "endservent");
5141	#endif
5142	}
5143
5144	PP(pp_gpwnam)
5145	{
5146	#ifdef HAS_PASSWD
5147	return pp_gpwent();
5148	#else
5149	DIE(aTHX_ PL_no_func, "getpwnam");
5150	#endif
5151	}
5152
5153	PP(pp_gpwuid)
5154	{
5155	#ifdef HAS_PASSWD
5156	return pp_gpwent();
5157	#else
5158	DIE(aTHX_ PL_no_func, "getpwuid");
5159	#endif
5160	}
5161
5162	PP(pp_gpwent)
5163	{
5164	#ifdef HAS_PASSWD
5165	dSP;
5166	I32 which = PL_op->op_type;
5167	register SV *sv;
5168	STRLEN n_a;
5169	struct passwd *pwent = NULL;
5170	/*
5171	* We currently support only the SysV getsp* shadow password interface.
5172	* The interface is declared in <shadow.h> and often one needs to link
5173	* with -lsecurity or some such.
5174	* This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5175	* (and SCO?)
5176	*
5177	* AIX getpwnam() is clever enough to return the encrypted password
5178	* only if the caller (euid?) is root.
5179	*
5180	* There are at least three other shadow password APIs. Many platforms
5181	* seem to contain more than one interface for accessing the shadow
5182	* password databases, possibly for compatibility reasons.
5183	* The getsp*() is by far he simplest one, the other two interfaces
5184	* are much more complicated, but also very similar to each other.
5185	*
5186	* <sys/types.h>
5187	* <sys/security.h>
5188	* <prot.h>
5189	* struct pr_passwd getprpw();
5190	* The password is in
5191	* char getprpw*(...).ufld.fd_encrypt[]
5192	* Mention HAS_GETPRPWNAM here so that Configure probes for it.
5193	*
5194	* <sys/types.h>
5195	* <sys/security.h>
5196	* <prot.h>
5197	* struct es_passwd getespw();
5198	* The password is in
5199	* char (getespw(...).ufld.fd_encrypt)
5200	* Mention HAS_GETESPWNAM here so that Configure probes for it.
5201	*
5202	* <userpw.h> (AIX)
5203	* struct userpw *getuserpw();
5204	* The password is in
5205	* char *(getuserpw(...)).spw_upw_passwd
5206	* (but the de facto standard getpwnam() should work okay)
5207	*
5208	* Mention I_PROT here so that Configure probes for it.
5209	*
5210	* In HP-UX for getprpw*() the manual page claims that one should include
5211	* <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5212	* if one includes <shadow.h> as that includes <hpsecurity.h>,
5213	* and pp_sys.c already includes <shadow.h> if there is such.
5214	*
5215	* Note that <sys/security.h> is already probed for, but currently
5216	* it is only included in special cases.
5217	*
5218	* In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5219	* be preferred interface, even though also the getprpw*() interface
5220	* is available) one needs to link with -lsecurity -ldb -laud -lm.
5221	* One also needs to call set_auth_parameters() in main() before
5222	* doing anything else, whether one is using getespw() or getprpw().
5223	*
5224	* Note that accessing the shadow databases can be magnitudes
5225	* slower than accessing the standard databases.
5226	*
5227	* --jhi
5228	*/
5229
5230	# if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5231	/* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5232	* the pw_comment is left uninitialized. */
5233	PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5234	# endif
5235
5236	switch (which) {
5237	case OP_GPWNAM:
5238	{
5239	char* name = POPpbytex;
5240	pwent = getpwnam(name);
5241	}
5242	break;
5243	case OP_GPWUID:
5244	{
5245	Uid_t uid = POPi;
5246	pwent = getpwuid(uid);
5247	}
5248	break;
5249	case OP_GPWENT:
5250	# ifdef HAS_GETPWENT
5251	pwent = getpwent();
5252	#ifdef POSIX_BC /* In some cases pw_passwd has invalid addresses */
5253	if (pwent) pwent = getpwnam(pwent->pw_name);
5254	#endif
5255	# else
5256	DIE(aTHX_ PL_no_func, "getpwent");
5257	# endif
5258	break;
5259	}
5260
5261	EXTEND(SP, 10);
5262	if (GIMME != G_ARRAY) {
5263	PUSHs(sv = sv_newmortal());
5264	if (pwent) {
5265	if (which == OP_GPWNAM)
5266	# if Uid_t_sign <= 0
5267	sv_setiv(sv, (IV)pwent->pw_uid);
5268	# else
5269	sv_setuv(sv, (UV)pwent->pw_uid);
5270	# endif
5271	else
5272	sv_setpv(sv, pwent->pw_name);
5273	}
5274	RETURN;
5275	}
5276
5277	if (pwent) {
5278	PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5279	sv_setpv(sv, pwent->pw_name);
5280
5281	PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5282	SvPOK_off(sv);
5283	/* If we have getspnam(), we try to dig up the shadow
5284	* password. If we are underprivileged, the shadow
5285	* interface will set the errno to EACCES or similar,
5286	* and return a null pointer. If this happens, we will
5287	* use the dummy password (usually "*" or "x") from the
5288	* standard password database.
5289	*
5290	* In theory we could skip the shadow call completely
5291	* if euid != 0 but in practice we cannot know which
5292	* security measures are guarding the shadow databases
5293	* on a random platform.
5294	*
5295	* Resist the urge to use additional shadow interfaces.
5296	* Divert the urge to writing an extension instead.
5297	*
5298	* --jhi */
5299	/* Some AIX setups falsely(?) detect some getspnam(), which
5300	* has a different API than the Solaris/IRIX one. */
5301	# if defined(HAS_GETSPNAM) && !defined(_AIX)
5302	{
5303	struct spwd *spwent;
5304	int saverrno; /* Save and restore errno so that
5305	* underprivileged attempts seem
5306	* to have never made the unsccessful
5307	* attempt to retrieve the shadow password. */
5308
5309	saverrno = errno;
5310	spwent = getspnam(pwent->pw_name);
5311	errno = saverrno;
5312	if (spwent && spwent->sp_pwdp)
5313	sv_setpv(sv, spwent->sp_pwdp);
5314	}
5315	# endif
5316	# ifdef PWPASSWD
5317	if (!SvPOK(sv)) /* Use the standard password, then. */
5318	sv_setpv(sv, pwent->pw_passwd);
5319	# endif
5320
5321	# ifndef INCOMPLETE_TAINTS
5322	/* passwd is tainted because user himself can diddle with it.
5323	* admittedly not much and in a very limited way, but nevertheless. */
5324	SvTAINTED_on(sv);
5325	# endif
5326
5327	PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5328	# if Uid_t_sign <= 0
5329	sv_setiv(sv, (IV)pwent->pw_uid);
5330	# else
5331	sv_setuv(sv, (UV)pwent->pw_uid);
5332	# endif
5333
5334	PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5335	# if Uid_t_sign <= 0
5336	sv_setiv(sv, (IV)pwent->pw_gid);
5337	# else
5338	sv_setuv(sv, (UV)pwent->pw_gid);
5339	# endif
5340	/* pw_change, pw_quota, and pw_age are mutually exclusive--
5341	* because of the poor interface of the Perl getpw*(),
5342	* not because there's some standard/convention saying so.
5343	* A better interface would have been to return a hash,
5344	* but we are accursed by our history, alas. --jhi. */
5345	PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5346	# ifdef PWCHANGE
5347	sv_setiv(sv, (IV)pwent->pw_change);
5348	# else
5349	# ifdef PWQUOTA
5350	sv_setiv(sv, (IV)pwent->pw_quota);
5351	# else
5352	# ifdef PWAGE
5353	sv_setpv(sv, pwent->pw_age);
5354	# endif
5355	# endif
5356	# endif
5357
5358	/* pw_class and pw_comment are mutually exclusive--.
5359	* see the above note for pw_change, pw_quota, and pw_age. */
5360	PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5361	# ifdef PWCLASS
5362	sv_setpv(sv, pwent->pw_class);
5363	# else
5364	# ifdef PWCOMMENT
5365	sv_setpv(sv, pwent->pw_comment);
5366	# endif
5367	# endif
5368
5369	PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5370	# ifdef PWGECOS
5371	sv_setpv(sv, pwent->pw_gecos);
5372	# endif
5373	# ifndef INCOMPLETE_TAINTS
5374	/* pw_gecos is tainted because user himself can diddle with it. */
5375	SvTAINTED_on(sv);
5376	# endif
5377
5378	PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5379	sv_setpv(sv, pwent->pw_dir);
5380
5381	PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5382	sv_setpv(sv, pwent->pw_shell);
5383	# ifndef INCOMPLETE_TAINTS
5384	/* pw_shell is tainted because user himself can diddle with it. */
5385	SvTAINTED_on(sv);
5386	# endif
5387
5388	# ifdef PWEXPIRE
5389	PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5390	sv_setiv(sv, (IV)pwent->pw_expire);
5391	# endif
5392	}
5393	RETURN;
5394	#else
5395	DIE(aTHX_ PL_no_func, "getpwent");
5396	#endif
5397	}
5398
5399	PP(pp_spwent)
5400	{
5401	#if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5402	dSP;
5403	setpwent();
5404	RETPUSHYES;
5405	#else
5406	DIE(aTHX_ PL_no_func, "setpwent");
5407	#endif
5408	}
5409
5410	PP(pp_epwent)
5411	{
5412	#if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5413	dSP;
5414	endpwent();
5415	RETPUSHYES;
5416	#else
5417	DIE(aTHX_ PL_no_func, "endpwent");
5418	#endif
5419	}
5420
5421	PP(pp_ggrnam)
5422	{
5423	#ifdef HAS_GROUP
5424	return pp_ggrent();
5425	#else
5426	DIE(aTHX_ PL_no_func, "getgrnam");
5427	#endif
5428	}
5429
5430	PP(pp_ggrgid)
5431	{
5432	#ifdef HAS_GROUP
5433	return pp_ggrent();
5434	#else
5435	DIE(aTHX_ PL_no_func, "getgrgid");
5436	#endif
5437	}
5438
5439	PP(pp_ggrent)
5440	{
5441	#ifdef HAS_GROUP
5442	dSP;
5443	I32 which = PL_op->op_type;
5444	register char **elem;
5445	register SV *sv;
5446	struct group *grent;
5447	STRLEN n_a;
5448
5449	if (which == OP_GGRNAM) {
5450	char* name = POPpbytex;
5451	grent = (struct group *)getgrnam(name);
5452	}
5453	else if (which == OP_GGRGID) {
5454	Gid_t gid = POPi;
5455	grent = (struct group *)getgrgid(gid);
5456	}
5457	else
5458	#ifdef HAS_GETGRENT
5459	grent = (struct group *)getgrent();
5460	#else
5461	DIE(aTHX_ PL_no_func, "getgrent");
5462	#endif
5463
5464	EXTEND(SP, 4);
5465	if (GIMME != G_ARRAY) {
5466	PUSHs(sv = sv_newmortal());
5467	if (grent) {
5468	if (which == OP_GGRNAM)
5469	sv_setiv(sv, (IV)grent->gr_gid);
5470	else
5471	sv_setpv(sv, grent->gr_name);
5472	}
5473	RETURN;
5474	}
5475
5476	if (grent) {
5477	PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5478	sv_setpv(sv, grent->gr_name);
5479
5480	PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5481	#ifdef GRPASSWD
5482	sv_setpv(sv, grent->gr_passwd);
5483	#endif
5484
5485	PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5486	sv_setiv(sv, (IV)grent->gr_gid);
5487
5488	#if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
5489	PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5490	/* In UNICOS/mk (_CRAYMPP) the multithreading
5491	* versions (getgrnam_r, getgrgid_r)
5492	* seem to return an illegal pointer
5493	* as the group members list, gr_mem.
5494	* getgrent() doesn't even have a _r version
5495	* but the gr_mem is poisonous anyway.
5496	* So yes, you cannot get the list of group
5497	* members if building multithreaded in UNICOS/mk. */
5498	for (elem = grent->gr_mem; elem && *elem; elem++) {
5499	sv_catpv(sv, *elem);
5500	if (elem[1])
5501	sv_catpvn(sv, " ", 1);
5502	}
5503	#endif
5504	}
5505
5506	RETURN;
5507	#else
5508	DIE(aTHX_ PL_no_func, "getgrent");
5509	#endif
5510	}
5511
5512	PP(pp_sgrent)
5513	{
5514	#if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5515	dSP;
5516	setgrent();
5517	RETPUSHYES;
5518	#else
5519	DIE(aTHX_ PL_no_func, "setgrent");
5520	#endif
5521	}
5522
5523	PP(pp_egrent)
5524	{
5525	#if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5526	dSP;
5527	endgrent();
5528	RETPUSHYES;
5529	#else
5530	DIE(aTHX_ PL_no_func, "endgrent");
5531	#endif
5532	}
5533
5534	PP(pp_getlogin)
5535	{
5536	#ifdef HAS_GETLOGIN
5537	dSP; dTARGET;
5538	char *tmps;
5539	EXTEND(SP, 1);
5540	if (!(tmps = PerlProc_getlogin()))
5541	RETPUSHUNDEF;
5542	PUSHp(tmps, strlen(tmps));
5543	RETURN;
5544	#else
5545	DIE(aTHX_ PL_no_func, "getlogin");
5546	#endif
5547	}
5548
5549	/* Miscellaneous. */
5550
5551	PP(pp_syscall)
5552	{
5553	#ifdef HAS_SYSCALL
5554	dSP; dMARK; dORIGMARK; dTARGET;
5555	register I32 items = SP - MARK;
5556	unsigned long a[20];
5557	register I32 i = 0;
5558	I32 retval = -1;
5559	STRLEN n_a;
5560
5561	if (PL_tainting) {
5562	while (++MARK <= SP) {
5563	if (SvTAINTED(*MARK)) {
5564	TAINT;
5565	break;
5566	}
5567	}
5568	MARK = ORIGMARK;
5569	TAINT_PROPER("syscall");
5570	}
5571
5572	/* This probably won't work on machines where sizeof(long) != sizeof(int)
5573	* or where sizeof(long) != sizeof(char*). But such machines will
5574	* not likely have syscall implemented either, so who cares?
5575	*/
5576	while (++MARK <= SP) {
5577	if (SvNIOK(*MARK) \|\| !i)
5578	a[i++] = SvIV(*MARK);
5579	else if (*MARK == &PL_sv_undef)
5580	a[i++] = 0;
5581	else
5582	a[i++] = (unsigned long)SvPV_force(*MARK, n_a);
5583	if (i > 15)
5584	break;
5585	}
5586	switch (items) {
5587	default:
5588	DIE(aTHX_ "Too many args to syscall");
5589	case 0:
5590	DIE(aTHX_ "Too few args to syscall");
5591	case 1:
5592	retval = syscall(a[0]);
5593	break;
5594	case 2:
5595	retval = syscall(a[0],a[1]);
5596	break;
5597	case 3:
5598	retval = syscall(a[0],a[1],a[2]);
5599	break;
5600	case 4:
5601	retval = syscall(a[0],a[1],a[2],a[3]);
5602	break;
5603	case 5:
5604	retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5605	break;
5606	case 6:
5607	retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5608	break;
5609	case 7:
5610	retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5611	break;
5612	case 8:
5613	retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5614	break;
5615	#ifdef atarist
5616	case 9:
5617	retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5618	break;
5619	case 10:
5620	retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
5621	break;
5622	case 11:
5623	retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5624	a[10]);
5625	break;
5626	case 12:
5627	retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5628	a[10],a[11]);
5629	break;
5630	case 13:
5631	retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5632	a[10],a[11],a[12]);
5633	break;
5634	case 14:
5635	retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5636	a[10],a[11],a[12],a[13]);
5637	break;
5638	#endif /* atarist */
5639	}
5640	SP = ORIGMARK;
5641	PUSHi(retval);
5642	RETURN;
5643	#else
5644	DIE(aTHX_ PL_no_func, "syscall");
5645	#endif
5646	}
5647
5648	#ifdef FCNTL_EMULATE_FLOCK
5649
5650	/* XXX Emulate flock() with fcntl().
5651	What's really needed is a good file locking module.
5652	*/
5653
5654	static int
5655	fcntl_emulate_flock(int fd, int operation)
5656	{
5657	struct flock flock;
5658
5659	switch (operation & ~LOCK_NB) {
5660	case LOCK_SH:
5661	flock.l_type = F_RDLCK;
5662	break;
5663	case LOCK_EX:
5664	flock.l_type = F_WRLCK;
5665	break;
5666	case LOCK_UN:
5667	flock.l_type = F_UNLCK;
5668	break;
5669	default:
5670	errno = EINVAL;
5671	return -1;
5672	}
5673	flock.l_whence = SEEK_SET;
5674	flock.l_start = flock.l_len = (Off_t)0;
5675
5676	return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5677	}
5678
5679	#endif /* FCNTL_EMULATE_FLOCK */
5680
5681	#ifdef LOCKF_EMULATE_FLOCK
5682
5683	/* XXX Emulate flock() with lockf(). This is just to increase
5684	portability of scripts. The calls are not completely
5685	interchangeable. What's really needed is a good file
5686	locking module.
5687	*/
5688
5689	/* The lockf() constants might have been defined in <unistd.h>.
5690	Unfortunately, <unistd.h> causes troubles on some mixed
5691	(BSD/POSIX) systems, such as SunOS 4.1.3.
5692
5693	Further, the lockf() constants aren't POSIX, so they might not be
5694	visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
5695	just stick in the SVID values and be done with it. Sigh.
5696	*/
5697
5698	# ifndef F_ULOCK
5699	# define F_ULOCK 0 /* Unlock a previously locked region */
5700	# endif
5701	# ifndef F_LOCK
5702	# define F_LOCK 1 /* Lock a region for exclusive use */
5703	# endif
5704	# ifndef F_TLOCK
5705	# define F_TLOCK 2 /* Test and lock a region for exclusive use */
5706	# endif
5707	# ifndef F_TEST
5708	# define F_TEST 3 /* Test a region for other processes locks */
5709	# endif
5710
5711	static int
5712	lockf_emulate_flock(int fd, int operation)
5713	{
5714	int i;
5715	int save_errno;
5716	Off_t pos;
5717
5718	/* flock locks entire file so for lockf we need to do the same */
5719	save_errno = errno;
5720	pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
5721	if (pos > 0) /* is seekable and needs to be repositioned */
5722	if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5723	pos = -1; /* seek failed, so don't seek back afterwards */
5724	errno = save_errno;
5725
5726	switch (operation) {
5727
5728	/* LOCK_SH - get a shared lock */
5729	case LOCK_SH:
5730	/* LOCK_EX - get an exclusive lock */
5731	case LOCK_EX:
5732	i = lockf (fd, F_LOCK, 0);
5733	break;
5734
5735	/* LOCK_SH\|LOCK_NB - get a non-blocking shared lock */
5736	case LOCK_SH\|LOCK_NB:
5737	/* LOCK_EX\|LOCK_NB - get a non-blocking exclusive lock */
5738	case LOCK_EX\|LOCK_NB:
5739	i = lockf (fd, F_TLOCK, 0);
5740	if (i == -1)
5741	if ((errno == EAGAIN) \|\| (errno == EACCES))
5742	errno = EWOULDBLOCK;
5743	break;
5744
5745	/* LOCK_UN - unlock (non-blocking is a no-op) */
5746	case LOCK_UN:
5747	case LOCK_UN\|LOCK_NB:
5748	i = lockf (fd, F_ULOCK, 0);
5749	break;
5750
5751	/* Default - can't decipher operation */
5752	default:
5753	i = -1;
5754	errno = EINVAL;
5755	break;
5756	}
5757
5758	if (pos > 0) /* need to restore position of the handle */
5759	PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
5760
5761	return (i);
5762	}
5763
5764	#endif /* LOCKF_EMULATE_FLOCK */

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

Context Navigation

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

Download in other formats: