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