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