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