This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
resync with mainline
[perl5.git] / pp_sys.c
CommitLineData
a0d0e21e
LW
1/* pp_sys.c
2 *
4eb8286e 3 * Copyright (c) 1991-1999, Larry Wall
a0d0e21e
LW
4 *
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
7 *
8 */
9
10/*
11 * But only a short way ahead its floor and the walls on either side were
12 * cloven by a great fissure, out of which the red glare came, now leaping
13 * up, now dying down into darkness; and all the while far below there was
14 * a rumour and a trouble as of great engines throbbing and labouring.
15 */
16
17#include "EXTERN.h"
864dbfa3 18#define PERL_IN_PP_SYS_C
a0d0e21e
LW
19#include "perl.h"
20
f1066039
JH
21#ifdef I_SHADOW
22/* Shadow password support for solaris - pdo@cs.umd.edu
23 * Not just Solaris: at least HP-UX, IRIX, Linux.
24 * the API is from SysV. --jhi */
c529f79d
CB
25#ifdef __hpux__
26/* There is a MAXINT coming from <shadow.h> <- <hpsecurity.h> <- <values.h>
27 * and another MAXINT from "perl.h" <- <sys/param.h>. */
28#undef MAXINT
29#endif
8c0bfa08
PB
30#include <shadow.h>
31#endif
32
76c32331
PP
33/* XXX If this causes problems, set i_unistd=undef in the hint file. */
34#ifdef I_UNISTD
35# include <unistd.h>
36#endif
37
8ac85365
NIS
38#ifdef HAS_SYSCALL
39#ifdef __cplusplus
40extern "C" int syscall(unsigned long,...);
41#endif
42#endif
43
76c32331
PP
44#ifdef I_SYS_WAIT
45# include <sys/wait.h>
46#endif
47
48#ifdef I_SYS_RESOURCE
49# include <sys/resource.h>
16d20bd9 50#endif
a0d0e21e
LW
51
52#if defined(HAS_SOCKET) && !defined(VMS) /* VMS handles sockets via vmsish.h */
53# include <sys/socket.h>
29209bc5 54# if defined(USE_SOCKS) && defined(I_SOCKS)
86959918
JH
55# include <socks.h>
56# endif
3fd537d4
JH
57# ifdef I_NETDB
58# include <netdb.h>
59# endif
a0d0e21e
LW
60# ifndef ENOTSOCK
61# ifdef I_NET_ERRNO
62# include <net/errno.h>
63# endif
64# endif
65#endif
66
67#ifdef HAS_SELECT
68#ifdef I_SYS_SELECT
a0d0e21e
LW
69#include <sys/select.h>
70#endif
71#endif
a0d0e21e 72
dc45a647
MB
73/* XXX Configure test needed.
74 h_errno might not be a simple 'int', especially for multi-threaded
5ff3f7a4
GS
75 applications, see "extern int errno in perl.h". Creating such
76 a test requires taking into account the differences between
77 compiling multithreaded and singlethreaded ($ccflags et al).
78 HOST_NOT_FOUND is typically defined in <netdb.h>.
dc45a647
MB
79*/
80#if defined(HOST_NOT_FOUND) && !defined(h_errno)
a0d0e21e
LW
81extern int h_errno;
82#endif
83
84#ifdef HAS_PASSWD
85# ifdef I_PWD
86# include <pwd.h>
87# else
20ce7b12
GS
88 struct passwd *getpwnam (char *);
89 struct passwd *getpwuid (Uid_t);
a0d0e21e 90# endif
28e8609d 91# ifdef HAS_GETPWENT
20ce7b12 92 struct passwd *getpwent (void);
28e8609d 93# endif
a0d0e21e
LW
94#endif
95
96#ifdef HAS_GROUP
97# ifdef I_GRP
98# include <grp.h>
99# else
20ce7b12
GS
100 struct group *getgrnam (char *);
101 struct group *getgrgid (Gid_t);
a0d0e21e 102# endif
28e8609d 103# ifdef HAS_GETGRENT
20ce7b12 104 struct group *getgrent (void);
28e8609d 105# endif
a0d0e21e
LW
106#endif
107
108#ifdef I_UTIME
3730b96e 109# if defined(_MSC_VER) || defined(__MINGW32__)
3fe9a6f1
PP
110# include <sys/utime.h>
111# else
112# include <utime.h>
113# endif
a0d0e21e
LW
114#endif
115#ifdef I_FCNTL
116#include <fcntl.h>
117#endif
118#ifdef I_SYS_FILE
119#include <sys/file.h>
120#endif
121
54310121
PP
122/* Put this after #includes because fork and vfork prototypes may conflict. */
123#ifndef HAS_VFORK
124# define vfork fork
125#endif
126
d574b85e
CS
127/* Put this after #includes because <unistd.h> defines _XOPEN_*. */
128#ifndef Sock_size_t
137443ea 129# if _XOPEN_VERSION >= 5 || defined(_XOPEN_SOURCE_EXTENDED) || defined(__GLIBC__)
d574b85e
CS
130# define Sock_size_t Size_t
131# else
132# define Sock_size_t int
133# endif
54310121
PP
134#endif
135
cbdc8872 136#ifdef HAS_CHSIZE
cd52b7b2
PP
137# ifdef my_chsize /* Probably #defined to Perl_my_chsize in embed.h */
138# undef my_chsize
139# endif
6ad3d225 140# define my_chsize PerlLIO_chsize
cbdc8872
PP
141#endif
142
ff68c719
PP
143#ifdef HAS_FLOCK
144# define FLOCK flock
145#else /* no flock() */
146
36477c24
PP
147 /* fcntl.h might not have been included, even if it exists, because
148 the current Configure only sets I_FCNTL if it's needed to pick up
149 the *_OK constants. Make sure it has been included before testing
150 the fcntl() locking constants. */
151# if defined(HAS_FCNTL) && !defined(I_FCNTL)
152# include <fcntl.h>
153# endif
154
ff68c719
PP
155# if defined(HAS_FCNTL) && defined(F_SETLK) && defined (F_SETLKW)
156# define FLOCK fcntl_emulate_flock
157# define FCNTL_EMULATE_FLOCK
158# else /* no flock() or fcntl(F_SETLK,...) */
159# ifdef HAS_LOCKF
160# define FLOCK lockf_emulate_flock
161# define LOCKF_EMULATE_FLOCK
162# endif /* lockf */
163# endif /* no flock() or fcntl(F_SETLK,...) */
164
165# ifdef FLOCK
20ce7b12 166 static int FLOCK (int, int);
ff68c719
PP
167
168 /*
169 * These are the flock() constants. Since this sytems doesn't have
170 * flock(), the values of the constants are probably not available.
171 */
172# ifndef LOCK_SH
173# define LOCK_SH 1
174# endif
175# ifndef LOCK_EX
176# define LOCK_EX 2
177# endif
178# ifndef LOCK_NB
179# define LOCK_NB 4
180# endif
181# ifndef LOCK_UN
182# define LOCK_UN 8
183# endif
184# endif /* emulating flock() */
185
186#endif /* no flock() */
55497cff 187
85ab1d1d
JH
188#define ZBTLEN 10
189static char zero_but_true[ZBTLEN + 1] = "0 but true";
190
5ff3f7a4
GS
191#if defined(I_SYS_ACCESS) && !defined(R_OK)
192# include <sys/access.h>
193#endif
194
c529f79d
CB
195#if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
196# define FD_CLOEXEC 1 /* NeXT needs this */
197#endif
198
5ff3f7a4
GS
199#undef PERL_EFF_ACCESS_R_OK /* EFFective uid/gid ACCESS R_OK */
200#undef PERL_EFF_ACCESS_W_OK
201#undef PERL_EFF_ACCESS_X_OK
202
203/* F_OK unused: if stat() cannot find it... */
204
205#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_ACCESS) && defined(EFF_ONLY_OK) && !defined(NO_EFF_ONLY_OK)
c955f117 206 /* Digital UNIX (when the EFF_ONLY_OK gets fixed), UnixWare */
5ff3f7a4
GS
207# define PERL_EFF_ACCESS_R_OK(p) (access((p), R_OK | EFF_ONLY_OK))
208# define PERL_EFF_ACCESS_W_OK(p) (access((p), W_OK | EFF_ONLY_OK))
209# define PERL_EFF_ACCESS_X_OK(p) (access((p), X_OK | EFF_ONLY_OK))
210#endif
211
212#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_EACCESS)
5ff3f7a4
GS
213# if defined(I_SYS_SECURITY)
214# include <sys/security.h>
215# endif
c955f117
JH
216 /* XXX Configure test needed for eaccess */
217# ifdef ACC_SELF
218 /* HP SecureWare */
219# define PERL_EFF_ACCESS_R_OK(p) (eaccess((p), R_OK, ACC_SELF))
220# define PERL_EFF_ACCESS_W_OK(p) (eaccess((p), W_OK, ACC_SELF))
221# define PERL_EFF_ACCESS_X_OK(p) (eaccess((p), X_OK, ACC_SELF))
222# else
223 /* SCO */
224# define PERL_EFF_ACCESS_R_OK(p) (eaccess((p), R_OK))
225# define PERL_EFF_ACCESS_W_OK(p) (eaccess((p), W_OK))
226# define PERL_EFF_ACCESS_X_OK(p) (eaccess((p), X_OK))
227# endif
5ff3f7a4
GS
228#endif
229
230#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_ACCESSX) && defined(ACC_SELF)
c955f117 231 /* AIX */
5ff3f7a4
GS
232# define PERL_EFF_ACCESS_R_OK(p) (accessx((p), R_OK, ACC_SELF))
233# define PERL_EFF_ACCESS_W_OK(p) (accessx((p), W_OK, ACC_SELF))
234# define PERL_EFF_ACCESS_X_OK(p) (accessx((p), X_OK, ACC_SELF))
235#endif
236
327c3667
GS
237#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_ACCESS) \
238 && (defined(HAS_SETREUID) || defined(HAS_SETRESUID) \
239 || defined(HAS_SETREGID) || defined(HAS_SETRESGID))
5ff3f7a4 240/* The Hard Way. */
327c3667 241STATIC int
7f4774ae 242S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
ba106d47 243{
5ff3f7a4
GS
244 Uid_t ruid = getuid();
245 Uid_t euid = geteuid();
246 Gid_t rgid = getgid();
247 Gid_t egid = getegid();
248 int res;
249
250 MUTEX_LOCK(&PL_cred_mutex);
251#if !defined(HAS_SETREUID) && !defined(HAS_SETRESUID)
cea2e8a9 252 Perl_croak(aTHX_ "switching effective uid is not implemented");
5ff3f7a4
GS
253#else
254#ifdef HAS_SETREUID
255 if (setreuid(euid, ruid))
256#else
257#ifdef HAS_SETRESUID
258 if (setresuid(euid, ruid, (Uid_t)-1))
259#endif
260#endif
cea2e8a9 261 Perl_croak(aTHX_ "entering effective uid failed");
5ff3f7a4
GS
262#endif
263
264#if !defined(HAS_SETREGID) && !defined(HAS_SETRESGID)
cea2e8a9 265 Perl_croak(aTHX_ "switching effective gid is not implemented");
5ff3f7a4
GS
266#else
267#ifdef HAS_SETREGID
268 if (setregid(egid, rgid))
269#else
270#ifdef HAS_SETRESGID
271 if (setresgid(egid, rgid, (Gid_t)-1))
272#endif
273#endif
cea2e8a9 274 Perl_croak(aTHX_ "entering effective gid failed");
5ff3f7a4
GS
275#endif
276
277 res = access(path, mode);
278
279#ifdef HAS_SETREUID
280 if (setreuid(ruid, euid))
281#else
282#ifdef HAS_SETRESUID
283 if (setresuid(ruid, euid, (Uid_t)-1))
284#endif
285#endif
cea2e8a9 286 Perl_croak(aTHX_ "leaving effective uid failed");
5ff3f7a4
GS
287
288#ifdef HAS_SETREGID
289 if (setregid(rgid, egid))
290#else
291#ifdef HAS_SETRESGID
292 if (setresgid(rgid, egid, (Gid_t)-1))
293#endif
294#endif
cea2e8a9 295 Perl_croak(aTHX_ "leaving effective gid failed");
5ff3f7a4
GS
296 MUTEX_UNLOCK(&PL_cred_mutex);
297
298 return res;
299}
300# define PERL_EFF_ACCESS_R_OK(p) (emulate_eaccess((p), R_OK))
301# define PERL_EFF_ACCESS_W_OK(p) (emulate_eaccess((p), W_OK))
302# define PERL_EFF_ACCESS_X_OK(p) (emulate_eaccess((p), X_OK))
303#endif
304
305#if !defined(PERL_EFF_ACCESS_R_OK)
327c3667 306STATIC int
7f4774ae 307S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
ba106d47 308{
cea2e8a9 309 Perl_croak(aTHX_ "switching effective uid is not implemented");
5ff3f7a4
GS
310 /*NOTREACHED*/
311 return -1;
312}
313#endif
314
a0d0e21e
LW
315PP(pp_backtick)
316{
4e35701f 317 djSP; dTARGET;
760ac839 318 PerlIO *fp;
2d8e6c8d
GS
319 STRLEN n_a;
320 char *tmps = POPpx;
54310121
PP
321 I32 gimme = GIMME_V;
322
a0d0e21e 323 TAINT_PROPER("``");
6ad3d225 324 fp = PerlProc_popen(tmps, "r");
a0d0e21e 325 if (fp) {
54310121 326 if (gimme == G_VOID) {
96827780
MB
327 char tmpbuf[256];
328 while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0)
54310121
PP
329 /*SUPPRESS 530*/
330 ;
331 }
332 else if (gimme == G_SCALAR) {
aa689395 333 sv_setpv(TARG, ""); /* note that this preserves previous buffer */
a0d0e21e
LW
334 while (sv_gets(TARG, fp, SvCUR(TARG)) != Nullch)
335 /*SUPPRESS 530*/
336 ;
337 XPUSHs(TARG);
aa689395 338 SvTAINTED_on(TARG);
a0d0e21e
LW
339 }
340 else {
341 SV *sv;
342
343 for (;;) {
8d6dde3e 344 sv = NEWSV(56, 79);
a0d0e21e
LW
345 if (sv_gets(sv, fp, 0) == Nullch) {
346 SvREFCNT_dec(sv);
347 break;
348 }
349 XPUSHs(sv_2mortal(sv));
350 if (SvLEN(sv) - SvCUR(sv) > 20) {
351 SvLEN_set(sv, SvCUR(sv)+1);
352 Renew(SvPVX(sv), SvLEN(sv), char);
353 }
aa689395 354 SvTAINTED_on(sv);
a0d0e21e
LW
355 }
356 }
6ad3d225 357 STATUS_NATIVE_SET(PerlProc_pclose(fp));
aa689395 358 TAINT; /* "I believe that this is not gratuitous!" */
a0d0e21e
LW
359 }
360 else {
f86702cc 361 STATUS_NATIVE_SET(-1);
54310121 362 if (gimme == G_SCALAR)
a0d0e21e
LW
363 RETPUSHUNDEF;
364 }
365
366 RETURN;
367}
368
369PP(pp_glob)
370{
371 OP *result;
f5284f61
IZ
372 tryAMAGICunTARGET(iter, -1);
373
a0d0e21e 374 ENTER;
a0d0e21e 375
c90c0ff4 376#ifndef VMS
3280af22 377 if (PL_tainting) {
7bac28a0
PP
378 /*
379 * The external globbing program may use things we can't control,
380 * so for security reasons we must assume the worst.
381 */
382 TAINT;
22c35a8c 383 taint_proper(PL_no_security, "glob");
7bac28a0 384 }
c90c0ff4 385#endif /* !VMS */
7bac28a0 386
3280af22
NIS
387 SAVESPTR(PL_last_in_gv); /* We don't want this to be permanent. */
388 PL_last_in_gv = (GV*)*PL_stack_sp--;
a0d0e21e 389
3280af22 390 SAVESPTR(PL_rs); /* This is not permanent, either. */
79cb57f6 391 PL_rs = sv_2mortal(newSVpvn("\000", 1));
c07a80fd
PP
392#ifndef DOSISH
393#ifndef CSH
6b88bc9c 394 *SvPVX(PL_rs) = '\n';
a0d0e21e 395#endif /* !CSH */
55497cff 396#endif /* !DOSISH */
c07a80fd 397
a0d0e21e
LW
398 result = do_readline();
399 LEAVE;
400 return result;
401}
402
15e52e56 403#if 0 /* XXX never used! */
a0d0e21e
LW
404PP(pp_indread)
405{
2d8e6c8d
GS
406 STRLEN n_a;
407 PL_last_in_gv = gv_fetchpv(SvPVx(GvSV((GV*)(*PL_stack_sp--)), n_a), TRUE,SVt_PVIO);
a0d0e21e
LW
408 return do_readline();
409}
15e52e56 410#endif
a0d0e21e
LW
411
412PP(pp_rcatline)
413{
3280af22 414 PL_last_in_gv = cGVOP->op_gv;
a0d0e21e
LW
415 return do_readline();
416}
417
418PP(pp_warn)
419{
4e35701f 420 djSP; dMARK;
06bf62c7 421 SV *tmpsv;
a0d0e21e 422 char *tmps;
06bf62c7 423 STRLEN len;
a0d0e21e
LW
424 if (SP - MARK != 1) {
425 dTARGET;
3280af22 426 do_join(TARG, &PL_sv_no, MARK, SP);
06bf62c7 427 tmpsv = TARG;
a0d0e21e
LW
428 SP = MARK + 1;
429 }
430 else {
06bf62c7 431 tmpsv = TOPs;
a0d0e21e 432 }
06bf62c7
GS
433 tmps = SvPV(tmpsv, len);
434 if (!tmps || !len) {
4e6ea2c3
GS
435 SV *error = ERRSV;
436 (void)SvUPGRADE(error, SVt_PV);
437 if (SvPOK(error) && SvCUR(error))
438 sv_catpv(error, "\t...caught");
06bf62c7
GS
439 tmpsv = error;
440 tmps = SvPV(tmpsv, len);
a0d0e21e 441 }
06bf62c7
GS
442 if (!tmps || !len)
443 tmpsv = sv_2mortal(newSVpvn("Warning: something's wrong", 26));
444
cea2e8a9 445 Perl_warn(aTHX_ "%_", tmpsv);
a0d0e21e
LW
446 RETSETYES;
447}
448
449PP(pp_die)
450{
4e35701f 451 djSP; dMARK;
a0d0e21e 452 char *tmps;
06bf62c7
GS
453 SV *tmpsv;
454 STRLEN len;
455 bool multiarg = 0;
a0d0e21e
LW
456 if (SP - MARK != 1) {
457 dTARGET;
3280af22 458 do_join(TARG, &PL_sv_no, MARK, SP);
06bf62c7
GS
459 tmpsv = TARG;
460 tmps = SvPV(tmpsv, len);
461 multiarg = 1;
a0d0e21e
LW
462 SP = MARK + 1;
463 }
464 else {
4e6ea2c3 465 tmpsv = TOPs;
06bf62c7 466 tmps = SvROK(tmpsv) ? Nullch : SvPV(tmpsv, len);
a0d0e21e 467 }
06bf62c7 468 if (!tmps || !len) {
4e6ea2c3
GS
469 SV *error = ERRSV;
470 (void)SvUPGRADE(error, SVt_PV);
06bf62c7
GS
471 if (multiarg ? SvROK(error) : SvROK(tmpsv)) {
472 if (!multiarg)
4e6ea2c3 473 SvSetSV(error,tmpsv);
06bf62c7 474 else if (sv_isobject(error)) {
05423cc9
GS
475 HV *stash = SvSTASH(SvRV(error));
476 GV *gv = gv_fetchmethod(stash, "PROPAGATE");
477 if (gv) {
3280af22
NIS
478 SV *file = sv_2mortal(newSVsv(GvSV(PL_curcop->cop_filegv)));
479 SV *line = sv_2mortal(newSViv(PL_curcop->cop_line));
05423cc9
GS
480 EXTEND(SP, 3);
481 PUSHMARK(SP);
482 PUSHs(error);
483 PUSHs(file);
484 PUSHs(line);
485 PUTBACK;
864dbfa3
GS
486 call_sv((SV*)GvCV(gv),
487 G_SCALAR|G_EVAL|G_KEEPERR);
3280af22 488 sv_setsv(error,*PL_stack_sp--);
05423cc9
GS
489 }
490 }
cea2e8a9 491 DIE(aTHX_ Nullch);
4e6ea2c3
GS
492 }
493 else {
494 if (SvPOK(error) && SvCUR(error))
495 sv_catpv(error, "\t...propagated");
06bf62c7
GS
496 tmpsv = error;
497 tmps = SvPV(tmpsv, len);
4e6ea2c3 498 }
a0d0e21e 499 }
06bf62c7
GS
500 if (!tmps || !len)
501 tmpsv = sv_2mortal(newSVpvn("Died", 4));
502
cea2e8a9 503 DIE(aTHX_ "%_", tmpsv);
a0d0e21e
LW
504}
505
506/* I/O. */
507
508PP(pp_open)
509{
4e35701f 510 djSP; dTARGET;
a0d0e21e
LW
511 GV *gv;
512 SV *sv;
6170680b
IZ
513 SV *name;
514 I32 have_name = 0;
a0d0e21e
LW
515 char *tmps;
516 STRLEN len;
4592e6ca 517 MAGIC *mg;
a0d0e21e 518
6170680b
IZ
519 if (MAXARG > 2) {
520 name = POPs;
521 have_name = 1;
522 }
a0d0e21e
LW
523 if (MAXARG > 1)
524 sv = POPs;
5f05dabc 525 if (!isGV(TOPs))
cea2e8a9 526 DIE(aTHX_ PL_no_usym, "filehandle");
5f05dabc
PP
527 if (MAXARG <= 1)
528 sv = GvSV(TOPs);
a0d0e21e 529 gv = (GV*)POPs;
5f05dabc 530 if (!isGV(gv))
cea2e8a9 531 DIE(aTHX_ PL_no_usym, "filehandle");
36477c24
PP
532 if (GvIOp(gv))
533 IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
853846ea
NIS
534
535#if 0 /* no undef means tmpfile() yet */
3eb568f1
NIS
536 if (sv == &PL_sv_undef) {
537#ifdef PerlIO
538 PerlIO *fp = PerlIO_tmpfile();
539#else
540 PerlIO *fp = tmpfile();
541#endif
542 if (fp != Nullfp && do_open(gv, "+>&", 3, FALSE, 0, 0, fp))
543 PUSHi( (I32)PL_forkprocess );
544 else
545 RETPUSHUNDEF;
546 RETURN;
547 }
853846ea
NIS
548#endif /* no undef means tmpfile() yet */
549
4592e6ca
NIS
550
551 if (mg = SvTIED_mg((SV*)gv, 'q')) {
552 PUSHMARK(SP);
553 XPUSHs(SvTIED_obj((SV*)gv, mg));
554 XPUSHs(sv);
6170680b
IZ
555 if (have_name)
556 XPUSHs(name);
4592e6ca
NIS
557 PUTBACK;
558 ENTER;
864dbfa3 559 call_method("OPEN", G_SCALAR);
4592e6ca
NIS
560 LEAVE;
561 SPAGAIN;
562 RETURN;
563 }
564
a0d0e21e 565 tmps = SvPV(sv, len);
6170680b 566 if (do_open9(gv, tmps, len, FALSE, O_RDONLY, 0, Nullfp, name, have_name))
3280af22
NIS
567 PUSHi( (I32)PL_forkprocess );
568 else if (PL_forkprocess == 0) /* we are a new child */
a0d0e21e
LW
569 PUSHi(0);
570 else
571 RETPUSHUNDEF;
572 RETURN;
573}
574
575PP(pp_close)
576{
4e35701f 577 djSP;
a0d0e21e 578 GV *gv;
1d603a67 579 MAGIC *mg;
a0d0e21e
LW
580
581 if (MAXARG == 0)
3280af22 582 gv = PL_defoutgv;
a0d0e21e
LW
583 else
584 gv = (GV*)POPs;
1d603a67 585
33c27489 586 if (mg = SvTIED_mg((SV*)gv, 'q')) {
1d603a67 587 PUSHMARK(SP);
33c27489 588 XPUSHs(SvTIED_obj((SV*)gv, mg));
1d603a67
GB
589 PUTBACK;
590 ENTER;
864dbfa3 591 call_method("CLOSE", G_SCALAR);
1d603a67
GB
592 LEAVE;
593 SPAGAIN;
594 RETURN;
595 }
a0d0e21e 596 EXTEND(SP, 1);
54310121 597 PUSHs(boolSV(do_close(gv, TRUE)));
a0d0e21e
LW
598 RETURN;
599}
600
601PP(pp_pipe_op)
602{
4e35701f 603 djSP;
a0d0e21e
LW
604#ifdef HAS_PIPE
605 GV *rgv;
606 GV *wgv;
607 register IO *rstio;
608 register IO *wstio;
609 int fd[2];
610
611 wgv = (GV*)POPs;
612 rgv = (GV*)POPs;
613
614 if (!rgv || !wgv)
615 goto badexit;
616
4633a7c4 617 if (SvTYPE(rgv) != SVt_PVGV || SvTYPE(wgv) != SVt_PVGV)
cea2e8a9 618 DIE(aTHX_ PL_no_usym, "filehandle");
a0d0e21e
LW
619 rstio = GvIOn(rgv);
620 wstio = GvIOn(wgv);
621
622 if (IoIFP(rstio))
623 do_close(rgv, FALSE);
624 if (IoIFP(wstio))
625 do_close(wgv, FALSE);
626
6ad3d225 627 if (PerlProc_pipe(fd) < 0)
a0d0e21e
LW
628 goto badexit;
629
760ac839
LW
630 IoIFP(rstio) = PerlIO_fdopen(fd[0], "r");
631 IoOFP(wstio) = PerlIO_fdopen(fd[1], "w");
a0d0e21e
LW
632 IoIFP(wstio) = IoOFP(wstio);
633 IoTYPE(rstio) = '<';
634 IoTYPE(wstio) = '>';
635
636 if (!IoIFP(rstio) || !IoOFP(wstio)) {
760ac839 637 if (IoIFP(rstio)) PerlIO_close(IoIFP(rstio));
6ad3d225 638 else PerlLIO_close(fd[0]);
760ac839 639 if (IoOFP(wstio)) PerlIO_close(IoOFP(wstio));
6ad3d225 640 else PerlLIO_close(fd[1]);
a0d0e21e
LW
641 goto badexit;
642 }
4771b018
GS
643#if defined(HAS_FCNTL) && defined(F_SETFD)
644 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
645 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
646#endif
a0d0e21e
LW
647 RETPUSHYES;
648
649badexit:
650 RETPUSHUNDEF;
651#else
cea2e8a9 652 DIE(aTHX_ PL_no_func, "pipe");
a0d0e21e
LW
653#endif
654}
655
656PP(pp_fileno)
657{
4e35701f 658 djSP; dTARGET;
a0d0e21e
LW
659 GV *gv;
660 IO *io;
760ac839 661 PerlIO *fp;
4592e6ca
NIS
662 MAGIC *mg;
663
a0d0e21e
LW
664 if (MAXARG < 1)
665 RETPUSHUNDEF;
666 gv = (GV*)POPs;
4592e6ca
NIS
667
668 if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
669 PUSHMARK(SP);
670 XPUSHs(SvTIED_obj((SV*)gv, mg));
671 PUTBACK;
672 ENTER;
864dbfa3 673 call_method("FILENO", G_SCALAR);
4592e6ca
NIS
674 LEAVE;
675 SPAGAIN;
676 RETURN;
677 }
678
a0d0e21e
LW
679 if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io)))
680 RETPUSHUNDEF;
760ac839 681 PUSHi(PerlIO_fileno(fp));
a0d0e21e
LW
682 RETURN;
683}
684
685PP(pp_umask)
686{
4e35701f 687 djSP; dTARGET;
761237fe 688 Mode_t anum;
a0d0e21e
LW
689
690#ifdef HAS_UMASK
691 if (MAXARG < 1) {
6ad3d225
GS
692 anum = PerlLIO_umask(0);
693 (void)PerlLIO_umask(anum);
a0d0e21e
LW
694 }
695 else
6ad3d225 696 anum = PerlLIO_umask(POPi);
a0d0e21e
LW
697 TAINT_PROPER("umask");
698 XPUSHi(anum);
699#else
eec2d3df
GS
700 /* Only DIE if trying to restrict permissions on `user' (self).
701 * Otherwise it's harmless and more useful to just return undef
702 * since 'group' and 'other' concepts probably don't exist here. */
703 if (MAXARG >= 1 && (POPi & 0700))
cea2e8a9 704 DIE(aTHX_ "umask not implemented");
6b88bc9c 705 XPUSHs(&PL_sv_undef);
a0d0e21e
LW
706#endif
707 RETURN;
708}
709
710PP(pp_binmode)
711{
4e35701f 712 djSP;
a0d0e21e
LW
713 GV *gv;
714 IO *io;
760ac839 715 PerlIO *fp;
4592e6ca 716 MAGIC *mg;
a0d0e21e
LW
717
718 if (MAXARG < 1)
719 RETPUSHUNDEF;
720
4592e6ca
NIS
721 gv = (GV*)POPs;
722
723 if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
724 PUSHMARK(SP);
725 XPUSHs(SvTIED_obj((SV*)gv, mg));
726 PUTBACK;
727 ENTER;
864dbfa3 728 call_method("BINMODE", G_SCALAR);
4592e6ca
NIS
729 LEAVE;
730 SPAGAIN;
731 RETURN;
732 }
a0d0e21e
LW
733
734 EXTEND(SP, 1);
735 if (!(io = GvIO(gv)) || !(fp = IoIFP(io)))
55497cff 736 RETPUSHUNDEF;
a0d0e21e 737
491527d0 738 if (do_binmode(fp,IoTYPE(io),TRUE))
a0d0e21e
LW
739 RETPUSHYES;
740 else
741 RETPUSHUNDEF;
a0d0e21e
LW
742}
743
b8e3bfaf 744
a0d0e21e
LW
745PP(pp_tie)
746{
4e35701f 747 djSP;
e336de0d 748 dMARK;
a0d0e21e
LW
749 SV *varsv;
750 HV* stash;
751 GV *gv;
a0d0e21e 752 SV *sv;
3280af22 753 I32 markoff = MARK - PL_stack_base;
a0d0e21e 754 char *methname;
6b05c17a 755 int how = 'P';
e336de0d 756 U32 items;
2d8e6c8d 757 STRLEN n_a;
a0d0e21e 758
e336de0d 759 varsv = *++MARK;
6b05c17a
NIS
760 switch(SvTYPE(varsv)) {
761 case SVt_PVHV:
762 methname = "TIEHASH";
763 break;
764 case SVt_PVAV:
765 methname = "TIEARRAY";
766 break;
767 case SVt_PVGV:
768 methname = "TIEHANDLE";
769 how = 'q';
770 break;
771 default:
772 methname = "TIESCALAR";
773 how = 'q';
774 break;
775 }
e336de0d
GS
776 items = SP - MARK++;
777 if (sv_isobject(*MARK)) {
6b05c17a 778 ENTER;
e788e7d3 779 PUSHSTACKi(PERLSI_MAGIC);
e336de0d
GS
780 PUSHMARK(SP);
781 EXTEND(SP,items);
782 while (items--)
783 PUSHs(*MARK++);
784 PUTBACK;
864dbfa3 785 call_method(methname, G_SCALAR);
6b05c17a
NIS
786 }
787 else {
864dbfa3 788 /* Not clear why we don't call call_method here too.
6b05c17a
NIS
789 * perhaps to get different error message ?
790 */
e336de0d 791 stash = gv_stashsv(*MARK, FALSE);
6b05c17a 792 if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
cea2e8a9 793 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%s\"",
2d8e6c8d 794 methname, SvPV(*MARK,n_a));
6b05c17a
NIS
795 }
796 ENTER;
e788e7d3 797 PUSHSTACKi(PERLSI_MAGIC);
e336de0d
GS
798 PUSHMARK(SP);
799 EXTEND(SP,items);
800 while (items--)
801 PUSHs(*MARK++);
802 PUTBACK;
864dbfa3 803 call_sv((SV*)GvCV(gv), G_SCALAR);
6b05c17a 804 }
a0d0e21e
LW
805 SPAGAIN;
806
807 sv = TOPs;
d3acc0f7 808 POPSTACK;
a0d0e21e 809 if (sv_isobject(sv)) {
33c27489
GS
810 sv_unmagic(varsv, how);
811 sv_magic(varsv, (SvRV(sv) == varsv ? Nullsv : sv), how, Nullch, 0);
a0d0e21e
LW
812 }
813 LEAVE;
3280af22 814 SP = PL_stack_base + markoff;
a0d0e21e
LW
815 PUSHs(sv);
816 RETURN;
817}
818
819PP(pp_untie)
820{
4e35701f 821 djSP;
33c27489
GS
822 SV *sv = POPs;
823 char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) ? 'P' : 'q';
55497cff 824
599cee73 825 if (ckWARN(WARN_UNTIE)) {
cbdc8872 826 MAGIC * mg ;
33c27489 827 if (mg = SvTIED_mg(sv, how)) {
cf2093f6 828#ifdef IV_IS_QUAD
b9c39e73 829 if (mg && SvREFCNT(SvRV(mg->mg_obj)) > 1)
cf2093f6
JH
830 Perl_warner(aTHX_ WARN_UNTIE,
831 "untie attempted while %" PERL_PRIu64 " inner references still exist",
832 (UV)SvREFCNT(SvRV(mg->mg_obj)) - 1 ) ;
833#else
b9c39e73 834 if (mg && SvREFCNT(SvRV(mg->mg_obj)) > 1)
cea2e8a9 835 Perl_warner(aTHX_ WARN_UNTIE,
599cee73
PM
836 "untie attempted while %lu inner references still exist",
837 (unsigned long)SvREFCNT(SvRV(mg->mg_obj)) - 1 ) ;
cf2093f6 838#endif
cbdc8872
PP
839 }
840 }
841
33c27489 842 sv_unmagic(sv, how);
55497cff 843 RETPUSHYES;
a0d0e21e
LW
844}
845
c07a80fd
PP
846PP(pp_tied)
847{
4e35701f 848 djSP;
33c27489
GS
849 SV *sv = POPs;
850 char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) ? 'P' : 'q';
851 MAGIC *mg;
c07a80fd 852
33c27489
GS
853 if (mg = SvTIED_mg(sv, how)) {
854 SV *osv = SvTIED_obj(sv, mg);
855 if (osv == mg->mg_obj)
856 osv = sv_mortalcopy(osv);
857 PUSHs(osv);
858 RETURN;
c07a80fd 859 }
c07a80fd
PP
860 RETPUSHUNDEF;
861}
862
a0d0e21e
LW
863PP(pp_dbmopen)
864{
4e35701f 865 djSP;
a0d0e21e
LW
866 HV *hv;
867 dPOPPOPssrl;
868 HV* stash;
869 GV *gv;
a0d0e21e
LW
870 SV *sv;
871
872 hv = (HV*)POPs;
873
3280af22 874 sv = sv_mortalcopy(&PL_sv_no);
a0d0e21e
LW
875 sv_setpv(sv, "AnyDBM_File");
876 stash = gv_stashsv(sv, FALSE);
8ebc5c01 877 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
a0d0e21e 878 PUTBACK;
864dbfa3 879 require_pv("AnyDBM_File.pm");
a0d0e21e 880 SPAGAIN;
8ebc5c01 881 if (!(gv = gv_fetchmethod(stash, "TIEHASH")))
cea2e8a9 882 DIE(aTHX_ "No dbm on this machine");
a0d0e21e
LW
883 }
884
57d3b86d 885 ENTER;
924508f0 886 PUSHMARK(SP);
6b05c17a 887
924508f0 888 EXTEND(SP, 5);
a0d0e21e
LW
889 PUSHs(sv);
890 PUSHs(left);
891 if (SvIV(right))
892 PUSHs(sv_2mortal(newSViv(O_RDWR|O_CREAT)));
893 else
894 PUSHs(sv_2mortal(newSViv(O_RDWR)));
895 PUSHs(right);
57d3b86d 896 PUTBACK;
864dbfa3 897 call_sv((SV*)GvCV(gv), G_SCALAR);
a0d0e21e
LW
898 SPAGAIN;
899
900 if (!sv_isobject(TOPs)) {
924508f0
GS
901 SP--;
902 PUSHMARK(SP);
a0d0e21e
LW
903 PUSHs(sv);
904 PUSHs(left);
905 PUSHs(sv_2mortal(newSViv(O_RDONLY)));
906 PUSHs(right);
a0d0e21e 907 PUTBACK;
864dbfa3 908 call_sv((SV*)GvCV(gv), G_SCALAR);
a0d0e21e
LW
909 SPAGAIN;
910 }
911
6b05c17a
NIS
912 if (sv_isobject(TOPs)) {
913 sv_unmagic((SV *) hv, 'P');
a0d0e21e 914 sv_magic((SV*)hv, TOPs, 'P', Nullch, 0);
6b05c17a 915 }
a0d0e21e
LW
916 LEAVE;
917 RETURN;
918}
919
920PP(pp_dbmclose)
921{
cea2e8a9 922 return pp_untie();
a0d0e21e
LW
923}
924
925PP(pp_sselect)
926{
4e35701f 927 djSP; dTARGET;
a0d0e21e
LW
928#ifdef HAS_SELECT
929 register I32 i;
930 register I32 j;
931 register char *s;
932 register SV *sv;
65202027 933 NV value;
a0d0e21e
LW
934 I32 maxlen = 0;
935 I32 nfound;
936 struct timeval timebuf;
937 struct timeval *tbuf = &timebuf;
938 I32 growsize;
939 char *fd_sets[4];
2d8e6c8d 940 STRLEN n_a;
a0d0e21e
LW
941#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
942 I32 masksize;
943 I32 offset;
944 I32 k;
945
946# if BYTEORDER & 0xf0000
947# define ORDERBYTE (0x88888888 - BYTEORDER)
948# else
949# define ORDERBYTE (0x4444 - BYTEORDER)
950# endif
951
952#endif
953
954 SP -= 4;
955 for (i = 1; i <= 3; i++) {
956 if (!SvPOK(SP[i]))
957 continue;
958 j = SvCUR(SP[i]);
959 if (maxlen < j)
960 maxlen = j;
961 }
962
5ff3f7a4 963/* little endians can use vecs directly */
a0d0e21e 964#if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
5ff3f7a4 965# if SELECT_MIN_BITS > 1
f2da832e
JH
966 /* If SELECT_MIN_BITS is greater than one we most probably will want
967 * to align the sizes with SELECT_MIN_BITS/8 because for example
968 * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
8f1f23e8
W
969 * UNIX, Solaris, NeXT, Rhapsody) the smallest quantum select() operates
970 * on (sets/tests/clears bits) is 32 bits. */
f2da832e 971 growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
5ff3f7a4 972# else
4633a7c4 973 growsize = sizeof(fd_set);
5ff3f7a4
GS
974# endif
975# else
976# ifdef NFDBITS
a0d0e21e 977
5ff3f7a4
GS
978# ifndef NBBY
979# define NBBY 8
980# endif
a0d0e21e
LW
981
982 masksize = NFDBITS / NBBY;
5ff3f7a4 983# else
a0d0e21e 984 masksize = sizeof(long); /* documented int, everyone seems to use long */
5ff3f7a4 985# endif
a0d0e21e
LW
986 growsize = maxlen + (masksize - (maxlen % masksize));
987 Zero(&fd_sets[0], 4, char*);
988#endif
989
990 sv = SP[4];
991 if (SvOK(sv)) {
992 value = SvNV(sv);
993 if (value < 0.0)
994 value = 0.0;
995 timebuf.tv_sec = (long)value;
65202027 996 value -= (NV)timebuf.tv_sec;
a0d0e21e
LW
997 timebuf.tv_usec = (long)(value * 1000000.0);
998 }
999 else
1000 tbuf = Null(struct timeval*);
1001
1002 for (i = 1; i <= 3; i++) {
1003 sv = SP[i];
1004 if (!SvOK(sv)) {
1005 fd_sets[i] = 0;
1006 continue;
1007 }
1008 else if (!SvPOK(sv))
2d8e6c8d 1009 SvPV_force(sv,n_a); /* force string conversion */
a0d0e21e
LW
1010 j = SvLEN(sv);
1011 if (j < growsize) {
1012 Sv_Grow(sv, growsize);
a0d0e21e 1013 }
c07a80fd
PP
1014 j = SvCUR(sv);
1015 s = SvPVX(sv) + j;
1016 while (++j <= growsize) {
1017 *s++ = '\0';
1018 }
1019
a0d0e21e
LW
1020#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1021 s = SvPVX(sv);
1022 New(403, fd_sets[i], growsize, char);
1023 for (offset = 0; offset < growsize; offset += masksize) {
1024 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1025 fd_sets[i][j+offset] = s[(k % masksize) + offset];
1026 }
1027#else
1028 fd_sets[i] = SvPVX(sv);
1029#endif
1030 }
1031
6ad3d225 1032 nfound = PerlSock_select(
a0d0e21e
LW
1033 maxlen * 8,
1034 (Select_fd_set_t) fd_sets[1],
1035 (Select_fd_set_t) fd_sets[2],
1036 (Select_fd_set_t) fd_sets[3],
1037 tbuf);
1038 for (i = 1; i <= 3; i++) {
1039 if (fd_sets[i]) {
1040 sv = SP[i];
1041#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1042 s = SvPVX(sv);
1043 for (offset = 0; offset < growsize; offset += masksize) {
1044 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1045 s[(k % masksize) + offset] = fd_sets[i][j+offset];
1046 }
1047 Safefree(fd_sets[i]);
1048#endif
1049 SvSETMAGIC(sv);
1050 }
1051 }
1052
1053 PUSHi(nfound);
1054 if (GIMME == G_ARRAY && tbuf) {
65202027
DS
1055 value = (NV)(timebuf.tv_sec) +
1056 (NV)(timebuf.tv_usec) / 1000000.0;
3280af22 1057 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW
1058 sv_setnv(sv, value);
1059 }
1060 RETURN;
1061#else
cea2e8a9 1062 DIE(aTHX_ "select not implemented");
a0d0e21e
LW
1063#endif
1064}
1065
4633a7c4 1066void
864dbfa3 1067Perl_setdefout(pTHX_ GV *gv)
4633a7c4 1068{
11343788 1069 dTHR;
4633a7c4
LW
1070 if (gv)
1071 (void)SvREFCNT_inc(gv);
3280af22
NIS
1072 if (PL_defoutgv)
1073 SvREFCNT_dec(PL_defoutgv);
1074 PL_defoutgv = gv;
4633a7c4
LW
1075}
1076
a0d0e21e
LW
1077PP(pp_select)
1078{
4e35701f 1079 djSP; dTARGET;
4633a7c4
LW
1080 GV *newdefout, *egv;
1081 HV *hv;
1082
533c011a 1083 newdefout = (PL_op->op_private > 0) ? ((GV *) POPs) : (GV *) NULL;
4633a7c4 1084
3280af22 1085 egv = GvEGV(PL_defoutgv);
4633a7c4 1086 if (!egv)
3280af22 1087 egv = PL_defoutgv;
4633a7c4
LW
1088 hv = GvSTASH(egv);
1089 if (! hv)
3280af22 1090 XPUSHs(&PL_sv_undef);
4633a7c4 1091 else {
cbdc8872 1092 GV **gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
f86702cc 1093 if (gvp && *gvp == egv) {
3280af22 1094 gv_efullname3(TARG, PL_defoutgv, Nullch);
f86702cc
PP
1095 XPUSHTARG;
1096 }
1097 else {
1098 XPUSHs(sv_2mortal(newRV((SV*)egv)));
1099 }
4633a7c4
LW
1100 }
1101
1102 if (newdefout) {
ded8aa31
GS
1103 if (!GvIO(newdefout))
1104 gv_IOadd(newdefout);
4633a7c4
LW
1105 setdefout(newdefout);
1106 }
1107
a0d0e21e
LW
1108 RETURN;
1109}
1110
1111PP(pp_getc)
1112{
4e35701f 1113 djSP; dTARGET;
a0d0e21e 1114 GV *gv;
2ae324a7 1115 MAGIC *mg;
a0d0e21e
LW
1116
1117 if (MAXARG <= 0)
3280af22 1118 gv = PL_stdingv;
a0d0e21e
LW
1119 else
1120 gv = (GV*)POPs;
1121 if (!gv)
3280af22 1122 gv = PL_argvgv;
2ae324a7 1123
33c27489 1124 if (mg = SvTIED_mg((SV*)gv, 'q')) {
54310121 1125 I32 gimme = GIMME_V;
2ae324a7 1126 PUSHMARK(SP);
33c27489 1127 XPUSHs(SvTIED_obj((SV*)gv, mg));
2ae324a7
PP
1128 PUTBACK;
1129 ENTER;
864dbfa3 1130 call_method("GETC", gimme);
2ae324a7
PP
1131 LEAVE;
1132 SPAGAIN;
54310121
PP
1133 if (gimme == G_SCALAR)
1134 SvSetMagicSV_nosteal(TARG, TOPs);
2ae324a7
PP
1135 RETURN;
1136 }
9bc64814 1137 if (!gv || do_eof(gv)) /* make sure we have fp with something */
a0d0e21e 1138 RETPUSHUNDEF;
bbce6d69 1139 TAINT;
a0d0e21e 1140 sv_setpv(TARG, " ");
9bc64814 1141 *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
a0d0e21e
LW
1142 PUSHTARG;
1143 RETURN;
1144}
1145
1146PP(pp_read)
1147{
cea2e8a9 1148 return pp_sysread();
a0d0e21e
LW
1149}
1150
76e3520e 1151STATIC OP *
cea2e8a9 1152S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
a0d0e21e 1153{
11343788 1154 dTHR;
c09156bb 1155 register PERL_CONTEXT *cx;
54310121 1156 I32 gimme = GIMME_V;
a0d0e21e
LW
1157 AV* padlist = CvPADLIST(cv);
1158 SV** svp = AvARRAY(padlist);
1159
1160 ENTER;
1161 SAVETMPS;
1162
1163 push_return(retop);
3280af22 1164 PUSHBLOCK(cx, CXt_SUB, PL_stack_sp);
a0d0e21e 1165 PUSHFORMAT(cx);
3280af22
NIS
1166 SAVESPTR(PL_curpad);
1167 PL_curpad = AvARRAY((AV*)svp[1]);
a0d0e21e 1168
4633a7c4 1169 setdefout(gv); /* locally select filehandle so $% et al work */
a0d0e21e
LW
1170 return CvSTART(cv);
1171}
1172
1173PP(pp_enterwrite)
1174{
4e35701f 1175 djSP;
a0d0e21e
LW
1176 register GV *gv;
1177 register IO *io;
1178 GV *fgv;
1179 CV *cv;
1180
1181 if (MAXARG == 0)
3280af22 1182 gv = PL_defoutgv;
a0d0e21e
LW
1183 else {
1184 gv = (GV*)POPs;
1185 if (!gv)
3280af22 1186 gv = PL_defoutgv;
a0d0e21e
LW
1187 }
1188 EXTEND(SP, 1);
1189 io = GvIO(gv);
1190 if (!io) {
1191 RETPUSHNO;
1192 }
1193 if (IoFMT_GV(io))
1194 fgv = IoFMT_GV(io);
1195 else
1196 fgv = gv;
1197
1198 cv = GvFORM(fgv);
a0d0e21e
LW
1199 if (!cv) {
1200 if (fgv) {
748a9306 1201 SV *tmpsv = sv_newmortal();
aac0dd9a 1202 gv_efullname3(tmpsv, fgv, Nullch);
cea2e8a9 1203 DIE(aTHX_ "Undefined format \"%s\" called",SvPVX(tmpsv));
a0d0e21e 1204 }
cea2e8a9 1205 DIE(aTHX_ "Not a format reference");
a0d0e21e 1206 }
44a8e56a
PP
1207 if (CvCLONE(cv))
1208 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
a0d0e21e 1209
44a8e56a 1210 IoFLAGS(io) &= ~IOf_DIDTOP;
533c011a 1211 return doform(cv,gv,PL_op->op_next);
a0d0e21e
LW
1212}
1213
1214PP(pp_leavewrite)
1215{
4e35701f 1216 djSP;
a0d0e21e
LW
1217 GV *gv = cxstack[cxstack_ix].blk_sub.gv;
1218 register IO *io = GvIOp(gv);
760ac839
LW
1219 PerlIO *ofp = IoOFP(io);
1220 PerlIO *fp;
a0d0e21e
LW
1221 SV **newsp;
1222 I32 gimme;
c09156bb 1223 register PERL_CONTEXT *cx;
a0d0e21e 1224
760ac839 1225 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
3280af22
NIS
1226 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1227 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1228 PL_formtarget != PL_toptarget)
a0d0e21e 1229 {
4633a7c4
LW
1230 GV *fgv;
1231 CV *cv;
a0d0e21e
LW
1232 if (!IoTOP_GV(io)) {
1233 GV *topgv;
46fc3d4c 1234 SV *topname;
a0d0e21e
LW
1235
1236 if (!IoTOP_NAME(io)) {
1237 if (!IoFMT_NAME(io))
1238 IoFMT_NAME(io) = savepv(GvNAME(gv));
cea2e8a9 1239 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%s_TOP", IoFMT_NAME(io)));
46fc3d4c 1240 topgv = gv_fetchpv(SvPVX(topname), FALSE, SVt_PVFM);
748a9306 1241 if ((topgv && GvFORM(topgv)) ||
a0d0e21e 1242 !gv_fetchpv("top",FALSE,SVt_PVFM))
46fc3d4c 1243 IoTOP_NAME(io) = savepv(SvPVX(topname));
a0d0e21e
LW
1244 else
1245 IoTOP_NAME(io) = savepv("top");
1246 }
1247 topgv = gv_fetchpv(IoTOP_NAME(io),FALSE, SVt_PVFM);
1248 if (!topgv || !GvFORM(topgv)) {
1249 IoLINES_LEFT(io) = 100000000;
1250 goto forget_top;
1251 }
1252 IoTOP_GV(io) = topgv;
1253 }
748a9306
LW
1254 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1255 I32 lines = IoLINES_LEFT(io);
3280af22 1256 char *s = SvPVX(PL_formtarget);
8e07c86e
AD
1257 if (lines <= 0) /* Yow, header didn't even fit!!! */
1258 goto forget_top;
748a9306
LW
1259 while (lines-- > 0) {
1260 s = strchr(s, '\n');
1261 if (!s)
1262 break;
1263 s++;
1264 }
1265 if (s) {
3280af22
NIS
1266 PerlIO_write(ofp, SvPVX(PL_formtarget), s - SvPVX(PL_formtarget));
1267 sv_chop(PL_formtarget, s);
1268 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
748a9306
LW
1269 }
1270 }
a0d0e21e 1271 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
3280af22 1272 PerlIO_write(ofp, SvPVX(PL_formfeed), SvCUR(PL_formfeed));
a0d0e21e
LW
1273 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1274 IoPAGE(io)++;
3280af22 1275 PL_formtarget = PL_toptarget;
748a9306 1276 IoFLAGS(io) |= IOf_DIDTOP;
4633a7c4
LW
1277 fgv = IoTOP_GV(io);
1278 if (!fgv)
cea2e8a9 1279 DIE(aTHX_ "bad top format reference");
4633a7c4
LW
1280 cv = GvFORM(fgv);
1281 if (!cv) {
1282 SV *tmpsv = sv_newmortal();
aac0dd9a 1283 gv_efullname3(tmpsv, fgv, Nullch);
cea2e8a9 1284 DIE(aTHX_ "Undefined top format \"%s\" called",SvPVX(tmpsv));
4633a7c4 1285 }
44a8e56a
PP
1286 if (CvCLONE(cv))
1287 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
533c011a 1288 return doform(cv,gv,PL_op);
a0d0e21e
LW
1289 }
1290
1291 forget_top:
3280af22 1292 POPBLOCK(cx,PL_curpm);
a0d0e21e
LW
1293 POPFORMAT(cx);
1294 LEAVE;
1295
1296 fp = IoOFP(io);
1297 if (!fp) {
599cee73 1298 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
af8c498a
GS
1299 SV* sv = sv_newmortal();
1300 gv_efullname3(sv, gv, Nullch);
a0d0e21e 1301 if (IoIFP(io))
af8c498a
GS
1302 Perl_warner(aTHX_ WARN_IO,
1303 "Filehandle %s opened only for input",
1304 SvPV_nolen(sv));
599cee73 1305 else if (ckWARN(WARN_CLOSED))
af8c498a
GS
1306 Perl_warner(aTHX_ WARN_CLOSED,
1307 "Write on closed filehandle %s", SvPV_nolen(sv));
a0d0e21e 1308 }
3280af22 1309 PUSHs(&PL_sv_no);
a0d0e21e
LW
1310 }
1311 else {
3280af22 1312 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
599cee73 1313 if (ckWARN(WARN_IO))
cea2e8a9 1314 Perl_warner(aTHX_ WARN_IO, "page overflow");
a0d0e21e 1315 }
3280af22 1316 if (!PerlIO_write(ofp, SvPVX(PL_formtarget), SvCUR(PL_formtarget)) ||
760ac839 1317 PerlIO_error(fp))
3280af22 1318 PUSHs(&PL_sv_no);
a0d0e21e 1319 else {
3280af22
NIS
1320 FmLINES(PL_formtarget) = 0;
1321 SvCUR_set(PL_formtarget, 0);
1322 *SvEND(PL_formtarget) = '\0';
a0d0e21e 1323 if (IoFLAGS(io) & IOf_FLUSH)
760ac839 1324 (void)PerlIO_flush(fp);
3280af22 1325 PUSHs(&PL_sv_yes);
a0d0e21e
LW
1326 }
1327 }
3280af22 1328 PL_formtarget = PL_bodytarget;
a0d0e21e
LW
1329 PUTBACK;
1330 return pop_return();
1331}
1332
1333PP(pp_prtf)
1334{
4e35701f 1335 djSP; dMARK; dORIGMARK;
a0d0e21e
LW
1336 GV *gv;
1337 IO *io;
760ac839 1338 PerlIO *fp;
26db47c4 1339 SV *sv;
46fc3d4c 1340 MAGIC *mg;
2d8e6c8d 1341 STRLEN n_a;
a0d0e21e 1342
533c011a 1343 if (PL_op->op_flags & OPf_STACKED)
a0d0e21e
LW
1344 gv = (GV*)*++MARK;
1345 else
3280af22 1346 gv = PL_defoutgv;
46fc3d4c 1347
33c27489 1348 if (mg = SvTIED_mg((SV*)gv, 'q')) {
46fc3d4c 1349 if (MARK == ORIGMARK) {
4352c267 1350 MEXTEND(SP, 1);
46fc3d4c
PP
1351 ++MARK;
1352 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1353 ++SP;
1354 }
1355 PUSHMARK(MARK - 1);
33c27489 1356 *MARK = SvTIED_obj((SV*)gv, mg);
46fc3d4c
PP
1357 PUTBACK;
1358 ENTER;
864dbfa3 1359 call_method("PRINTF", G_SCALAR);
46fc3d4c
PP
1360 LEAVE;
1361 SPAGAIN;
1362 MARK = ORIGMARK + 1;
1363 *MARK = *SP;
1364 SP = MARK;
1365 RETURN;
1366 }
1367
26db47c4 1368 sv = NEWSV(0,0);
a0d0e21e 1369 if (!(io = GvIO(gv))) {
599cee73 1370 if (ckWARN(WARN_UNOPENED)) {
af8c498a
GS
1371 gv_efullname3(sv, gv, Nullch);
1372 Perl_warner(aTHX_ WARN_UNOPENED,
1373 "Filehandle %s never opened", SvPV(sv,n_a));
748a9306
LW
1374 }
1375 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW
1376 goto just_say_no;
1377 }
1378 else if (!(fp = IoOFP(io))) {
599cee73 1379 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
af8c498a 1380 gv_efullname3(sv, gv, Nullch);
a0d0e21e 1381 if (IoIFP(io))
af8c498a
GS
1382 Perl_warner(aTHX_ WARN_IO,
1383 "Filehandle %s opened only for input",
1384 SvPV(sv,n_a));
599cee73 1385 else if (ckWARN(WARN_CLOSED))
af8c498a
GS
1386 Perl_warner(aTHX_ WARN_CLOSED,
1387 "printf on closed filehandle %s", SvPV(sv,n_a));
a0d0e21e 1388 }
748a9306 1389 SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
a0d0e21e
LW
1390 goto just_say_no;
1391 }
1392 else {
1393 do_sprintf(sv, SP - MARK, MARK + 1);
1394 if (!do_print(sv, fp))
1395 goto just_say_no;
1396
1397 if (IoFLAGS(io) & IOf_FLUSH)
760ac839 1398 if (PerlIO_flush(fp) == EOF)
a0d0e21e
LW
1399 goto just_say_no;
1400 }
1401 SvREFCNT_dec(sv);
1402 SP = ORIGMARK;
3280af22 1403 PUSHs(&PL_sv_yes);
a0d0e21e
LW
1404 RETURN;
1405
1406 just_say_no:
1407 SvREFCNT_dec(sv);
1408 SP = ORIGMARK;
3280af22 1409 PUSHs(&PL_sv_undef);
a0d0e21e
LW
1410 RETURN;
1411}
1412
c07a80fd
PP
1413PP(pp_sysopen)
1414{
4e35701f 1415 djSP;
c07a80fd 1416 GV *gv;
c07a80fd
PP
1417 SV *sv;
1418 char *tmps;
1419 STRLEN len;
1420 int mode, perm;
1421
1422 if (MAXARG > 3)
1423 perm = POPi;
1424 else
1425 perm = 0666;
1426 mode = POPi;
1427 sv = POPs;
1428 gv = (GV *)POPs;
1429
4592e6ca
NIS
1430 /* Need TIEHANDLE method ? */
1431
c07a80fd
PP
1432 tmps = SvPV(sv, len);
1433 if (do_open(gv, tmps, len, TRUE, mode, perm, Nullfp)) {
1434 IoLINES(GvIOp(gv)) = 0;
3280af22 1435 PUSHs(&PL_sv_yes);
c07a80fd
PP
1436 }
1437 else {
3280af22 1438 PUSHs(&PL_sv_undef);
c07a80fd
PP
1439 }
1440 RETURN;
1441}
1442
a0d0e21e
LW
1443PP(pp_sysread)
1444{
4e35701f 1445 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW
1446 int offset;
1447 GV *gv;
1448 IO *io;
1449 char *buffer;
5b54f415 1450 SSize_t length;
1e422769 1451 Sock_size_t bufsize;
748a9306 1452 SV *bufsv;
a0d0e21e 1453 STRLEN blen;
2ae324a7 1454 MAGIC *mg;
a0d0e21e
LW
1455
1456 gv = (GV*)*++MARK;
533c011a 1457 if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD) &&
33c27489 1458 (mg = SvTIED_mg((SV*)gv, 'q')))
137443ea 1459 {
2ae324a7
PP
1460 SV *sv;
1461
1462 PUSHMARK(MARK-1);
33c27489 1463 *MARK = SvTIED_obj((SV*)gv, mg);
2ae324a7 1464 ENTER;
864dbfa3 1465 call_method("READ", G_SCALAR);
2ae324a7
PP
1466 LEAVE;
1467 SPAGAIN;
1468 sv = POPs;
1469 SP = ORIGMARK;
1470 PUSHs(sv);
1471 RETURN;
1472 }
1473
a0d0e21e
LW
1474 if (!gv)
1475 goto say_undef;
748a9306 1476 bufsv = *++MARK;
ff68c719
PP
1477 if (! SvOK(bufsv))
1478 sv_setpvn(bufsv, "", 0);
748a9306 1479 buffer = SvPV_force(bufsv, blen);
a0d0e21e
LW
1480 length = SvIVx(*++MARK);
1481 if (length < 0)
cea2e8a9 1482 DIE(aTHX_ "Negative length");
748a9306 1483 SETERRNO(0,0);
a0d0e21e
LW
1484 if (MARK < SP)
1485 offset = SvIVx(*++MARK);
1486 else
1487 offset = 0;
1488 io = GvIO(gv);
1489 if (!io || !IoIFP(io))
1490 goto say_undef;
1491#ifdef HAS_SOCKET
533c011a 1492 if (PL_op->op_type == OP_RECV) {
46fc3d4c 1493 char namebuf[MAXPATHLEN];
eec2d3df 1494#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE)
490ab354
JH
1495 bufsize = sizeof (struct sockaddr_in);
1496#else
46fc3d4c 1497 bufsize = sizeof namebuf;
490ab354 1498#endif
abf95952
IZ
1499#ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1500 if (bufsize >= 256)
1501 bufsize = 255;
1502#endif
626727d5
GS
1503#ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1504 if (bufsize >= 256)
1505 bufsize = 255;
1506#endif
748a9306 1507 buffer = SvGROW(bufsv, length+1);
bbce6d69 1508 /* 'offset' means 'flags' here */
6ad3d225 1509 length = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
46fc3d4c 1510 (struct sockaddr *)namebuf, &bufsize);
a0d0e21e
LW
1511 if (length < 0)
1512 RETPUSHUNDEF;
748a9306
LW
1513 SvCUR_set(bufsv, length);
1514 *SvEND(bufsv) = '\0';
1515 (void)SvPOK_only(bufsv);
1516 SvSETMAGIC(bufsv);
aac0dd9a 1517 /* This should not be marked tainted if the fp is marked clean */
bbce6d69
PP
1518 if (!(IoFLAGS(io) & IOf_UNTAINT))
1519 SvTAINTED_on(bufsv);
a0d0e21e 1520 SP = ORIGMARK;
46fc3d4c 1521 sv_setpvn(TARG, namebuf, bufsize);
a0d0e21e
LW
1522 PUSHs(TARG);
1523 RETURN;
1524 }
1525#else
911d147d 1526 if (PL_op->op_type == OP_RECV)
cea2e8a9 1527 DIE(aTHX_ PL_no_sock_func, "recv");
a0d0e21e 1528#endif
bbce6d69
PP
1529 if (offset < 0) {
1530 if (-offset > blen)
cea2e8a9 1531 DIE(aTHX_ "Offset outside string");
bbce6d69
PP
1532 offset += blen;
1533 }
cd52b7b2 1534 bufsize = SvCUR(bufsv);
748a9306 1535 buffer = SvGROW(bufsv, length+offset+1);
cd52b7b2
PP
1536 if (offset > bufsize) { /* Zero any newly allocated space */
1537 Zero(buffer+bufsize, offset-bufsize, char);
1538 }
533c011a 1539 if (PL_op->op_type == OP_SYSREAD) {
a7092146
GS
1540#ifdef PERL_SOCK_SYSREAD_IS_RECV
1541 if (IoTYPE(io) == 's') {
1542 length = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
1543 buffer+offset, length, 0);
1544 }
1545 else
1546#endif
1547 {
1548 length = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
1549 buffer+offset, length);
1550 }
a0d0e21e
LW
1551 }
1552 else
1553#ifdef HAS_SOCKET__bad_code_maybe
1554 if (IoTYPE(io) == 's') {
46fc3d4c 1555 char namebuf[MAXPATHLEN];
490ab354
JH
1556#if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
1557 bufsize = sizeof (struct sockaddr_in);
1558#else
46fc3d4c 1559 bufsize = sizeof namebuf;
490ab354 1560#endif
6ad3d225 1561 length = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer+offset, length, 0,
46fc3d4c 1562 (struct sockaddr *)namebuf, &bufsize);
a0d0e21e
LW
1563 }
1564 else
1565#endif
3b02c43c 1566 {
760ac839 1567 length = PerlIO_read(IoIFP(io), buffer+offset, length);
3b02c43c 1568 /* fread() returns 0 on both error and EOF */
5c7a8c78 1569 if (length == 0 && PerlIO_error(IoIFP(io)))
3b02c43c
GS
1570 length = -1;
1571 }
af8c498a 1572 if (length < 0) {
c529f79d
CB
1573 if ((IoTYPE(io) == '>' || IoIFP(io) == PerlIO_stdout()
1574 || IoIFP(io) == PerlIO_stderr()) && ckWARN(WARN_IO))
af8c498a
GS
1575 {
1576 SV* sv = sv_newmortal();
1577 gv_efullname3(sv, gv, Nullch);
1578 Perl_warner(aTHX_ WARN_IO, "Filehandle %s opened only for output",
1579 SvPV_nolen(sv));
1580 }
a0d0e21e 1581 goto say_undef;
af8c498a 1582 }
748a9306
LW
1583 SvCUR_set(bufsv, length+offset);
1584 *SvEND(bufsv) = '\0';
1585 (void)SvPOK_only(bufsv);
1586 SvSETMAGIC(bufsv);
aac0dd9a 1587 /* This should not be marked tainted if the fp is marked clean */
bbce6d69
PP
1588 if (!(IoFLAGS(io) & IOf_UNTAINT))
1589 SvTAINTED_on(bufsv);
a0d0e21e
LW
1590 SP = ORIGMARK;
1591 PUSHi(length);
1592 RETURN;
1593
1594 say_undef:
1595 SP = ORIGMARK;
1596 RETPUSHUNDEF;
1597}
1598
1599PP(pp_syswrite)
1600{
092bebab
JH
1601 djSP;
1602 int items = (SP - PL_stack_base) - TOPMARK;
1603 if (items == 2) {
9f089d78 1604 SV *sv;
092bebab 1605 EXTEND(SP, 1);
9f089d78
SB
1606 sv = sv_2mortal(newSViv(sv_len(*SP)));
1607 PUSHs(sv);
092bebab
JH
1608 PUTBACK;
1609 }
cea2e8a9 1610 return pp_send();
a0d0e21e
LW
1611}
1612
1613PP(pp_send)
1614{
4e35701f 1615 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW
1616 GV *gv;
1617 IO *io;
1618 int offset;
748a9306 1619 SV *bufsv;
a0d0e21e
LW
1620 char *buffer;
1621 int length;
1622 STRLEN blen;
1d603a67 1623 MAGIC *mg;
a0d0e21e
LW
1624
1625 gv = (GV*)*++MARK;
33c27489 1626 if (PL_op->op_type == OP_SYSWRITE && (mg = SvTIED_mg((SV*)gv, 'q'))) {
1d603a67
GB
1627 SV *sv;
1628
1629 PUSHMARK(MARK-1);
33c27489 1630 *MARK = SvTIED_obj((SV*)gv, mg);
1d603a67 1631 ENTER;
864dbfa3 1632 call_method("WRITE", G_SCALAR);
1d603a67
GB
1633 LEAVE;
1634 SPAGAIN;
1635 sv = POPs;
1636 SP = ORIGMARK;
1637 PUSHs(sv);
1638 RETURN;
1639 }
a0d0e21e
LW
1640 if (!gv)
1641 goto say_undef;
748a9306
LW
1642 bufsv = *++MARK;
1643 buffer = SvPV(bufsv, blen);
a0d0e21e
LW
1644 length = SvIVx(*++MARK);
1645 if (length < 0)
cea2e8a9 1646 DIE(aTHX_ "Negative length");
748a9306 1647 SETERRNO(0,0);
a0d0e21e
LW
1648 io = GvIO(gv);
1649 if (!io || !IoIFP(io)) {
1650 length = -1;
599cee73 1651 if (ckWARN(WARN_CLOSED)) {
533c011a 1652 if (PL_op->op_type == OP_SYSWRITE)
cea2e8a9 1653 Perl_warner(aTHX_ WARN_CLOSED, "Syswrite on closed filehandle");
a0d0e21e 1654 else
cea2e8a9 1655 Perl_warner(aTHX_ WARN_CLOSED, "Send on closed socket");
a0d0e21e
LW
1656 }
1657 }
533c011a 1658 else if (PL_op->op_type == OP_SYSWRITE) {
bbce6d69 1659 if (MARK < SP) {
a0d0e21e 1660 offset = SvIVx(*++MARK);
bbce6d69
PP
1661 if (offset < 0) {
1662 if (-offset > blen)
cea2e8a9 1663 DIE(aTHX_ "Offset outside string");
bbce6d69 1664 offset += blen;
fb73857a 1665 } else if (offset >= blen && blen > 0)
cea2e8a9 1666 DIE(aTHX_ "Offset outside string");
bbce6d69 1667 } else
a0d0e21e
LW
1668 offset = 0;
1669 if (length > blen - offset)
1670 length = blen - offset;
a7092146
GS
1671#ifdef PERL_SOCK_SYSWRITE_IS_SEND
1672 if (IoTYPE(io) == 's') {
1673 length = PerlSock_send(PerlIO_fileno(IoIFP(io)),
1674 buffer+offset, length, 0);
1675 }
1676 else
1677#endif
1678 {
94e4c244 1679 /* See the note at doio.c:do_print about filesize limits. --jhi */
a7092146
GS
1680 length = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
1681 buffer+offset, length);
1682 }
a0d0e21e
LW
1683 }
1684#ifdef HAS_SOCKET
1685 else if (SP > MARK) {
1686 char *sockbuf;
1687 STRLEN mlen;
1688 sockbuf = SvPVx(*++MARK, mlen);
6ad3d225 1689 length = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen, length,
a0d0e21e
LW
1690 (struct sockaddr *)sockbuf, mlen);
1691 }
1692 else
6ad3d225 1693 length = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, length);
490ab354 1694
a0d0e21e
LW
1695#else
1696 else
cea2e8a9 1697 DIE(aTHX_ PL_no_sock_func, "send");
a0d0e21e
LW
1698#endif
1699 if (length < 0)
1700 goto say_undef;
1701 SP = ORIGMARK;
1702 PUSHi(length);
1703 RETURN;
1704
1705 say_undef:
1706 SP = ORIGMARK;
1707 RETPUSHUNDEF;
1708}
1709
1710PP(pp_recv)
1711{
cea2e8a9 1712 return pp_sysread();
a0d0e21e
LW
1713}
1714
1715PP(pp_eof)
1716{
4e35701f 1717 djSP;
a0d0e21e 1718 GV *gv;
4592e6ca 1719 MAGIC *mg;
a0d0e21e
LW
1720
1721 if (MAXARG <= 0)
3280af22 1722 gv = PL_last_in_gv;
a0d0e21e 1723 else
3280af22 1724 gv = PL_last_in_gv = (GV*)POPs;
4592e6ca
NIS
1725
1726 if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
1727 PUSHMARK(SP);
1728 XPUSHs(SvTIED_obj((SV*)gv, mg));
1729 PUTBACK;
1730 ENTER;
864dbfa3 1731 call_method("EOF", G_SCALAR);
4592e6ca
NIS
1732 LEAVE;
1733 SPAGAIN;
1734 RETURN;
1735 }
1736
54310121 1737 PUSHs(boolSV(!gv || do_eof(gv)));
a0d0e21e
LW
1738 RETURN;
1739}
1740
1741PP(pp_tell)
1742{
4e35701f 1743 djSP; dTARGET;
4592e6ca
NIS
1744 GV *gv;
1745 MAGIC *mg;
a0d0e21e
LW
1746
1747 if (MAXARG <= 0)
3280af22 1748 gv = PL_last_in_gv;
a0d0e21e 1749 else
3280af22 1750 gv = PL_last_in_gv = (GV*)POPs;
4592e6ca
NIS
1751
1752 if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
1753 PUSHMARK(SP);
1754 XPUSHs(SvTIED_obj((SV*)gv, mg));
1755 PUTBACK;
1756 ENTER;
864dbfa3 1757 call_method("TELL", G_SCALAR);
4592e6ca
NIS
1758 LEAVE;
1759 SPAGAIN;
1760 RETURN;
1761 }
1762
a0d0e21e
LW
1763 PUSHi( do_tell(gv) );
1764 RETURN;
1765}
1766
1767PP(pp_seek)
1768{
cea2e8a9 1769 return pp_sysseek();
137443ea
PP
1770}
1771
1772PP(pp_sysseek)
1773{
4e35701f 1774 djSP;
a0d0e21e
LW
1775 GV *gv;
1776 int whence = POPi;
d9b3e12d 1777 Off_t offset = (Off_t)SvIVx(POPs);
4592e6ca 1778 MAGIC *mg;
a0d0e21e 1779
3280af22 1780 gv = PL_last_in_gv = (GV*)POPs;
4592e6ca
NIS
1781
1782 if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
1783 PUSHMARK(SP);
1784 XPUSHs(SvTIED_obj((SV*)gv, mg));
1785 XPUSHs(sv_2mortal(newSViv((IV) offset)));
1786 XPUSHs(sv_2mortal(newSViv((IV) whence)));
1787 PUTBACK;
1788 ENTER;
864dbfa3 1789 call_method("SEEK", G_SCALAR);
4592e6ca
NIS
1790 LEAVE;
1791 SPAGAIN;
1792 RETURN;
1793 }
1794
533c011a 1795 if (PL_op->op_type == OP_SEEK)
8903cb82
PP
1796 PUSHs(boolSV(do_seek(gv, offset, whence)));
1797 else {
97cc44eb 1798 Off_t n = do_sysseek(gv, offset, whence);
3280af22 1799 PUSHs((n < 0) ? &PL_sv_undef
8903cb82 1800 : sv_2mortal(n ? newSViv((IV)n)
79cb57f6 1801 : newSVpvn(zero_but_true, ZBTLEN)));
8903cb82 1802 }
a0d0e21e
LW
1803 RETURN;
1804}
1805
1806PP(pp_truncate)
1807{
4e35701f 1808 djSP;
a0d0e21e
LW
1809 Off_t len = (Off_t)POPn;
1810 int result = 1;
1811 GV *tmpgv;
2d8e6c8d 1812 STRLEN n_a;
a0d0e21e 1813
748a9306 1814 SETERRNO(0,0);
5d94fbed 1815#if defined(HAS_TRUNCATE) || defined(HAS_CHSIZE) || defined(F_FREESP)
533c011a 1816 if (PL_op->op_flags & OPf_SPECIAL) {
2d8e6c8d 1817 tmpgv = gv_fetchpv(POPpx, FALSE, SVt_PVIO);
cbdc8872 1818 do_ftruncate:
1e422769 1819 TAINT_PROPER("truncate");
a0d0e21e 1820 if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv)) ||
cbdc8872 1821#ifdef HAS_TRUNCATE
760ac839 1822 ftruncate(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
cbdc8872 1823#else
760ac839 1824 my_chsize(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
cbdc8872 1825#endif
a0d0e21e
LW
1826 result = 0;
1827 }
1828 else {
cbdc8872 1829 SV *sv = POPs;
1e422769 1830 char *name;
2d8e6c8d 1831 STRLEN n_a;
1e422769 1832
cbdc8872
PP
1833 if (SvTYPE(sv) == SVt_PVGV) {
1834 tmpgv = (GV*)sv; /* *main::FRED for example */
1835 goto do_ftruncate;
1836 }
1837 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
1838 tmpgv = (GV*) SvRV(sv); /* \*main::FRED for example */
1839 goto do_ftruncate;
1840 }
1e422769 1841
2d8e6c8d 1842 name = SvPV(sv, n_a);
1e422769 1843 TAINT_PROPER("truncate");
cbdc8872 1844#ifdef HAS_TRUNCATE
1e422769 1845 if (truncate(name, len) < 0)
a0d0e21e 1846 result = 0;
cbdc8872
PP
1847#else
1848 {
1849 int tmpfd;
6ad3d225 1850 if ((tmpfd = PerlLIO_open(name, O_RDWR)) < 0)
bbce6d69 1851 result = 0;
cbdc8872
PP
1852 else {
1853 if (my_chsize(tmpfd, len) < 0)
1854 result = 0;
6ad3d225 1855 PerlLIO_close(tmpfd);
cbdc8872 1856 }
a0d0e21e 1857 }
a0d0e21e 1858#endif
cbdc8872 1859 }
a0d0e21e
LW
1860
1861 if (result)
1862 RETPUSHYES;
1863 if (!errno)
748a9306 1864 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW
1865 RETPUSHUNDEF;
1866#else
cea2e8a9 1867 DIE(aTHX_ "truncate not implemented");
a0d0e21e
LW
1868#endif
1869}
1870
1871PP(pp_fcntl)
1872{
cea2e8a9 1873 return pp_ioctl();
a0d0e21e
LW
1874}
1875
1876PP(pp_ioctl)
1877{
4e35701f 1878 djSP; dTARGET;
748a9306 1879 SV *argsv = POPs;
a0d0e21e 1880 unsigned int func = U_I(POPn);
533c011a 1881 int optype = PL_op->op_type;
a0d0e21e 1882 char *s;
324aa91a 1883 IV retval;
a0d0e21e
LW
1884 GV *gv = (GV*)POPs;
1885 IO *io = GvIOn(gv);
1886
748a9306
LW
1887 if (!io || !argsv || !IoIFP(io)) {
1888 SETERRNO(EBADF,RMS$_IFI); /* well, sort of... */
a0d0e21e
LW
1889 RETPUSHUNDEF;
1890 }
1891
748a9306 1892 if (SvPOK(argsv) || !SvNIOK(argsv)) {
a0d0e21e 1893 STRLEN len;
324aa91a 1894 STRLEN need;
748a9306 1895 s = SvPV_force(argsv, len);
324aa91a
HF
1896 need = IOCPARM_LEN(func);
1897 if (len < need) {
1898 s = Sv_Grow(argsv, need + 1);
1899 SvCUR_set(argsv, need);
a0d0e21e
LW
1900 }
1901
748a9306 1902 s[SvCUR(argsv)] = 17; /* a little sanity check here */
a0d0e21e
LW
1903 }
1904 else {
748a9306 1905 retval = SvIV(argsv);
c529f79d 1906 s = INT2PTR(char*,retval); /* ouch */
a0d0e21e
LW
1907 }
1908
1909 TAINT_PROPER(optype == OP_IOCTL ? "ioctl" : "fcntl");
1910
1911 if (optype == OP_IOCTL)
1912#ifdef HAS_IOCTL
76e3520e 1913 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
a0d0e21e 1914#else
cea2e8a9 1915 DIE(aTHX_ "ioctl is not implemented");
a0d0e21e
LW
1916#endif
1917 else
55497cff
PP
1918#ifdef HAS_FCNTL
1919#if defined(OS2) && defined(__EMX__)
760ac839 1920 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
55497cff 1921#else
760ac839 1922 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
55497cff
PP
1923#endif
1924#else
cea2e8a9 1925 DIE(aTHX_ "fcntl is not implemented");
a0d0e21e
LW
1926#endif
1927
748a9306
LW
1928 if (SvPOK(argsv)) {
1929 if (s[SvCUR(argsv)] != 17)
cea2e8a9 1930 DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
22c35a8c 1931 PL_op_name[optype]);
748a9306
LW
1932 s[SvCUR(argsv)] = 0; /* put our null back */
1933 SvSETMAGIC(argsv); /* Assume it has changed */
a0d0e21e
LW
1934 }
1935
1936 if (retval == -1)
1937 RETPUSHUNDEF;
1938 if (retval != 0) {
1939 PUSHi(retval);
1940 }
1941 else {
8903cb82 1942 PUSHp(zero_but_true, ZBTLEN);
a0d0e21e
LW
1943 }
1944 RETURN;
1945}
1946
1947PP(pp_flock)
1948{
4e35701f 1949 djSP; dTARGET;
a0d0e21e
LW
1950 I32 value;
1951 int argtype;
1952 GV *gv;
760ac839 1953 PerlIO *fp;
16d20bd9 1954
ff68c719 1955#ifdef FLOCK
a0d0e21e
LW
1956 argtype = POPi;
1957 if (MAXARG <= 0)
3280af22 1958 gv = PL_last_in_gv;
a0d0e21e
LW
1959 else
1960 gv = (GV*)POPs;
1961 if (gv && GvIO(gv))
1962 fp = IoIFP(GvIOp(gv));
1963 else
1964 fp = Nullfp;
1965 if (fp) {
68dc0745 1966 (void)PerlIO_flush(fp);
76e3520e 1967 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
a0d0e21e
LW
1968 }
1969 else
1970 value = 0;
1971 PUSHi(value);
1972 RETURN;
1973#else
cea2e8a9 1974 DIE(aTHX_ PL_no_func, "flock()");
a0d0e21e
LW
1975#endif
1976}
1977
1978/* Sockets. */
1979
1980PP(pp_socket)
1981{
4e35701f 1982 djSP;
a0d0e21e
LW
1983#ifdef HAS_SOCKET
1984 GV *gv;
1985 register IO *io;
1986 int protocol = POPi;
1987 int type = POPi;
1988 int domain = POPi;
1989 int fd;
1990
1991 gv = (GV*)POPs;
1992
1993 if (!gv) {
748a9306 1994 SETERRNO(EBADF,LIB$_INVARG);
a0d0e21e
LW
1995 RETPUSHUNDEF;
1996 }
1997
1998 io = GvIOn(gv);
1999 if (IoIFP(io))
2000 do_close(gv, FALSE);
2001
2002 TAINT_PROPER("socket");
6ad3d225 2003 fd = PerlSock_socket(domain, type, protocol);
a0d0e21e
LW
2004 if (fd < 0)
2005 RETPUSHUNDEF;
760ac839
LW
2006 IoIFP(io) = PerlIO_fdopen(fd, "r"); /* stdio gets confused about sockets */
2007 IoOFP(io) = PerlIO_fdopen(fd, "w");
a0d0e21e
LW
2008 IoTYPE(io) = 's';
2009 if (!IoIFP(io) || !IoOFP(io)) {
760ac839
LW
2010 if (IoIFP(io)) PerlIO_close(IoIFP(io));
2011 if (IoOFP(io)) PerlIO_close(IoOFP(io));
6ad3d225 2012 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
a0d0e21e
LW
2013 RETPUSHUNDEF;
2014 }
2015
2016 RETPUSHYES;
2017#else
cea2e8a9 2018 DIE(aTHX_ PL_no_sock_func, "socket");
a0d0e21e
LW
2019#endif
2020}
2021
2022PP(pp_sockpair)
2023{
4e35701f 2024 djSP;
a0d0e21e
LW
2025#ifdef HAS_SOCKETPAIR
2026 GV *gv1;
2027 GV *gv2;
2028 register IO *io1;
2029 register IO *io2;
2030 int protocol = POPi;
2031 int type = POPi;
2032 int domain = POPi;
2033 int fd[2];
2034
2035 gv2 = (GV*)POPs;
2036 gv1 = (GV*)POPs;
2037 if (!gv1 || !gv2)
2038 RETPUSHUNDEF;
2039
2040 io1 = GvIOn(gv1);
2041 io2 = GvIOn(gv2);
2042 if (IoIFP(io1))
2043 do_close(gv1, FALSE);
2044 if (IoIFP(io2))
2045 do_close(gv2, FALSE);
2046
2047 TAINT_PROPER("socketpair");
6ad3d225 2048 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
a0d0e21e 2049 RETPUSHUNDEF;
760ac839
LW
2050 IoIFP(io1) = PerlIO_fdopen(fd[0], "r");
2051 IoOFP(io1) = PerlIO_fdopen(fd[0], "w");
a0d0e21e 2052 IoTYPE(io1) = 's';
760ac839
LW
2053 IoIFP(io2) = PerlIO_fdopen(fd[1], "r");
2054 IoOFP(io2) = PerlIO_fdopen(fd[1], "w");
a0d0e21e
LW
2055 IoTYPE(io2) = 's';
2056 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
760ac839
LW
2057 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2058 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
6ad3d225 2059 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
760ac839
LW
2060 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2061 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
6ad3d225 2062 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
a0d0e21e
LW
2063 RETPUSHUNDEF;
2064 }
2065
2066 RETPUSHYES;
2067#else
cea2e8a9 2068 DIE(aTHX_ PL_no_sock_func, "socketpair");
a0d0e21e
LW
2069#endif
2070}
2071
2072PP(pp_bind)
2073{
4e35701f 2074 djSP;
a0d0e21e 2075#ifdef HAS_SOCKET
eec2d3df
GS
2076#ifdef MPE /* Requires PRIV mode to bind() to ports < 1024 */
2077 extern GETPRIVMODE();
2078 extern GETUSERMODE();
2079#endif
748a9306 2080 SV *addrsv = POPs;
a0d0e21e
LW
2081 char *addr;
2082 GV *gv = (GV*)POPs;
2083 register IO *io = GvIOn(gv);
2084 STRLEN len;
eec2d3df
GS
2085 int bind_ok = 0;
2086#ifdef MPE
2087 int mpeprivmode = 0;
2088#endif
a0d0e21e
LW
2089
2090 if (!io || !IoIFP(io))
2091 goto nuts;
2092
748a9306 2093 addr = SvPV(addrsv, len);
a0d0e21e 2094 TAINT_PROPER("bind");
eec2d3df
GS
2095#ifdef MPE /* Deal with MPE bind() peculiarities */
2096 if (((struct sockaddr *)addr)->sa_family == AF_INET) {
2097 /* The address *MUST* stupidly be zero. */
2098 ((struct sockaddr_in *)addr)->sin_addr.s_addr = INADDR_ANY;
2099 /* PRIV mode is required to bind() to ports < 1024. */
2100 if (((struct sockaddr_in *)addr)->sin_port < 1024 &&
2101 ((struct sockaddr_in *)addr)->sin_port > 0) {
2102 GETPRIVMODE(); /* If this fails, we are aborted by MPE/iX. */
2103 mpeprivmode = 1;
2104 }
2105 }
2106#endif /* MPE */
2107 if (PerlSock_bind(PerlIO_fileno(IoIFP(io)),
2108 (struct sockaddr *)addr, len) >= 0)
2109 bind_ok = 1;
2110
2111#ifdef MPE /* Switch back to USER mode */
2112 if (mpeprivmode)
2113 GETUSERMODE();
2114#endif /* MPE */
2115
2116 if (bind_ok)
a0d0e21e
LW
2117 RETPUSHYES;
2118 else
2119 RETPUSHUNDEF;
2120
2121nuts:
599cee73 2122 if (ckWARN(WARN_CLOSED))
cea2e8a9 2123 Perl_warner(aTHX_ WARN_CLOSED, "bind() on closed fd");
748a9306 2124 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW
2125 RETPUSHUNDEF;
2126#else
cea2e8a9 2127 DIE(aTHX_ PL_no_sock_func, "bind");
a0d0e21e
LW
2128#endif
2129}
2130
2131PP(pp_connect)
2132{
4e35701f 2133 djSP;
a0d0e21e 2134#ifdef HAS_SOCKET
748a9306 2135 SV *addrsv = POPs;
a0d0e21e
LW
2136 char *addr;
2137 GV *gv = (GV*)POPs;
2138 register IO *io = GvIOn(gv);
2139 STRLEN len;
2140
2141 if (!io || !IoIFP(io))
2142 goto nuts;
2143
748a9306 2144 addr = SvPV(addrsv, len);
a0d0e21e 2145 TAINT_PROPER("connect");
6ad3d225 2146 if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
a0d0e21e
LW
2147 RETPUSHYES;
2148 else
2149 RETPUSHUNDEF;
2150
2151nuts:
599cee73 2152 if (ckWARN(WARN_CLOSED))
cea2e8a9 2153 Perl_warner(aTHX_ WARN_CLOSED, "connect() on closed fd");
748a9306 2154 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW
2155 RETPUSHUNDEF;
2156#else
cea2e8a9 2157 DIE(aTHX_ PL_no_sock_func, "connect");
a0d0e21e
LW
2158#endif
2159}
2160
2161PP(pp_listen)
2162{
4e35701f 2163 djSP;
a0d0e21e
LW
2164#ifdef HAS_SOCKET
2165 int backlog = POPi;
2166 GV *gv = (GV*)POPs;
2167 register IO *io = GvIOn(gv);
2168
2169 if (!io || !IoIFP(io))
2170 goto nuts;
2171
6ad3d225 2172 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
a0d0e21e
LW
2173 RETPUSHYES;
2174 else
2175 RETPUSHUNDEF;
2176
2177nuts:
599cee73 2178 if (ckWARN(WARN_CLOSED))
cea2e8a9 2179 Perl_warner(aTHX_ WARN_CLOSED, "listen() on closed fd");
748a9306 2180 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW
2181 RETPUSHUNDEF;
2182#else
cea2e8a9 2183 DIE(aTHX_ PL_no_sock_func, "listen");
a0d0e21e
LW
2184#endif
2185}
2186
2187PP(pp_accept)
2188{
4e35701f 2189 djSP; dTARGET;
a0d0e21e
LW
2190#ifdef HAS_SOCKET
2191 GV *ngv;
2192 GV *ggv;
2193 register IO *nstio;
2194 register IO *gstio;
4633a7c4 2195 struct sockaddr saddr; /* use a struct to avoid alignment problems */
1e422769 2196 Sock_size_t len = sizeof saddr;
a0d0e21e
LW
2197 int fd;
2198
2199 ggv = (GV*)POPs;
2200 ngv = (GV*)POPs;
2201
2202 if (!ngv)
2203 goto badexit;
2204 if (!ggv)
2205 goto nuts;
2206
2207 gstio = GvIO(ggv);
2208 if (!gstio || !IoIFP(gstio))
2209 goto nuts;
2210
2211 nstio = GvIOn(ngv);
2212 if (IoIFP(nstio))
2213 do_close(ngv, FALSE);
2214
6ad3d225 2215 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *)&saddr, &len);
a0d0e21e
LW
2216 if (fd < 0)
2217 goto badexit;
760ac839
LW
2218 IoIFP(nstio) = PerlIO_fdopen(fd, "r");
2219 IoOFP(nstio) = PerlIO_fdopen(fd, "w");
a0d0e21e
LW
2220 IoTYPE(nstio) = 's';
2221 if (!IoIFP(nstio) || !IoOFP(nstio)) {
760ac839
LW
2222 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2223 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
6ad3d225 2224 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
a0d0e21e
LW
2225 goto badexit;
2226 }
2227
748a9306 2228 PUSHp((char *)&saddr, len);
a0d0e21e
LW
2229 RETURN;
2230
2231nuts:
599cee73 2232 if (ckWARN(WARN_CLOSED))
cea2e8a9 2233 Perl_warner(aTHX_ WARN_CLOSED, "accept() on closed fd");
748a9306 2234 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW
2235
2236badexit:
2237 RETPUSHUNDEF;
2238
2239#else
cea2e8a9 2240 DIE(aTHX_ PL_no_sock_func, "accept");
a0d0e21e
LW
2241#endif
2242}
2243
2244PP(pp_shutdown)
2245{
4e35701f 2246 djSP; dTARGET;
a0d0e21e
LW
2247#ifdef HAS_SOCKET
2248 int how = POPi;
2249 GV *gv = (GV*)POPs;
2250 register IO *io = GvIOn(gv);
2251
2252 if (!io || !IoIFP(io))
2253 goto nuts;
2254
6ad3d225 2255 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
a0d0e21e
LW
2256 RETURN;
2257
2258nuts:
599cee73 2259 if (ckWARN(WARN_CLOSED))
cea2e8a9 2260 Perl_warner(aTHX_ WARN_CLOSED, "shutdown() on closed fd");
748a9306 2261 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW
2262 RETPUSHUNDEF;
2263#else
cea2e8a9 2264 DIE(aTHX_ PL_no_sock_func, "shutdown");
a0d0e21e
LW
2265#endif
2266}
2267
2268PP(pp_gsockopt)
2269{
2270#ifdef HAS_SOCKET
cea2e8a9 2271 return pp_ssockopt();
a0d0e21e 2272#else
cea2e8a9 2273 DIE(aTHX_ PL_no_sock_func, "getsockopt");
a0d0e21e
LW
2274#endif
2275}
2276
2277PP(pp_ssockopt)
2278{
4e35701f 2279 djSP;
a0d0e21e 2280#ifdef HAS_SOCKET
533c011a 2281 int optype = PL_op->op_type;
a0d0e21e
LW
2282 SV *sv;
2283 int fd;
2284 unsigned int optname;
2285 unsigned int lvl;
2286 GV *gv;
2287 register IO *io;
1e422769 2288 Sock_size_t len;
a0d0e21e
LW
2289
2290 if (optype == OP_GSOCKOPT)
2291 sv = sv_2mortal(NEWSV(22, 257));
2292 else
2293 sv = POPs;
2294 optname = (unsigned int) POPi;
2295 lvl = (unsigned int) POPi;
2296
2297 gv = (GV*)POPs;
2298 io = GvIOn(gv);
2299 if (!io || !IoIFP(io))
2300 goto nuts;
2301
760ac839 2302 fd = PerlIO_fileno(IoIFP(io));
a0d0e21e
LW
2303 switch (optype) {
2304 case OP_GSOCKOPT:
748a9306 2305 SvGROW(sv, 257);
a0d0e21e 2306 (void)SvPOK_only(sv);
748a9306
LW
2307 SvCUR_set(sv,256);
2308 *SvEND(sv) ='\0';
1e422769 2309 len = SvCUR(sv);
6ad3d225 2310 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
a0d0e21e 2311 goto nuts2;
1e422769 2312 SvCUR_set(sv, len);
748a9306 2313 *SvEND(sv) ='\0';
a0d0e21e
LW
2314 PUSHs(sv);
2315 break;
2316 case OP_SSOCKOPT: {
1e422769
PP
2317 char *buf;
2318 int aint;
2319 if (SvPOKp(sv)) {
2d8e6c8d
GS
2320 STRLEN l;
2321 buf = SvPV(sv, l);
2322 len = l;
1e422769 2323 }
56ee1660 2324 else {
a0d0e21e
LW
2325 aint = (int)SvIV(sv);
2326 buf = (char*)&aint;
2327 len = sizeof(int);
2328 }
6ad3d225 2329 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
a0d0e21e 2330 goto nuts2;
3280af22 2331 PUSHs(&PL_sv_yes);
a0d0e21e
LW
2332 }
2333 break;
2334 }
2335 RETURN;
2336
2337nuts:
599cee73 2338 if (ckWARN(WARN_CLOSED))
cea2e8a9 2339 Perl_warner(aTHX_ WARN_CLOSED, "[gs]etsockopt() on closed fd");
748a9306 2340 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW
2341nuts2:
2342 RETPUSHUNDEF;
2343
2344#else
cea2e8a9 2345 DIE(aTHX_ PL_no_sock_func, "setsockopt");
a0d0e21e
LW
2346#endif
2347}
2348
2349PP(pp_getsockname)
2350{
2351#ifdef HAS_SOCKET
cea2e8a9 2352 return pp_getpeername();
a0d0e21e 2353#else
cea2e8a9 2354 DIE(aTHX_ PL_no_sock_func, "getsockname");
a0d0e21e
LW
2355#endif
2356}
2357
2358PP(pp_getpeername)
2359{
4e35701f 2360 djSP;
a0d0e21e 2361#ifdef HAS_SOCKET
533c011a 2362 int optype = PL_op->op_type;
a0d0e21e
LW
2363 SV *sv;
2364 int fd;
2365 GV *gv = (GV*)POPs;
2366 register IO *io = GvIOn(gv);
1e422769 2367 Sock_size_t len;
a0d0e21e
LW
2368
2369 if (!io || !IoIFP(io))
2370 goto nuts;
2371
2372 sv = sv_2mortal(NEWSV(22, 257));
748a9306 2373 (void)SvPOK_only(sv);
1e422769
PP
2374 len = 256;
2375 SvCUR_set(sv, len);
748a9306 2376 *SvEND(sv) ='\0';
760ac839 2377 fd = PerlIO_fileno(IoIFP(io));
a0d0e21e
LW
2378 switch (optype) {
2379 case OP_GETSOCKNAME:
6ad3d225 2380 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
a0d0e21e
LW
2381 goto nuts2;
2382 break;
2383 case OP_GETPEERNAME:
6ad3d225 2384 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
a0d0e21e 2385 goto nuts2;
490ab354
JH
2386#if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2387 {
2388 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";
2389 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2390 if (((struct sockaddr *)SvPVX(sv))->sa_family == AF_INET &&
2391 !memcmp((char *)SvPVX(sv) + sizeof(u_short), nowhere,
2392 sizeof(u_short) + sizeof(struct in_addr))) {
2393 goto nuts2;
2394 }
2395 }
2396#endif
a0d0e21e
LW
2397 break;
2398 }
13826f2c
CS
2399#ifdef BOGUS_GETNAME_RETURN
2400 /* Interactive Unix, getpeername() and getsockname()
2401 does not return valid namelen */
1e422769
PP
2402 if (len == BOGUS_GETNAME_RETURN)
2403 len = sizeof(struct sockaddr);
13826f2c 2404#endif
1e422769 2405 SvCUR_set(sv, len);
748a9306 2406 *SvEND(sv) ='\0';
a0d0e21e
LW
2407 PUSHs(sv);
2408 RETURN;
2409
2410nuts:
599cee73 2411 if (ckWARN(WARN_CLOSED))
cea2e8a9 2412 Perl_warner(aTHX_ WARN_CLOSED, "get{sock, peer}name() on closed fd");
748a9306 2413 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW
2414nuts2:
2415 RETPUSHUNDEF;
2416
2417#else
cea2e8a9 2418 DIE(aTHX_ PL_no_sock_func, "getpeername");
a0d0e21e
LW
2419#endif
2420}
2421
2422/* Stat calls. */
2423
2424PP(pp_lstat)
2425{
cea2e8a9 2426 return pp_stat();
a0d0e21e
LW
2427}
2428
2429PP(pp_stat)
2430{
4e35701f 2431 djSP;
a0d0e21e 2432 GV *tmpgv;
54310121 2433 I32 gimme;
a0d0e21e 2434 I32 max = 13;
2d8e6c8d 2435 STRLEN n_a;
a0d0e21e 2436
533c011a 2437 if (PL_op->op_flags & OPf_REF) {
a0d0e21e 2438 tmpgv = cGVOP->op_gv;
748a9306 2439 do_fstat:
3280af22
NIS
2440 if (tmpgv != PL_defgv) {
2441 PL_laststype = OP_STAT;
2442 PL_statgv = tmpgv;
2443 sv_setpv(PL_statname, "");
2444 PL_laststatval = (GvIO(tmpgv) && IoIFP(GvIOp(tmpgv))
2445 ? PerlLIO_fstat(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), &PL_statcache) : -1);
a0d0e21e 2446 }
3280af22 2447 if (PL_laststatval < 0)
a0d0e21e
LW
2448 max = 0;
2449 }
2450 else {
748a9306
LW
2451 SV* sv = POPs;
2452 if (SvTYPE(sv) == SVt_PVGV) {
2453 tmpgv = (GV*)sv;
2454 goto do_fstat;
2455 }
2456 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2457 tmpgv = (GV*)SvRV(sv);
2458 goto do_fstat;
2459 }
2d8e6c8d 2460 sv_setpv(PL_statname, SvPV(sv,n_a));
3280af22 2461 PL_statgv = Nullgv;
a0d0e21e 2462#ifdef HAS_LSTAT
533c011a
NIS
2463 PL_laststype = PL_op->op_type;
2464 if (PL_op->op_type == OP_LSTAT)
2d8e6c8d 2465 PL_laststatval = PerlLIO_lstat(SvPV(PL_statname, n_a), &PL_statcache);
a0d0e21e
LW
2466 else
2467#endif
2d8e6c8d 2468 PL_laststatval = PerlLIO_stat(SvPV(PL_statname, n_a), &PL_statcache);
3280af22 2469 if (PL_laststatval < 0) {
2d8e6c8d 2470 if (ckWARN(WARN_NEWLINE) && strchr(SvPV(PL_statname, n_a), '\n'))
cea2e8a9 2471 Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "stat");
a0d0e21e
LW
2472 max = 0;
2473 }
2474 }
2475
54310121
PP
2476 gimme = GIMME_V;
2477 if (gimme != G_ARRAY) {
2478 if (gimme != G_VOID)
2479 XPUSHs(boolSV(max));
2480 RETURN;
a0d0e21e
LW
2481 }
2482 if (max) {
36477c24
PP
2483 EXTEND(SP, max);
2484 EXTEND_MORTAL(max);
1ff81528
PL
2485 PUSHs(sv_2mortal(newSViv(PL_statcache.st_dev)));
2486 PUSHs(sv_2mortal(newSViv(PL_statcache.st_ino)));
2487 PUSHs(sv_2mortal(newSViv(PL_statcache.st_mode)));
2488 PUSHs(sv_2mortal(newSViv(PL_statcache.st_nlink)));
2489 PUSHs(sv_2mortal(newSViv(PL_statcache.st_uid)));
2490 PUSHs(sv_2mortal(newSViv(PL_statcache.st_gid)));
cbdc8872 2491#ifdef USE_STAT_RDEV
1ff81528 2492 PUSHs(sv_2mortal(newSViv(PL_statcache.st_rdev)));
cbdc8872 2493#else
79cb57f6 2494 PUSHs(sv_2mortal(newSVpvn("", 0)));
cbdc8872 2495#endif
1ff81528 2496 PUSHs(sv_2mortal(newSViv(PL_statcache.st_size)));
cbdc8872 2497#ifdef BIG_TIME
172ae379
JH
2498 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_atime)));
2499 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_mtime)));
2500 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_ctime)));
cbdc8872 2501#else
1ff81528
PL
2502 PUSHs(sv_2mortal(newSViv(PL_statcache.st_atime)));
2503 PUSHs(sv_2mortal(newSViv(PL_statcache.st_mtime)));
2504 PUSHs(sv_2mortal(newSViv(PL_statcache.st_ctime)));
cbdc8872 2505#endif
a0d0e21e 2506#ifdef USE_STAT_BLOCKS
1ff81528
PL
2507 PUSHs(sv_2mortal(newSViv(PL_statcache.st_blksize)));
2508 PUSHs(sv_2mortal(newSViv(PL_statcache.st_blocks)));
a0d0e21e 2509#else
79cb57f6
GS
2510 PUSHs(sv_2mortal(newSVpvn("", 0)));
2511 PUSHs(sv_2mortal(newSVpvn("", 0)));
a0d0e21e
LW
2512#endif
2513 }
2514 RETURN;
2515}
2516
2517PP(pp_ftrread)
2518{
5ff3f7a4 2519 I32 result;
4e35701f 2520 djSP;
5ff3f7a4 2521#if defined(HAS_ACCESS) && defined(R_OK)
2d8e6c8d 2522 STRLEN n_a;
5ff3f7a4 2523 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2524 result = access(TOPpx, R_OK);
5ff3f7a4
GS
2525 if (result == 0)
2526 RETPUSHYES;
2527 if (result < 0)
2528 RETPUSHUNDEF;
2529 RETPUSHNO;
22865c03
GS
2530 }
2531 else
cea2e8a9 2532 result = my_stat();
5ff3f7a4 2533#else
cea2e8a9 2534 result = my_stat();
5ff3f7a4 2535#endif
22865c03 2536 SPAGAIN;
a0d0e21e
LW
2537 if (result < 0)
2538 RETPUSHUNDEF;
3280af22 2539 if (cando(S_IRUSR, 0, &PL_statcache))
a0d0e21e
LW
2540 RETPUSHYES;
2541 RETPUSHNO;
2542}
2543
2544PP(pp_ftrwrite)
2545{
5ff3f7a4 2546 I32 result;
4e35701f 2547 djSP;
5ff3f7a4 2548#if defined(HAS_ACCESS) && defined(W_OK)
2d8e6c8d 2549 STRLEN n_a;
5ff3f7a4 2550 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2551 result = access(TOPpx, W_OK);
5ff3f7a4
GS
2552 if (result == 0)
2553 RETPUSHYES;
2554 if (result < 0)
2555 RETPUSHUNDEF;
2556 RETPUSHNO;
22865c03
GS
2557 }
2558 else
cea2e8a9 2559 result = my_stat();
5ff3f7a4 2560#else
cea2e8a9 2561 result = my_stat();
5ff3f7a4 2562#endif
22865c03 2563 SPAGAIN;
a0d0e21e
LW
2564 if (result < 0)
2565 RETPUSHUNDEF;
3280af22 2566 if (cando(S_IWUSR, 0, &PL_statcache))
a0d0e21e
LW
2567 RETPUSHYES;
2568 RETPUSHNO;
2569}
2570
2571PP(pp_ftrexec)
2572{
5ff3f7a4 2573 I32 result;
4e35701f 2574 djSP;
5ff3f7a4 2575#if defined(HAS_ACCESS) && defined(X_OK)
2d8e6c8d 2576 STRLEN n_a;
5ff3f7a4 2577 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2578 result = access(TOPpx, X_OK);
5ff3f7a4
GS
2579 if (result == 0)
2580 RETPUSHYES;
2581 if (result < 0)
2582 RETPUSHUNDEF;
2583 RETPUSHNO;
22865c03
GS
2584 }
2585 else
cea2e8a9 2586 result = my_stat();
5ff3f7a4 2587#else
cea2e8a9 2588 result = my_stat();
5ff3f7a4 2589#endif
22865c03 2590 SPAGAIN;
a0d0e21e
LW
2591 if (result < 0)
2592 RETPUSHUNDEF;
3280af22 2593 if (cando(S_IXUSR, 0, &PL_statcache))
a0d0e21e
LW
2594 RETPUSHYES;
2595 RETPUSHNO;
2596}
2597
2598PP(pp_fteread)
2599{
5ff3f7a4 2600 I32 result;
4e35701f 2601 djSP;
5ff3f7a4 2602#ifdef PERL_EFF_ACCESS_R_OK
2d8e6c8d 2603 STRLEN n_a;
5ff3f7a4 2604 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2605 result = PERL_EFF_ACCESS_R_OK(TOPpx);
5ff3f7a4
GS
2606 if (result == 0)
2607 RETPUSHYES;
2608 if (result < 0)
2609 RETPUSHUNDEF;
2610 RETPUSHNO;
22865c03
GS
2611 }
2612 else
cea2e8a9 2613 result = my_stat();
5ff3f7a4 2614#else
cea2e8a9 2615 result = my_stat();
5ff3f7a4 2616#endif
22865c03 2617 SPAGAIN;
a0d0e21e
LW
2618 if (result < 0)
2619 RETPUSHUNDEF;
3280af22 2620 if (cando(S_IRUSR, 1, &PL_statcache))
a0d0e21e
LW
2621 RETPUSHYES;
2622 RETPUSHNO;
2623}
2624
2625PP(pp_ftewrite)
2626{
5ff3f7a4 2627 I32 result;
4e35701f 2628 djSP;
5ff3f7a4 2629#ifdef PERL_EFF_ACCESS_W_OK
2d8e6c8d 2630 STRLEN n_a;
5ff3f7a4 2631 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2632 result = PERL_EFF_ACCESS_W_OK(TOPpx);
5ff3f7a4
GS
2633 if (result == 0)
2634 RETPUSHYES;
2635 if (result < 0)
2636 RETPUSHUNDEF;
2637 RETPUSHNO;
22865c03
GS
2638 }
2639 else
cea2e8a9 2640 result = my_stat();
5ff3f7a4 2641#else
cea2e8a9 2642 result = my_stat();
5ff3f7a4 2643#endif
22865c03 2644 SPAGAIN;
a0d0e21e
LW
2645 if (result < 0)
2646 RETPUSHUNDEF;
3280af22 2647 if (cando(S_IWUSR, 1, &PL_statcache))
a0d0e21e
LW
2648 RETPUSHYES;
2649 RETPUSHNO;
2650}
2651
2652PP(pp_fteexec)
2653{
5ff3f7a4 2654 I32 result;
4e35701f 2655 djSP;
5ff3f7a4 2656#ifdef PERL_EFF_ACCESS_X_OK
2d8e6c8d 2657 STRLEN n_a;
5ff3f7a4 2658 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2659 result = PERL_EFF_ACCESS_X_OK(TOPpx);
5ff3f7a4
GS
2660 if (result == 0)
2661 RETPUSHYES;
2662 if (result < 0)
2663 RETPUSHUNDEF;
2664 RETPUSHNO;
22865c03
GS
2665 }
2666 else
cea2e8a9 2667 result = my_stat();
5ff3f7a4 2668#else
cea2e8a9 2669 result = my_stat();
5ff3f7a4 2670#endif
22865c03 2671 SPAGAIN;
a0d0e21e
LW
2672 if (result < 0)
2673 RETPUSHUNDEF;
3280af22 2674 if (cando(S_IXUSR, 1, &PL_statcache))
a0d0e21e
LW
2675 RETPUSHYES;
2676 RETPUSHNO;
2677}
2678
2679PP(pp_ftis)
2680{
cea2e8a9 2681 I32 result = my_stat();
4e35701f 2682 djSP;
a0d0e21e
LW
2683 if (result < 0)
2684 RETPUSHUNDEF;
2685 RETPUSHYES;
2686}
2687
2688PP(pp_fteowned)
2689{
cea2e8a9 2690 return pp_ftrowned();
a0d0e21e
LW
2691}
2692
2693PP(pp_ftrowned)
2694{
cea2e8a9 2695 I32 result = my_stat();
4e35701f 2696 djSP;
a0d0e21e
LW
2697 if (result < 0)
2698 RETPUSHUNDEF;
533c011a 2699 if (PL_statcache.st_uid == (PL_op->op_type == OP_FTEOWNED ? PL_euid : PL_uid) )
a0d0e21e
LW
2700 RETPUSHYES;
2701 RETPUSHNO;
2702}
2703
2704PP(pp_ftzero)
2705{
cea2e8a9 2706 I32 result = my_stat();
4e35701f 2707 djSP;
a0d0e21e
LW
2708 if (result < 0)
2709 RETPUSHUNDEF;
3280af22 2710 if (!PL_statcache.st_size)
a0d0e21e
LW
2711 RETPUSHYES;
2712 RETPUSHNO;
2713}
2714
2715PP(pp_ftsize)
2716{
cea2e8a9 2717 I32 result = my_stat();
4e35701f 2718 djSP; dTARGET;
a0d0e21e
LW
2719 if (result < 0)
2720 RETPUSHUNDEF;
3280af22 2721 PUSHi(PL_statcache.st_size);
a0d0e21e
LW
2722 RETURN;
2723}
2724
2725PP(pp_ftmtime)
2726{
cea2e8a9 2727 I32 result = my_stat();
4e35701f 2728 djSP; dTARGET;
a0d0e21e
LW
2729 if (result < 0)
2730 RETPUSHUNDEF;
c6419e06 2731 PUSHn( (PL_basetime - PL_statcache.st_mtime) / 86400.0 );
a0d0e21e
LW
2732 RETURN;
2733}
2734
2735PP(pp_ftatime)
2736{
cea2e8a9 2737 I32 result = my_stat();
4e35701f 2738 djSP; dTARGET;
a0d0e21e
LW
2739 if (result < 0)
2740 RETPUSHUNDEF;
c6419e06 2741 PUSHn( (PL_basetime - PL_statcache.st_atime) / 86400.0 );
a0d0e21e
LW
2742 RETURN;
2743}
2744
2745PP(pp_ftctime)
2746{
cea2e8a9 2747 I32 result = my_stat();
4e35701f 2748 djSP; dTARGET;
a0d0e21e
LW
2749 if (result < 0)
2750 RETPUSHUNDEF;
c6419e06 2751 PUSHn( (PL_basetime - PL_statcache.st_ctime) / 86400.0 );
a0d0e21e
LW
2752 RETURN;
2753}
2754
2755PP(pp_ftsock)
2756{
cea2e8a9 2757 I32 result = my_stat();
4e35701f 2758 djSP;
a0d0e21e
LW
2759 if (result < 0)
2760 RETPUSHUNDEF;
3280af22 2761 if (S_ISSOCK(PL_statcache.st_mode))
a0d0e21e
LW
2762 RETPUSHYES;
2763 RETPUSHNO;
2764}
2765
2766PP(pp_ftchr)
2767{
cea2e8a9 2768 I32 result = my_stat();
4e35701f 2769 djSP;
a0d0e21e
LW
2770 if (result < 0)
2771 RETPUSHUNDEF;
3280af22 2772 if (S_ISCHR(PL_statcache.st_mode))
a0d0e21e
LW
2773 RETPUSHYES;
2774 RETPUSHNO;
2775}
2776
2777PP(pp_ftblk)
2778{
cea2e8a9 2779 I32 result = my_stat();
4e35701f 2780 djSP;
a0d0e21e
LW
2781 if (result < 0)
2782 RETPUSHUNDEF;
3280af22 2783 if (S_ISBLK(PL_statcache.st_mode))
a0d0e21e
LW
2784 RETPUSHYES;
2785 RETPUSHNO;
2786}
2787
2788PP(pp_ftfile)
2789{
cea2e8a9 2790 I32 result = my_stat();
4e35701f 2791 djSP;
a0d0e21e
LW
2792 if (result < 0)
2793 RETPUSHUNDEF;
3280af22 2794 if (S_ISREG(PL_statcache.st_mode))
a0d0e21e
LW
2795 RETPUSHYES;
2796 RETPUSHNO;
2797}
2798
2799PP(pp_ftdir)
2800{
cea2e8a9 2801 I32 result = my_stat();
4e35701f 2802 djSP;
a0d0e21e
LW
2803 if (result < 0)
2804 RETPUSHUNDEF;
3280af22 2805 if (S_ISDIR(PL_statcache.st_mode))
a0d0e21e
LW
2806 RETPUSHYES;
2807 RETPUSHNO;
2808}
2809
2810PP(pp_ftpipe)
2811{
cea2e8a9 2812 I32 result = my_stat();
4e35701f 2813 djSP;
a0d0e21e
LW
2814 if (result < 0)
2815 RETPUSHUNDEF;
3280af22 2816 if (S_ISFIFO(PL_statcache.st_mode))
a0d0e21e
LW
2817 RETPUSHYES;
2818 RETPUSHNO;
2819}
2820
2821PP(pp_ftlink)
2822{
cea2e8a9 2823 I32 result = my_lstat();
4e35701f 2824 djSP;
a0d0e21e
LW
2825 if (result < 0)
2826 RETPUSHUNDEF;
3280af22 2827 if (S_ISLNK(PL_statcache.st_mode))
a0d0e21e
LW
2828 RETPUSHYES;
2829 RETPUSHNO;
2830}
2831
2832PP(pp_ftsuid)
2833{
4e35701f 2834 djSP;
a0d0e21e 2835#ifdef S_ISUID
cea2e8a9 2836 I32 result = my_stat();
a0d0e21e
LW
2837 SPAGAIN;
2838 if (result < 0)
2839 RETPUSHUNDEF;
3280af22 2840 if (PL_statcache.st_mode & S_ISUID)
a0d0e21e
LW
2841 RETPUSHYES;
2842#endif
2843 RETPUSHNO;
2844}
2845
2846PP(pp_ftsgid)
2847{
4e35701f 2848 djSP;
a0d0e21e 2849#ifdef S_ISGID
cea2e8a9 2850 I32 result = my_stat();
a0d0e21e
LW
2851 SPAGAIN;
2852 if (result < 0)
2853 RETPUSHUNDEF;
3280af22 2854 if (PL_statcache.st_mode & S_ISGID)
a0d0e21e
LW
2855 RETPUSHYES;
2856#endif
2857 RETPUSHNO;
2858}
2859
2860PP(pp_ftsvtx)
2861{
4e35701f 2862 djSP;
a0d0e21e 2863#ifdef S_ISVTX
cea2e8a9 2864 I32 result = my_stat();
a0d0e21e
LW
2865 SPAGAIN;
2866 if (result < 0)
2867 RETPUSHUNDEF;
3280af22 2868 if (PL_statcache.st_mode & S_ISVTX)
a0d0e21e
LW
2869 RETPUSHYES;
2870#endif
2871 RETPUSHNO;
2872}
2873
2874PP(pp_fttty)
2875{
4e35701f 2876 djSP;
a0d0e21e
LW
2877 int fd;
2878 GV *gv;
fb73857a 2879 char *tmps = Nullch;
2d8e6c8d 2880 STRLEN n_a;
fb73857a 2881
533c011a 2882 if (PL_op->op_flags & OPf_REF)
a0d0e21e 2883 gv = cGVOP->op_gv;
fb73857a
PP
2884 else if (isGV(TOPs))
2885 gv = (GV*)POPs;
2886 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
2887 gv = (GV*)SvRV(POPs);
a0d0e21e 2888 else
2d8e6c8d 2889 gv = gv_fetchpv(tmps = POPpx, FALSE, SVt_PVIO);
fb73857a 2890
a0d0e21e 2891 if (GvIO(gv) && IoIFP(GvIOp(gv)))
760ac839 2892 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
fb73857a 2893 else if (tmps && isDIGIT(*tmps))
a0d0e21e
LW
2894 fd = atoi(tmps);
2895 else
2896 RETPUSHUNDEF;
6ad3d225 2897 if (PerlLIO_isatty(fd))
a0d0e21e
LW
2898 RETPUSHYES;
2899 RETPUSHNO;
2900}
2901
16d20bd9
AD
2902#if defined(atarist) /* this will work with atariST. Configure will
2903 make guesses for other systems. */
2904# define FILE_base(f) ((f)->_base)
2905# define FILE_ptr(f) ((f)->_ptr)
2906# define FILE_cnt(f) ((f)->_cnt)
2907# define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
a0d0e21e
LW
2908#endif
2909
2910PP(pp_fttext)
2911{
4e35701f 2912 djSP;
a0d0e21e
LW
2913 I32 i;
2914 I32 len;
2915 I32 odd = 0;
2916 STDCHAR tbuf[512];
2917 register STDCHAR *s;
2918 register IO *io;
5f05dabc
PP
2919 register SV *sv;
2920 GV *gv;
2d8e6c8d 2921 STRLEN n_a;
a0d0e21e 2922
533c011a 2923 if (PL_op->op_flags & OPf_REF)
5f05dabc
PP
2924 gv = cGVOP->op_gv;
2925 else if (isGV(TOPs))
2926 gv = (GV*)POPs;
2927 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
2928 gv = (GV*)SvRV(POPs);
2929 else
2930 gv = Nullgv;
2931
2932 if (gv) {
a0d0e21e 2933 EXTEND(SP, 1);
3280af22
NIS
2934 if (gv == PL_defgv) {
2935 if (PL_statgv)
2936 io = GvIO(PL_statgv);
a0d0e21e 2937 else {
3280af22 2938 sv = PL_statname;
a0d0e21e
LW
2939 goto really_filename;
2940 }
2941 }
2942 else {
3280af22
NIS
2943 PL_statgv = gv;
2944 PL_laststatval = -1;
2945 sv_setpv(PL_statname, "");
2946 io = GvIO(PL_statgv);
a0d0e21e
LW
2947 }
2948 if (io && IoIFP(io)) {
5f05dabc 2949 if (! PerlIO_has_base(IoIFP(io)))
cea2e8a9 2950 DIE(aTHX_ "-T and -B not implemented on filehandles");
3280af22
NIS
2951 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
2952 if (PL_laststatval < 0)
5f05dabc 2953 RETPUSHUNDEF;
3280af22 2954 if (S_ISDIR(PL_statcache.st_mode)) /* handle NFS glitch */
533c011a 2955 if (PL_op->op_type == OP_FTTEXT)
a0d0e21e
LW
2956 RETPUSHNO;
2957 else
2958 RETPUSHYES;
a20bf0c3 2959 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
760ac839 2960 i = PerlIO_getc(IoIFP(io));
a0d0e21e 2961 if (i != EOF)
760ac839 2962 (void)PerlIO_ungetc(IoIFP(io),i);
a0d0e21e 2963 }
a20bf0c3 2964 if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
a0d0e21e 2965 RETPUSHYES;
a20bf0c3
JH
2966 len = PerlIO_get_bufsiz(IoIFP(io));
2967 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
760ac839
LW
2968 /* sfio can have large buffers - limit to 512 */
2969 if (len > 512)
2970 len = 512;
a0d0e21e
LW
2971 }
2972 else {
599cee73 2973 if (ckWARN(WARN_UNOPENED))
cea2e8a9 2974 Perl_warner(aTHX_ WARN_UNOPENED, "Test on unopened file <%s>",
a0d0e21e 2975 GvENAME(cGVOP->op_gv));
748a9306 2976 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW
2977 RETPUSHUNDEF;
2978 }
2979 }
2980 else {
2981 sv = POPs;
5f05dabc 2982 really_filename:
3280af22
NIS
2983 PL_statgv = Nullgv;
2984 PL_laststatval = -1;
2d8e6c8d 2985 sv_setpv(PL_statname, SvPV(sv, n_a));
a0d0e21e 2986#ifdef HAS_OPEN3
2d8e6c8d 2987 i = PerlLIO_open3(SvPV(sv, n_a), O_RDONLY, 0);
a0d0e21e 2988#else
2d8e6c8d 2989 i = PerlLIO_open(SvPV(sv, n_a), 0);
a0d0e21e
LW
2990#endif
2991 if (i < 0) {
2d8e6c8d 2992 if (ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, n_a), '\n'))
cea2e8a9 2993 Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "open");
a0d0e21e
LW
2994 RETPUSHUNDEF;
2995 }
3280af22
NIS
2996 PL_laststatval = PerlLIO_fstat(i, &PL_statcache);
2997 if (PL_laststatval < 0)
5f05dabc 2998 RETPUSHUNDEF;
6ad3d225
GS
2999 len = PerlLIO_read(i, tbuf, 512);
3000 (void)PerlLIO_close(i);
a0d0e21e 3001 if (len <= 0) {
533c011a 3002 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
a0d0e21e
LW
3003 RETPUSHNO; /* special case NFS directories */
3004 RETPUSHYES; /* null file is anything */
3005 }
3006 s = tbuf;
3007 }
3008
3009 /* now scan s to look for textiness */
4633a7c4 3010 /* XXX ASCII dependent code */
a0d0e21e
LW
3011
3012 for (i = 0; i < len; i++, s++) {
3013 if (!*s) { /* null never allowed in text */
3014 odd += len;
3015 break;
3016 }
9d116dd7
JH
3017#ifdef EBCDIC
3018 else if (!(isPRINT(*s) || isSPACE(*s)))
3019 odd++;
3020#else
a0d0e21e
LW
3021 else if (*s & 128)
3022 odd++;
3023 else if (*s < 32 &&
3024 *s != '\n' && *s != '\r' && *s != '\b' &&
3025 *s != '\t' && *s != '\f' && *s != 27)
3026 odd++;
9d116dd7 3027#endif
a0d0e21e
LW
3028 }
3029
533c011a 3030 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
a0d0e21e
LW
3031 RETPUSHNO;
3032 else
3033 RETPUSHYES;
3034}
3035
3036PP(pp_ftbinary)
3037{
cea2e8a9 3038 return pp_fttext();
a0d0e21e
LW
3039}
3040
3041/* File calls. */
3042
3043PP(pp_chdir)
3044{
4e35701f 3045 djSP; dTARGET;
a0d0e21e
LW
3046 char *tmps;
3047 SV **svp;
2d8e6c8d 3048 STRLEN n_a;
a0d0e21e
LW
3049
3050 if (MAXARG < 1)
3051 tmps = Nullch;
3052 else
2d8e6c8d 3053 tmps = POPpx;
a0d0e21e 3054 if (!tmps || !*tmps) {
3280af22 3055 svp = hv_fetch(GvHVn(PL_envgv), "HOME", 4, FALSE);
a0d0e21e 3056 if (svp)
2d8e6c8d 3057 tmps = SvPV(*svp, n_a);
a0d0e21e
LW
3058 }
3059 if (!tmps || !*tmps) {
3280af22 3060 svp = hv_fetch(GvHVn(PL_envgv), "LOGDIR", 6, FALSE);
a0d0e21e 3061 if (svp)
2d8e6c8d 3062 tmps = SvPV(*svp, n_a);
a0d0e21e 3063 }
491527d0
GS
3064#ifdef VMS
3065 if (!tmps || !*tmps) {
6b88bc9c 3066 svp = hv_fetch(GvHVn(PL_envgv), "SYS$LOGIN", 9, FALSE);
491527d0 3067 if (svp)
2d8e6c8d 3068 tmps = SvPV(*svp, n_a);
491527d0
GS
3069 }
3070#endif
a0d0e21e 3071 TAINT_PROPER("chdir");
6ad3d225 3072 PUSHi( PerlDir_chdir(tmps) >= 0 );
748a9306
LW
3073#ifdef VMS
3074 /* Clear the DEFAULT element of ENV so we'll get the new value
3075 * in the future. */
6b88bc9c 3076 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
748a9306 3077#endif
a0d0e21e
LW
3078 RETURN;
3079}
3080
3081PP(pp_chown)
3082{
4e35701f 3083 djSP; dMARK; dTARGET;
a0d0e21e
LW
3084 I32 value;
3085#ifdef HAS_CHOWN
533c011a 3086 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW
3087 SP = MARK;
3088 PUSHi(value);
3089 RETURN;
3090#else
cea2e8a9 3091 DIE(aTHX_ PL_no_func, "Unsupported function chown");
a0d0e21e
LW
3092#endif
3093}
3094
3095PP(pp_chroot)
3096{
4e35701f 3097 djSP; dTARGET;
a0d0e21e
LW
3098 char *tmps;
3099#ifdef HAS_CHROOT
2d8e6c8d
GS
3100 STRLEN n_a;
3101 tmps = POPpx;
a0d0e21e
LW
3102 TAINT_PROPER("chroot");
3103 PUSHi( chroot(tmps) >= 0 );
3104 RETURN;
3105#else
cea2e8a9 3106 DIE(aTHX_ PL_no_func, "chroot");
a0d0e21e
LW
3107#endif
3108}
3109
3110PP(pp_unlink)
3111{
4e35701f 3112 djSP; dMARK; dTARGET;
a0d0e21e 3113 I32 value;
533c011a 3114 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW
3115 SP = MARK;
3116 PUSHi(value);
3117 RETURN;
3118}
3119
3120PP(pp_chmod)
3121{
4e35701f 3122 djSP; dMARK; dTARGET;
a0d0e21e 3123 I32 value;
533c011a 3124 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW
3125 SP = MARK;
3126 PUSHi(value);
3127 RETURN;
3128}
3129
3130PP(pp_utime)
3131{
4e35701f 3132 djSP; dMARK; dTARGET;
a0d0e21e 3133 I32 value;
533c011a 3134 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW
3135 SP = MARK;
3136 PUSHi(value);
3137 RETURN;
3138}
3139
3140PP(pp_rename)
3141{
4e35701f 3142 djSP; dTARGET;
a0d0e21e 3143 int anum;
2d8e6c8d 3144 STRLEN n_a;
a0d0e21e 3145
2d8e6c8d
GS
3146 char *tmps2 = POPpx;
3147 char *tmps = SvPV(TOPs, n_a);
a0d0e21e
LW
3148 TAINT_PROPER("rename");
3149#ifdef HAS_RENAME
baed7233 3150 anum = PerlLIO_rename(tmps, tmps2);
a0d0e21e 3151#else
6b88bc9c 3152 if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
ed969818
WK
3153 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3154 anum = 1;
3155 else {
3654eb6c 3156 if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
ed969818
WK
3157 (void)UNLINK(tmps2);
3158 if (!(anum = link(tmps, tmps2)))
3159 anum = UNLINK(tmps);
3160 }
a0d0e21e
LW
3161 }
3162#endif
3163 SETi( anum >= 0 );
3164 RETURN;
3165}
3166
3167PP(pp_link)
3168{
4e35701f 3169 djSP; dTARGET;
a0d0e21e 3170#ifdef HAS_LINK
2d8e6c8d
GS
3171 STRLEN n_a;
3172 char *tmps2 = POPpx;
3173 char *tmps = SvPV(TOPs, n_a);
a0d0e21e
LW
3174 TAINT_PROPER("link");
3175 SETi( link(tmps, tmps2) >= 0 );
3176#else
cea2e8a9 3177 DIE(aTHX_ PL_no_func, "Unsupported function link");
a0d0e21e
LW
3178#endif
3179 RETURN;
3180}
3181
3182PP(pp_symlink)
3183{
4e35701f 3184 djSP; dTARGET;
a0d0e21e 3185#ifdef HAS_SYMLINK
2d8e6c8d
GS
3186 STRLEN n_a;
3187 char *tmps2 = POPpx;
3188 char *tmps = SvPV(TOPs, n_a);
a0d0e21e
LW
3189 TAINT_PROPER("symlink");
3190 SETi( symlink(tmps, tmps2) >= 0 );
3191 RETURN;
3192#else
cea2e8a9 3193 DIE(aTHX_ PL_no_func, "symlink");
a0d0e21e
LW
3194#endif
3195}
3196
3197PP(pp_readlink)
3198{
4e35701f 3199 djSP; dTARGET;
a0d0e21e
LW
3200#ifdef HAS_SYMLINK
3201 char *tmps;
46fc3d4c 3202 char buf[MAXPATHLEN];
a0d0e21e 3203 int len;
2d8e6c8d 3204 STRLEN n_a;
46fc3d4c 3205
fb73857a
PP
3206#ifndef INCOMPLETE_TAINTS
3207 TAINT;
3208#endif
2d8e6c8d 3209 tmps = POPpx;
a0d0e21e
LW
3210 len = readlink(tmps, buf, sizeof buf);
3211 EXTEND(SP, 1);
3212 if (len < 0)
3213 RETPUSHUNDEF;
3214 PUSHp(buf, len);
3215 RETURN;
3216#else
3217 EXTEND(SP, 1);
3218 RETSETUNDEF; /* just pretend it's a normal file */
3219#endif
3220}
3221
3222#if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
ba106d47 3223STATIC int
cea2e8a9 3224S_dooneliner(pTHX_ char *cmd, char *filename)
a0d0e21e 3225{
1e422769
PP
3226 char *save_filename = filename;
3227 char *cmdline;
3228 char *s;
760ac839 3229 PerlIO *myfp;
1e422769 3230 int anum = 1;
a0d0e21e 3231
1e422769
PP
3232 New(666, cmdline, strlen(cmd) + (strlen(filename) * 2) + 10, char);
3233 strcpy(cmdline, cmd);
3234 strcat(cmdline, " ");
3235 for (s = cmdline + strlen(cmdline); *filename; ) {
a0d0e21e
LW
3236 *s++ = '\\';
3237 *s++ = *filename++;
3238 }
3239 strcpy(s, " 2>&1");
6ad3d225 3240 myfp = PerlProc_popen(cmdline, "r");
1e422769
PP
3241 Safefree(cmdline);
3242
a0d0e21e 3243 if (myfp) {
1e422769 3244 SV *tmpsv = sv_newmortal();
6b88bc9c 3245 /* Need to save/restore 'PL_rs' ?? */
760ac839 3246 s = sv_gets(tmpsv, myfp, 0);
6ad3d225 3247 (void)PerlProc_pclose(myfp);
a0d0e21e 3248 if (s != Nullch) {
1e422769
PP
3249 int e;
3250 for (e = 1;
a0d0e21e 3251#ifdef HAS_SYS_ERRLIST
1e422769
PP
3252 e <= sys_nerr
3253#endif
3254 ; e++)
3255 {
3256 /* you don't see this */
3257 char *errmsg =
3258#ifdef HAS_SYS_ERRLIST
3259 sys_errlist[e]
a0d0e21e 3260#else
1e422769 3261 strerror(e)
a0d0e21e 3262#endif
1e422769
PP
3263 ;
3264 if (!errmsg)
3265 break;
3266 if (instr(s, errmsg)) {
3267 SETERRNO(e,0);
3268 return 0;
3269 }
a0d0e21e 3270 }
748a9306 3271 SETERRNO(0,0);
a0d0e21e
LW
3272#ifndef EACCES
3273#define EACCES EPERM
3274#endif
1e422769 3275 if (instr(s, "cannot make"))
748a9306 3276 SETERRNO(EEXIST,RMS$_FEX);
1e422769 3277 else if (instr(s, "existing file"))
748a9306 3278 SETERRNO(EEXIST,RMS$_FEX);
1e422769 3279 else if (instr(s, "ile exists"))
748a9306 3280 SETERRNO(EEXIST,RMS$_FEX);
1e422769 3281 else if (instr(s, "non-exist"))
748a9306 3282 SETERRNO(ENOENT,RMS$_FNF);
1e422769 3283 else if (instr(s, "does not exist"))
748a9306 3284 SETERRNO(ENOENT,RMS$_FNF);
1e422769 3285 else if (instr(s, "not empty"))
748a9306 3286 SETERRNO(EBUSY,SS$_DEVOFFLINE);
1e422769 3287 else if (instr(s, "cannot access"))
748a9306 3288 SETERRNO(EACCES,RMS$_PRV);
a0d0e21e 3289 else
748a9306 3290 SETERRNO(EPERM,RMS$_PRV);
a0d0e21e
LW
3291 return 0;
3292 }
3293 else { /* some mkdirs return no failure indication */
6b88bc9c 3294 anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
911d147d 3295 if (PL_op->op_type == OP_RMDIR)
a0d0e21e
LW
3296 anum = !anum;
3297 if (anum)
748a9306 3298 SETERRNO(0,0);
a0d0e21e 3299 else
748a9306 3300 SETERRNO(EACCES,RMS$_PRV); /* a guess */
a0d0e21e
LW
3301 }
3302 return anum;
3303 }
3304 else
3305 return 0;
3306}
3307#endif
3308
3309PP(pp_mkdir)
3310{
4e35701f 3311 djSP; dTARGET;
a0d0e21e
LW
3312 int mode = POPi;
3313#ifndef HAS_MKDIR
3314 int oldumask;
3315#endif
2d8e6c8d
GS
3316 STRLEN n_a;
3317 char *tmps = SvPV(TOPs, n_a);
a0d0e21e
LW
3318
3319 TAINT_PROPER("mkdir");
3320#ifdef HAS_MKDIR
6ad3d225 3321 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
a0d0e21e
LW
3322#else
3323 SETi( dooneliner("mkdir", tmps) );
6ad3d225
GS
3324 oldumask = PerlLIO_umask(0);
3325 PerlLIO_umask(oldumask);
3326 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
a0d0e21e
LW
3327#endif
3328 RETURN;
3329}
3330
3331PP(pp_rmdir)
3332{
4e35701f 3333 djSP; dTARGET;
a0d0e21e 3334 char *tmps;
2d8e6c8d 3335 STRLEN n_a;
a0d0e21e 3336
2d8e6c8d 3337 tmps = POPpx;
a0d0e21e
LW
3338 TAINT_PROPER("rmdir");
3339#ifdef HAS_RMDIR
6ad3d225 3340 XPUSHi( PerlDir_rmdir(tmps) >= 0 );
a0d0e21e
LW
3341#else
3342 XPUSHi( dooneliner("rmdir", tmps) );
3343#endif
3344 RETURN;
3345}
3346
3347/* Directory calls. */
3348
3349PP(pp_open_dir)
3350{
4e35701f 3351 djSP;
a0d0e21e 3352#if defined(Direntry_t) && defined(HAS_READDIR)
2d8e6c8d
GS
3353 STRLEN n_a;
3354 char *dirname = POPpx;
a0d0e21e
LW
3355 GV *gv = (GV*)POPs;
3356 register IO *io = GvIOn(gv);
3357
3358 if (!io)
3359 goto nope;
3360
3361 if (IoDIRP(io))
6ad3d225
GS
3362 PerlDir_close(IoDIRP(io));
3363 if (!(IoDIRP(io) = PerlDir_open(dirname)))
a0d0e21e
LW
3364 goto nope;
3365
3366 RETPUSHYES;
3367nope:
3368 if (!errno)
748a9306 3369 SETERRNO(EBADF,RMS$_DIR);
a0d0e21e
LW
3370 RETPUSHUNDEF;
3371#else
cea2e8a9 3372 DIE(aTHX_ PL_no_dir_func, "opendir");
a0d0e21e
LW
3373#endif
3374}
3375
3376PP(pp_readdir)
3377{
4e35701f 3378 djSP;
a0d0e21e
LW
3379#if defined(Direntry_t) && defined(HAS_READDIR)
3380#ifndef I_DIRENT
20ce7b12 3381 Direntry_t *readdir (DIR *);
a0d0e21e
LW
3382#endif
3383 register Direntry_t *dp;
3384 GV *gv = (GV*)POPs;
3385 register IO *io = GvIOn(gv);
fb73857a 3386 SV *sv;
a0d0e21e
LW
3387
3388 if (!io || !IoDIRP(io))
3389 goto nope;
3390
3391 if (GIMME == G_ARRAY) {
3392 /*SUPPRESS 560*/
6ad3d225 3393 while (dp = (Direntry_t *)PerlDir_read(IoDIRP(io))) {
a0d0e21e 3394#ifdef DIRNAMLEN
79cb57f6 3395 sv = newSVpvn(dp->d_name, dp->d_namlen);
a0d0e21e 3396#else
fb73857a
PP
3397 sv = newSVpv(dp->d_name, 0);
3398#endif
3399#ifndef INCOMPLETE_TAINTS
3400 SvTAINTED_on(sv);
a0d0e21e 3401#endif
fb73857a 3402 XPUSHs(sv_2mortal(sv));
a0d0e21e
LW
3403 }
3404 }
3405 else {
6ad3d225 3406 if (!(dp = (Direntry_t *)PerlDir_read(IoDIRP(io))))
a0d0e21e
LW
3407 goto nope;
3408#ifdef DIRNAMLEN
79cb57f6 3409 sv = newSVpvn(dp->d_name, dp->d_namlen);
a0d0e21e 3410#else
fb73857a 3411 sv = newSVpv(dp->d_name, 0);
a0d0e21e 3412#endif
fb73857a
PP
3413#ifndef INCOMPLETE_TAINTS
3414 SvTAINTED_on(sv);
3415#endif
3416 XPUSHs(sv_2mortal(sv));
a0d0e21e
LW
3417 }
3418 RETURN;
3419
3420nope:
3421 if (!errno)
748a9306 3422 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW
3423 if (GIMME == G_ARRAY)
3424 RETURN;
3425 else
3426 RETPUSHUNDEF;
3427#else
cea2e8a9 3428 DIE(aTHX_ PL_no_dir_func, "readdir");
a0d0e21e
LW
3429#endif
3430}
3431
3432PP(pp_telldir)
3433{
4e35701f 3434 djSP; dTARGET;
a0d0e21e 3435#if defined(HAS_TELLDIR) || defined(telldir)
968dcd91
JH
3436 /* XXX does _anyone_ need this? --AD 2/20/1998 */
3437 /* XXX netbsd still seemed to.
3438 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3439 --JHI 1999-Feb-02 */
3440# if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
20ce7b12 3441 long telldir (DIR *);
dfe9444c 3442# endif
a0d0e21e
LW
3443 GV *gv = (GV*)POPs;
3444 register IO *io = GvIOn(gv);
3445
3446 if (!io || !IoDIRP(io))
3447 goto nope;
3448
6ad3d225 3449 PUSHi( PerlDir_tell(IoDIRP(io)) );
a0d0e21e
LW
3450 RETURN;
3451nope:
3452 if (!errno)
748a9306 3453 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW
3454 RETPUSHUNDEF;
3455#else
cea2e8a9 3456 DIE(aTHX_ PL_no_dir_func, "telldir");
a0d0e21e
LW
3457#endif
3458}
3459
3460PP(pp_seekdir)
3461{
4e35701f 3462 djSP;
a0d0e21e
LW
3463#if defined(HAS_SEEKDIR) || defined(seekdir)
3464 long along = POPl;
3465 GV *gv = (GV*)POPs;
3466 register IO *io = GvIOn(gv);
3467
3468 if (!io || !IoDIRP(io))
3469 goto nope;
3470
6ad3d225 3471 (void)PerlDir_seek(IoDIRP(io), along);
a0d0e21e
LW
3472
3473 RETPUSHYES;
3474nope:
3475 if (!errno)
748a9306 3476 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW
3477 RETPUSHUNDEF;
3478#else
cea2e8a9 3479 DIE(aTHX_ PL_no_dir_func, "seekdir");
a0d0e21e
LW
3480#endif
3481}
3482
3483PP(pp_rewinddir)
3484{
4e35701f 3485 djSP;
a0d0e21e
LW
3486#if defined(HAS_REWINDDIR) || defined(rewinddir)
3487 GV *gv = (GV*)POPs;
3488 register IO *io = GvIOn(gv);
3489
3490 if (!io || !IoDIRP(io))
3491 goto nope;
3492
6ad3d225 3493 (void)PerlDir_rewind(IoDIRP(io));
a0d0e21e
LW
3494 RETPUSHYES;
3495nope:
3496 if (!errno)
748a9306 3497 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW
3498 RETPUSHUNDEF;
3499#else
cea2e8a9 3500 DIE(aTHX_ PL_no_dir_func, "rewinddir");
a0d0e21e
LW
3501#endif
3502}
3503
3504PP(pp_closedir)
3505{
4e35701f 3506 djSP;
a0d0e21e
LW
3507#if defined(Direntry_t) && defined(HAS_READDIR)
3508 GV *gv = (GV*)POPs;
3509 register IO *io = GvIOn(gv);
3510
3511 if (!io || !IoDIRP(io))
3512 goto nope;
3513
3514#ifdef VOID_CLOSEDIR
6ad3d225 3515 PerlDir_close(IoDIRP(io));
a0d0e21e 3516#else
6ad3d225 3517 if (PerlDir_close(IoDIRP(io)) < 0) {
748a9306 3518 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
a0d0e21e 3519 goto nope;
748a9306 3520 }
a0d0e21e
LW
3521#endif
3522 IoDIRP(io) = 0;
3523
3524 RETPUSHYES;
3525nope:
3526 if (!errno)
748a9306 3527 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW
3528 RETPUSHUNDEF;
3529#else
cea2e8a9 3530 DIE(aTHX_ PL_no_dir_func, "closedir");
a0d0e21e
LW
3531#endif
3532}
3533
3534/* Process control. */
3535
3536PP(pp_fork)
3537{
44a8e56a 3538#ifdef HAS_FORK
4e35701f 3539 djSP; dTARGET;
761237fe 3540 Pid_t childpid;
a0d0e21e
LW
3541 GV *tmpgv;
3542
3543 EXTEND(SP, 1);
45bc9206 3544 PERL_FLUSHALL_FOR_CHILD;
a0d0e21e
LW
3545 childpid = fork();
3546 if (childpid < 0)
3547 RETSETUNDEF;
3548 if (!childpid) {
3549 /*SUPPRESS 560*/
3550 if (tmpgv = gv_fetchpv("$", TRUE, SVt_PV))
1e422769 3551 sv_setiv(GvSV(tmpgv), (IV)getpid());
3280af22 3552 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
a0d0e21e
LW
3553 }
3554 PUSHi(childpid);
3555 RETURN;
3556#else
cea2e8a9 3557 DIE(aTHX_ PL_no_func, "Unsupported function fork");
a0d0e21e
LW
3558#endif
3559}
3560
3561PP(pp_wait)
3562{
2c2d71f5 3563#if !defined(DOSISH) || defined(OS2) || defined(WIN32)
4e35701f 3564 djSP; dTARGET;
761237fe 3565 Pid_t childpid;
a0d0e21e 3566 int argflags;
a0d0e21e 3567
44a8e56a 3568 childpid = wait4pid(-1, &argflags, 0);
f86702cc 3569 STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
44a8e56a 3570 XPUSHi(childpid);
a0d0e21e
LW
3571 RETURN;
3572#else
cea2e8a9 3573 DIE(aTHX_ PL_no_func, "Unsupported function wait");
a0d0e21e
LW
3574#endif
3575}
3576
3577PP(pp_waitpid)
3578{
2c2d71f5 3579#if !defined(DOSISH) || defined(OS2) || defined(WIN32)
4e35701f 3580 djSP; dTARGET;
761237fe 3581 Pid_t childpid;
a0d0e21e
LW
3582 int optype;
3583 int argflags;
a0d0e21e 3584
a0d0e21e
LW
3585 optype = POPi;
3586 childpid = TOPi;
3587 childpid = wait4pid(childpid, &argflags, optype);
f86702cc