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