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