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