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