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