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