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