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