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
hand-applied conflicting parts of suggested patch
[perl5.git] / pp_sys.c
CommitLineData
a0d0e21e
LW		 1/* pp_sys.c
2 *
4eb8286e 3 * Copyright (c) 1991-1999, Larry Wall
a0d0e21e
LW		 4 *
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
7 *
8 */
9
10/*
11 * But only a short way ahead its floor and the walls on either side were
12 * cloven by a great fissure, out of which the red glare came, now leaping
13 * up, now dying down into darkness; and all the while far below there was
14 * a rumour and a trouble as of great engines throbbing and labouring.
15 */
16
17#include "EXTERN.h"
18#include "perl.h"
19
76c32331 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 372 SAVESPTR(PL_rs); /* This is not permanent, either. */
79cb57f6 373 PL_rs = sv_2mortal(newSVpvn("\000", 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;
761237fe 610 Mode_t anum;
a0d0e21e
LW		 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
8f1f23e8
W		 872 * UNIX, Solaris, NeXT, Rhapsody) the smallest quantum select() operates
873 * on (sets/tests/clears bits) is 32 bits. */
f2da832e 874 growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
5ff3f7a4 875# else
4633a7c4 876 growsize = sizeof(fd_set);
5ff3f7a4
GS		 877# endif
878# else
879# ifdef NFDBITS
a0d0e21e 880
5ff3f7a4
GS		 881# ifndef NBBY
882# define NBBY 8
883# endif
a0d0e21e
LW		 884
885 masksize = NFDBITS / NBBY;
5ff3f7a4 886# else
a0d0e21e 887 masksize = sizeof(long); /* documented int, everyone seems to use long */
5ff3f7a4 888# endif
a0d0e21e
LW		 889 growsize = maxlen + (masksize - (maxlen % masksize));
890 Zero(&fd_sets[0], 4, char*);
891#endif
892
893 sv = SP[4];
894 if (SvOK(sv)) {
895 value = SvNV(sv);
896 if (value < 0.0)
897 value = 0.0;
898 timebuf.tv_sec = (long)value;
899 value -= (double)timebuf.tv_sec;
900 timebuf.tv_usec = (long)(value * 1000000.0);
901 }
902 else
903 tbuf = Null(struct timeval*);
904
905 for (i = 1; i <= 3; i++) {
906 sv = SP[i];
907 if (!SvOK(sv)) {
908 fd_sets[i] = 0;
909 continue;
910 }
911 else if (!SvPOK(sv))
2d8e6c8d 912 SvPV_force(sv,n_a); /* force string conversion */
a0d0e21e
LW		 913 j = SvLEN(sv);
914 if (j < growsize) {
915 Sv_Grow(sv, growsize);
a0d0e21e 916 }
c07a80fd 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) {
ded8aa31
GS		 1006 if (!GvIO(newdefout))
1007 gv_IOadd(newdefout);
4633a7c4
LW		 1008 setdefout(newdefout);
1009 }
1010
a0d0e21e
LW		 1011 RETURN;
1012}
1013
1014PP(pp_getc)
1015{
4e35701f 1016 djSP; dTARGET;
a0d0e21e 1017 GV *gv;
2ae324a7 1018 MAGIC *mg;
a0d0e21e
LW		 1019
1020 if (MAXARG <= 0)
3280af22 1021 gv = PL_stdingv;
a0d0e21e
LW		 1022 else
1023 gv = (GV*)POPs;
1024 if (!gv)
3280af22 1025 gv = PL_argvgv;
2ae324a7 1026
33c27489 1027 if (mg = SvTIED_mg((SV*)gv, 'q')) {
54310121 1028 I32 gimme = GIMME_V;
2ae324a7 1029 PUSHMARK(SP);
33c27489 1030 XPUSHs(SvTIED_obj((SV*)gv, mg));
2ae324a7 1031 PUTBACK;
1032 ENTER;
54310121 1033 perl_call_method("GETC", gimme);
2ae324a7 1034 LEAVE;
1035 SPAGAIN;
54310121 1036 if (gimme == G_SCALAR)
1037 SvSetMagicSV_nosteal(TARG, TOPs);
2ae324a7 1038 RETURN;
1039 }
9bc64814 1040 if (!gv || do_eof(gv)) /* make sure we have fp with something */
a0d0e21e 1041 RETPUSHUNDEF;
bbce6d69 1042 TAINT;
a0d0e21e 1043 sv_setpv(TARG, " ");
9bc64814 1044 *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
a0d0e21e
LW		 1045 PUSHTARG;
1046 RETURN;
1047}
1048
1049PP(pp_read)
1050{
1051 return pp_sysread(ARGS);
1052}
1053
76e3520e 1054STATIC OP *
8ac85365 1055doform(CV *cv, GV *gv, OP *retop)
a0d0e21e 1056{
11343788 1057 dTHR;
c09156bb 1058 register PERL_CONTEXT *cx;
54310121 1059 I32 gimme = GIMME_V;
a0d0e21e
LW		 1060 AV* padlist = CvPADLIST(cv);
1061 SV** svp = AvARRAY(padlist);
1062
1063 ENTER;
1064 SAVETMPS;
1065
1066 push_return(retop);
3280af22 1067 PUSHBLOCK(cx, CXt_SUB, PL_stack_sp);
a0d0e21e 1068 PUSHFORMAT(cx);
3280af22
NIS		 1069 SAVESPTR(PL_curpad);
1070 PL_curpad = AvARRAY((AV*)svp[1]);
a0d0e21e 1071
4633a7c4 1072 setdefout(gv); /* locally select filehandle so $% et al work */
a0d0e21e
LW		 1073 return CvSTART(cv);
1074}
1075
1076PP(pp_enterwrite)
1077{
4e35701f 1078 djSP;
a0d0e21e
LW		 1079 register GV *gv;
1080 register IO *io;
1081 GV *fgv;
1082 CV *cv;
1083
1084 if (MAXARG == 0)
3280af22 1085 gv = PL_defoutgv;
a0d0e21e
LW		 1086 else {
1087 gv = (GV*)POPs;
1088 if (!gv)
3280af22 1089 gv = PL_defoutgv;
a0d0e21e
LW		 1090 }
1091 EXTEND(SP, 1);
1092 io = GvIO(gv);
1093 if (!io) {
1094 RETPUSHNO;
1095 }
1096 if (IoFMT_GV(io))
1097 fgv = IoFMT_GV(io);
1098 else
1099 fgv = gv;
1100
1101 cv = GvFORM(fgv);
a0d0e21e
LW		 1102 if (!cv) {
1103 if (fgv) {
748a9306 1104 SV *tmpsv = sv_newmortal();
aac0dd9a 1105 gv_efullname3(tmpsv, fgv, Nullch);
748a9306 1106 DIE("Undefined format \"%s\" called",SvPVX(tmpsv));
a0d0e21e
LW		 1107 }
1108 DIE("Not a format reference");
1109 }
44a8e56a 1110 if (CvCLONE(cv))
1111 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
a0d0e21e 1112
44a8e56a 1113 IoFLAGS(io) &= ~IOf_DIDTOP;
533c011a 1114 return doform(cv,gv,PL_op->op_next);
a0d0e21e
LW		 1115}
1116
1117PP(pp_leavewrite)
1118{
4e35701f 1119 djSP;
a0d0e21e
LW		 1120 GV *gv = cxstack[cxstack_ix].blk_sub.gv;
1121 register IO *io = GvIOp(gv);
760ac839
LW		 1122 PerlIO *ofp = IoOFP(io);
1123 PerlIO *fp;
a0d0e21e
LW		 1124 SV **newsp;
1125 I32 gimme;
c09156bb 1126 register PERL_CONTEXT *cx;
a0d0e21e 1127
760ac839 1128 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
3280af22
NIS		 1129 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1130 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1131 PL_formtarget != PL_toptarget)
a0d0e21e 1132 {
4633a7c4
LW		 1133 GV *fgv;
1134 CV *cv;
a0d0e21e
LW		 1135 if (!IoTOP_GV(io)) {
1136 GV *topgv;
46fc3d4c 1137 SV *topname;
a0d0e21e
LW		 1138
1139 if (!IoTOP_NAME(io)) {
1140 if (!IoFMT_NAME(io))
1141 IoFMT_NAME(io) = savepv(GvNAME(gv));
46fc3d4c 1142 topname = sv_2mortal(newSVpvf("%s_TOP", IoFMT_NAME(io)));
1143 topgv = gv_fetchpv(SvPVX(topname), FALSE, SVt_PVFM);
748a9306 1144 if ((topgv && GvFORM(topgv)) ||
a0d0e21e 1145 !gv_fetchpv("top",FALSE,SVt_PVFM))
46fc3d4c 1146 IoTOP_NAME(io) = savepv(SvPVX(topname));
a0d0e21e
LW		 1147 else
1148 IoTOP_NAME(io) = savepv("top");
1149 }
1150 topgv = gv_fetchpv(IoTOP_NAME(io),FALSE, SVt_PVFM);
1151 if (!topgv || !GvFORM(topgv)) {
1152 IoLINES_LEFT(io) = 100000000;
1153 goto forget_top;
1154 }
1155 IoTOP_GV(io) = topgv;
1156 }
748a9306
LW		 1157 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1158 I32 lines = IoLINES_LEFT(io);
3280af22 1159 char *s = SvPVX(PL_formtarget);
8e07c86e
AD		 1160 if (lines <= 0) /* Yow, header didn't even fit!!! */
1161 goto forget_top;
748a9306
LW		 1162 while (lines-- > 0) {
1163 s = strchr(s, '\n');
1164 if (!s)
1165 break;
1166 s++;
1167 }
1168 if (s) {
3280af22
NIS		 1169 PerlIO_write(ofp, SvPVX(PL_formtarget), s - SvPVX(PL_formtarget));
1170 sv_chop(PL_formtarget, s);
1171 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
748a9306
LW		 1172 }
1173 }
a0d0e21e 1174 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
3280af22 1175 PerlIO_write(ofp, SvPVX(PL_formfeed), SvCUR(PL_formfeed));
a0d0e21e
LW		 1176 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1177 IoPAGE(io)++;
3280af22 1178 PL_formtarget = PL_toptarget;
748a9306 1179 IoFLAGS(io) |= IOf_DIDTOP;
4633a7c4
LW		 1180 fgv = IoTOP_GV(io);
1181 if (!fgv)
1182 DIE("bad top format reference");
1183 cv = GvFORM(fgv);
1184 if (!cv) {
1185 SV *tmpsv = sv_newmortal();
aac0dd9a 1186 gv_efullname3(tmpsv, fgv, Nullch);
4633a7c4
LW		 1187 DIE("Undefined top format \"%s\" called",SvPVX(tmpsv));
1188 }
44a8e56a 1189 if (CvCLONE(cv))
1190 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
533c011a 1191 return doform(cv,gv,PL_op);
a0d0e21e
LW		 1192 }
1193
1194 forget_top:
3280af22 1195 POPBLOCK(cx,PL_curpm);
a0d0e21e
LW		 1196 POPFORMAT(cx);
1197 LEAVE;
1198
1199 fp = IoOFP(io);
1200 if (!fp) {
599cee73 1201 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
a0d0e21e 1202 if (IoIFP(io))
599cee73
PM		 1203 warner(WARN_IO, "Filehandle only opened for input");
1204 else if (ckWARN(WARN_CLOSED))
1205 warner(WARN_CLOSED, "Write on closed filehandle");
a0d0e21e 1206 }
3280af22 1207 PUSHs(&PL_sv_no);
a0d0e21e
LW		 1208 }
1209 else {
3280af22 1210 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
599cee73
PM		 1211 if (ckWARN(WARN_IO))
1212 warner(WARN_IO, "page overflow");
a0d0e21e 1213 }
3280af22 1214 if (!PerlIO_write(ofp, SvPVX(PL_formtarget), SvCUR(PL_formtarget)) ||
760ac839 1215 PerlIO_error(fp))
3280af22 1216 PUSHs(&PL_sv_no);
a0d0e21e 1217 else {
3280af22
NIS		 1218 FmLINES(PL_formtarget) = 0;
1219 SvCUR_set(PL_formtarget, 0);
1220 *SvEND(PL_formtarget) = '\0';
a0d0e21e 1221 if (IoFLAGS(io) & IOf_FLUSH)
760ac839 1222 (void)PerlIO_flush(fp);
3280af22 1223 PUSHs(&PL_sv_yes);
a0d0e21e
LW		 1224 }
1225 }
3280af22 1226 PL_formtarget = PL_bodytarget;
a0d0e21e
LW		 1227 PUTBACK;
1228 return pop_return();
1229}
1230
1231PP(pp_prtf)
1232{
4e35701f 1233 djSP; dMARK; dORIGMARK;
a0d0e21e
LW		 1234 GV *gv;
1235 IO *io;
760ac839 1236 PerlIO *fp;
26db47c4 1237 SV *sv;
46fc3d4c 1238 MAGIC *mg;
2d8e6c8d 1239 STRLEN n_a;
a0d0e21e 1240
533c011a 1241 if (PL_op->op_flags & OPf_STACKED)
a0d0e21e
LW		 1242 gv = (GV*)*++MARK;
1243 else
3280af22 1244 gv = PL_defoutgv;
46fc3d4c 1245
33c27489 1246 if (mg = SvTIED_mg((SV*)gv, 'q')) {
46fc3d4c 1247 if (MARK == ORIGMARK) {
4352c267 1248 MEXTEND(SP, 1);
46fc3d4c 1249 ++MARK;
1250 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1251 ++SP;
1252 }
1253 PUSHMARK(MARK - 1);
33c27489 1254 *MARK = SvTIED_obj((SV*)gv, mg);
46fc3d4c 1255 PUTBACK;
1256 ENTER;
1257 perl_call_method("PRINTF", G_SCALAR);
1258 LEAVE;
1259 SPAGAIN;
1260 MARK = ORIGMARK + 1;
1261 *MARK = *SP;
1262 SP = MARK;
1263 RETURN;
1264 }
1265
26db47c4 1266 sv = NEWSV(0,0);
a0d0e21e 1267 if (!(io = GvIO(gv))) {
599cee73 1268 if (ckWARN(WARN_UNOPENED)) {
aac0dd9a 1269 gv_fullname3(sv, gv, Nullch);
2d8e6c8d 1270 warner(WARN_UNOPENED, "Filehandle %s never opened", SvPV(sv,n_a));
748a9306
LW		 1271 }
1272 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW		 1273 goto just_say_no;
1274 }
1275 else if (!(fp = IoOFP(io))) {
599cee73 1276 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
aac0dd9a 1277 gv_fullname3(sv, gv, Nullch);
a0d0e21e 1278 if (IoIFP(io))
599cee73 1279 warner(WARN_IO, "Filehandle %s opened only for input",
2d8e6c8d 1280 SvPV(sv,n_a));
599cee73
PM		 1281 else if (ckWARN(WARN_CLOSED))
1282 warner(WARN_CLOSED, "printf on closed filehandle %s",
2d8e6c8d 1283 SvPV(sv,n_a));
a0d0e21e 1284 }
748a9306 1285 SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
a0d0e21e
LW		 1286 goto just_say_no;
1287 }
1288 else {
36477c24 1289#ifdef USE_LOCALE_NUMERIC
533c011a 1290 if (PL_op->op_private & OPpLOCALE)
36477c24 1291 SET_NUMERIC_LOCAL();
bbce6d69 1292 else
36477c24 1293 SET_NUMERIC_STANDARD();
1294#endif
a0d0e21e
LW		 1295 do_sprintf(sv, SP - MARK, MARK + 1);
1296 if (!do_print(sv, fp))
1297 goto just_say_no;
1298
1299 if (IoFLAGS(io) & IOf_FLUSH)
760ac839 1300 if (PerlIO_flush(fp) == EOF)
a0d0e21e
LW		 1301 goto just_say_no;
1302 }
1303 SvREFCNT_dec(sv);
1304 SP = ORIGMARK;
3280af22 1305 PUSHs(&PL_sv_yes);
a0d0e21e
LW		 1306 RETURN;
1307
1308 just_say_no:
1309 SvREFCNT_dec(sv);
1310 SP = ORIGMARK;
3280af22 1311 PUSHs(&PL_sv_undef);
a0d0e21e
LW		 1312 RETURN;
1313}
1314
c07a80fd 1315PP(pp_sysopen)
1316{
4e35701f 1317 djSP;
c07a80fd 1318 GV *gv;
c07a80fd 1319 SV *sv;
1320 char *tmps;
1321 STRLEN len;
1322 int mode, perm;
1323
1324 if (MAXARG > 3)
1325 perm = POPi;
1326 else
1327 perm = 0666;
1328 mode = POPi;
1329 sv = POPs;
1330 gv = (GV *)POPs;
1331
1332 tmps = SvPV(sv, len);
1333 if (do_open(gv, tmps, len, TRUE, mode, perm, Nullfp)) {
1334 IoLINES(GvIOp(gv)) = 0;
3280af22 1335 PUSHs(&PL_sv_yes);
c07a80fd 1336 }
1337 else {
3280af22 1338 PUSHs(&PL_sv_undef);
c07a80fd 1339 }
1340 RETURN;
1341}
1342
a0d0e21e
LW		 1343PP(pp_sysread)
1344{
4e35701f 1345 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW		 1346 int offset;
1347 GV *gv;
1348 IO *io;
1349 char *buffer;
5b54f415 1350 SSize_t length;
1e422769 1351 Sock_size_t bufsize;
748a9306 1352 SV *bufsv;
a0d0e21e 1353 STRLEN blen;
2ae324a7 1354 MAGIC *mg;
a0d0e21e
LW		 1355
1356 gv = (GV*)*++MARK;
533c011a 1357 if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD) &&
33c27489 1358 (mg = SvTIED_mg((SV*)gv, 'q')))
137443ea 1359 {
2ae324a7 1360 SV *sv;
1361
1362 PUSHMARK(MARK-1);
33c27489 1363 *MARK = SvTIED_obj((SV*)gv, mg);
2ae324a7 1364 ENTER;
1365 perl_call_method("READ", G_SCALAR);
1366 LEAVE;
1367 SPAGAIN;
1368 sv = POPs;
1369 SP = ORIGMARK;
1370 PUSHs(sv);
1371 RETURN;
1372 }
1373
a0d0e21e
LW		 1374 if (!gv)
1375 goto say_undef;
748a9306 1376 bufsv = *++MARK;
ff68c719 1377 if (! SvOK(bufsv))
1378 sv_setpvn(bufsv, "", 0);
748a9306 1379 buffer = SvPV_force(bufsv, blen);
a0d0e21e
LW		 1380 length = SvIVx(*++MARK);
1381 if (length < 0)
1382 DIE("Negative length");
748a9306 1383 SETERRNO(0,0);
a0d0e21e
LW		 1384 if (MARK < SP)
1385 offset = SvIVx(*++MARK);
1386 else
1387 offset = 0;
1388 io = GvIO(gv);
1389 if (!io || !IoIFP(io))
1390 goto say_undef;
1391#ifdef HAS_SOCKET
533c011a 1392 if (PL_op->op_type == OP_RECV) {
46fc3d4c 1393 char namebuf[MAXPATHLEN];
eec2d3df 1394#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE)
490ab354
JH		 1395 bufsize = sizeof (struct sockaddr_in);
1396#else
46fc3d4c 1397 bufsize = sizeof namebuf;
490ab354 1398#endif
748a9306 1399 buffer = SvGROW(bufsv, length+1);
bbce6d69 1400 /* 'offset' means 'flags' here */
6ad3d225 1401 length = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
46fc3d4c 1402 (struct sockaddr *)namebuf, &bufsize);
a0d0e21e
LW		 1403 if (length < 0)
1404 RETPUSHUNDEF;
748a9306
LW		 1405 SvCUR_set(bufsv, length);
1406 *SvEND(bufsv) = '\0';
1407 (void)SvPOK_only(bufsv);
1408 SvSETMAGIC(bufsv);
aac0dd9a 1409 /* This should not be marked tainted if the fp is marked clean */
bbce6d69 1410 if (!(IoFLAGS(io) & IOf_UNTAINT))
1411 SvTAINTED_on(bufsv);
a0d0e21e 1412 SP = ORIGMARK;
46fc3d4c 1413 sv_setpvn(TARG, namebuf, bufsize);
a0d0e21e
LW		 1414 PUSHs(TARG);
1415 RETURN;
1416 }
1417#else
911d147d 1418 if (PL_op->op_type == OP_RECV)
22c35a8c 1419 DIE(PL_no_sock_func, "recv");
a0d0e21e 1420#endif
bbce6d69 1421 if (offset < 0) {
1422 if (-offset > blen)
1423 DIE("Offset outside string");
1424 offset += blen;
1425 }
cd52b7b2 1426 bufsize = SvCUR(bufsv);
748a9306 1427 buffer = SvGROW(bufsv, length+offset+1);
cd52b7b2 1428 if (offset > bufsize) { /* Zero any newly allocated space */
1429 Zero(buffer+bufsize, offset-bufsize, char);
1430 }
533c011a 1431 if (PL_op->op_type == OP_SYSREAD) {
a7092146
GS		 1432#ifdef PERL_SOCK_SYSREAD_IS_RECV
1433 if (IoTYPE(io) == 's') {
1434 length = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
1435 buffer+offset, length, 0);
1436 }
1437 else
1438#endif
1439 {
1440 length = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
1441 buffer+offset, length);
1442 }
a0d0e21e
LW		 1443 }
1444 else
1445#ifdef HAS_SOCKET__bad_code_maybe
1446 if (IoTYPE(io) == 's') {
46fc3d4c 1447 char namebuf[MAXPATHLEN];
490ab354
JH		 1448#if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
1449 bufsize = sizeof (struct sockaddr_in);
1450#else
46fc3d4c 1451 bufsize = sizeof namebuf;
490ab354 1452#endif
6ad3d225 1453 length = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer+offset, length, 0,
46fc3d4c 1454 (struct sockaddr *)namebuf, &bufsize);
a0d0e21e
LW		 1455 }
1456 else
1457#endif
3b02c43c 1458 {
760ac839 1459 length = PerlIO_read(IoIFP(io), buffer+offset, length);
3b02c43c 1460 /* fread() returns 0 on both error and EOF */
5c7a8c78 1461 if (length == 0 && PerlIO_error(IoIFP(io)))
3b02c43c
GS		 1462 length = -1;
1463 }
a0d0e21e
LW		 1464 if (length < 0)
1465 goto say_undef;
748a9306
LW		 1466 SvCUR_set(bufsv, length+offset);
1467 *SvEND(bufsv) = '\0';
1468 (void)SvPOK_only(bufsv);
1469 SvSETMAGIC(bufsv);
aac0dd9a 1470 /* This should not be marked tainted if the fp is marked clean */
bbce6d69 1471 if (!(IoFLAGS(io) & IOf_UNTAINT))
1472 SvTAINTED_on(bufsv);
a0d0e21e
LW		 1473 SP = ORIGMARK;
1474 PUSHi(length);
1475 RETURN;
1476
1477 say_undef:
1478 SP = ORIGMARK;
1479 RETPUSHUNDEF;
1480}
1481
1482PP(pp_syswrite)
1483{
092bebab
JH		 1484 djSP;
1485 int items = (SP - PL_stack_base) - TOPMARK;
1486 if (items == 2) {
9f089d78 1487 SV *sv;
092bebab 1488 EXTEND(SP, 1);
9f089d78
SB		 1489 sv = sv_2mortal(newSViv(sv_len(*SP)));
1490 PUSHs(sv);
092bebab
JH		 1491 PUTBACK;
1492 }
a0d0e21e
LW		 1493 return pp_send(ARGS);
1494}
1495
1496PP(pp_send)
1497{
4e35701f 1498 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW		 1499 GV *gv;
1500 IO *io;
1501 int offset;
748a9306 1502 SV *bufsv;
a0d0e21e
LW		 1503 char *buffer;
1504 int length;
1505 STRLEN blen;
1d603a67 1506 MAGIC *mg;
a0d0e21e
LW		 1507
1508 gv = (GV*)*++MARK;
33c27489 1509 if (PL_op->op_type == OP_SYSWRITE && (mg = SvTIED_mg((SV*)gv, 'q'))) {
1d603a67
GB		 1510 SV *sv;
1511
1512 PUSHMARK(MARK-1);
33c27489 1513 *MARK = SvTIED_obj((SV*)gv, mg);
1d603a67
GB		 1514 ENTER;
1515 perl_call_method("WRITE", G_SCALAR);
1516 LEAVE;
1517 SPAGAIN;
1518 sv = POPs;
1519 SP = ORIGMARK;
1520 PUSHs(sv);
1521 RETURN;
1522 }
a0d0e21e
LW		 1523 if (!gv)
1524 goto say_undef;
748a9306
LW		 1525 bufsv = *++MARK;
1526 buffer = SvPV(bufsv, blen);
a0d0e21e
LW		 1527 length = SvIVx(*++MARK);
1528 if (length < 0)
1529 DIE("Negative length");
748a9306 1530 SETERRNO(0,0);
a0d0e21e
LW		 1531 io = GvIO(gv);
1532 if (!io || !IoIFP(io)) {
1533 length = -1;
599cee73 1534 if (ckWARN(WARN_CLOSED)) {
533c011a 1535 if (PL_op->op_type == OP_SYSWRITE)
599cee73 1536 warner(WARN_CLOSED, "Syswrite on closed filehandle");
a0d0e21e 1537 else
599cee73 1538 warner(WARN_CLOSED, "Send on closed socket");
a0d0e21e
LW		 1539 }
1540 }
533c011a 1541 else if (PL_op->op_type == OP_SYSWRITE) {
bbce6d69 1542 if (MARK < SP) {
a0d0e21e 1543 offset = SvIVx(*++MARK);
bbce6d69 1544 if (offset < 0) {
1545 if (-offset > blen)
1546 DIE("Offset outside string");
1547 offset += blen;
fb73857a 1548 } else if (offset >= blen && blen > 0)
bbce6d69 1549 DIE("Offset outside string");
1550 } else
a0d0e21e
LW		 1551 offset = 0;
1552 if (length > blen - offset)
1553 length = blen - offset;
a7092146
GS		 1554#ifdef PERL_SOCK_SYSWRITE_IS_SEND
1555 if (IoTYPE(io) == 's') {
1556 length = PerlSock_send(PerlIO_fileno(IoIFP(io)),
1557 buffer+offset, length, 0);
1558 }
1559 else
1560#endif
1561 {
1562 length = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
1563 buffer+offset, length);
1564 }
a0d0e21e
LW		 1565 }
1566#ifdef HAS_SOCKET
1567 else if (SP > MARK) {
1568 char *sockbuf;
1569 STRLEN mlen;
1570 sockbuf = SvPVx(*++MARK, mlen);
6ad3d225 1571 length = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen, length,
a0d0e21e
LW		 1572 (struct sockaddr *)sockbuf, mlen);
1573 }
1574 else
6ad3d225 1575 length = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, length);
490ab354 1576
a0d0e21e
LW		 1577#else
1578 else
22c35a8c 1579 DIE(PL_no_sock_func, "send");
a0d0e21e
LW		 1580#endif
1581 if (length < 0)
1582 goto say_undef;
1583 SP = ORIGMARK;
1584 PUSHi(length);
1585 RETURN;
1586
1587 say_undef:
1588 SP = ORIGMARK;
1589 RETPUSHUNDEF;
1590}
1591
1592PP(pp_recv)
1593{
1594 return pp_sysread(ARGS);
1595}
1596
1597PP(pp_eof)
1598{
4e35701f 1599 djSP;
a0d0e21e
LW		 1600 GV *gv;
1601
1602 if (MAXARG <= 0)
3280af22 1603 gv = PL_last_in_gv;
a0d0e21e 1604 else
3280af22 1605 gv = PL_last_in_gv = (GV*)POPs;
54310121 1606 PUSHs(boolSV(!gv || do_eof(gv)));
a0d0e21e
LW		 1607 RETURN;
1608}
1609
1610PP(pp_tell)
1611{
4e35701f 1612 djSP; dTARGET;
a0d0e21e
LW		 1613 GV *gv;
1614
1615 if (MAXARG <= 0)
3280af22 1616 gv = PL_last_in_gv;
a0d0e21e 1617 else
3280af22 1618 gv = PL_last_in_gv = (GV*)POPs;
a0d0e21e
LW		 1619 PUSHi( do_tell(gv) );
1620 RETURN;
1621}
1622
1623PP(pp_seek)
1624{
137443ea 1625 return pp_sysseek(ARGS);
1626}
1627
1628PP(pp_sysseek)
1629{
4e35701f 1630 djSP;
a0d0e21e
LW		 1631 GV *gv;
1632 int whence = POPi;
97cc44eb 1633 Off_t offset = POPl;
a0d0e21e 1634
3280af22 1635 gv = PL_last_in_gv = (GV*)POPs;
533c011a 1636 if (PL_op->op_type == OP_SEEK)
8903cb82 1637 PUSHs(boolSV(do_seek(gv, offset, whence)));
1638 else {
97cc44eb 1639 Off_t n = do_sysseek(gv, offset, whence);
3280af22 1640 PUSHs((n < 0) ? &PL_sv_undef
8903cb82 1641 : sv_2mortal(n ? newSViv((IV)n)
79cb57f6 1642 : newSVpvn(zero_but_true, ZBTLEN)));
8903cb82 1643 }
a0d0e21e
LW		 1644 RETURN;
1645}
1646
1647PP(pp_truncate)
1648{
4e35701f 1649 djSP;
a0d0e21e
LW		 1650 Off_t len = (Off_t)POPn;
1651 int result = 1;
1652 GV *tmpgv;
2d8e6c8d 1653 STRLEN n_a;
a0d0e21e 1654
748a9306 1655 SETERRNO(0,0);
5d94fbed 1656#if defined(HAS_TRUNCATE) || defined(HAS_CHSIZE) || defined(F_FREESP)
533c011a 1657 if (PL_op->op_flags & OPf_SPECIAL) {
2d8e6c8d 1658 tmpgv = gv_fetchpv(POPpx, FALSE, SVt_PVIO);
cbdc8872 1659 do_ftruncate:
1e422769 1660 TAINT_PROPER("truncate");
a0d0e21e 1661 if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv)) ||
cbdc8872 1662#ifdef HAS_TRUNCATE
760ac839 1663 ftruncate(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
cbdc8872 1664#else
760ac839 1665 my_chsize(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
cbdc8872 1666#endif
a0d0e21e
LW		 1667 result = 0;
1668 }
1669 else {
cbdc8872 1670 SV *sv = POPs;
1e422769 1671 char *name;
2d8e6c8d 1672 STRLEN n_a;
1e422769 1673
cbdc8872 1674 if (SvTYPE(sv) == SVt_PVGV) {
1675 tmpgv = (GV*)sv; /* *main::FRED for example */
1676 goto do_ftruncate;
1677 }
1678 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
1679 tmpgv = (GV*) SvRV(sv); /* \*main::FRED for example */
1680 goto do_ftruncate;
1681 }
1e422769 1682
2d8e6c8d 1683 name = SvPV(sv, n_a);
1e422769 1684 TAINT_PROPER("truncate");
cbdc8872 1685#ifdef HAS_TRUNCATE
1e422769 1686 if (truncate(name, len) < 0)
a0d0e21e 1687 result = 0;
cbdc8872 1688#else
1689 {
1690 int tmpfd;
6ad3d225 1691 if ((tmpfd = PerlLIO_open(name, O_RDWR)) < 0)
bbce6d69 1692 result = 0;
cbdc8872 1693 else {
1694 if (my_chsize(tmpfd, len) < 0)
1695 result = 0;
6ad3d225 1696 PerlLIO_close(tmpfd);
cbdc8872 1697 }
a0d0e21e 1698 }
a0d0e21e 1699#endif
cbdc8872 1700 }
a0d0e21e
LW		 1701
1702 if (result)
1703 RETPUSHYES;
1704 if (!errno)
748a9306 1705 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW		 1706 RETPUSHUNDEF;
1707#else
1708 DIE("truncate not implemented");
1709#endif
1710}
1711
1712PP(pp_fcntl)
1713{
1714 return pp_ioctl(ARGS);
1715}
1716
1717PP(pp_ioctl)
1718{
4e35701f 1719 djSP; dTARGET;
748a9306 1720 SV *argsv = POPs;
a0d0e21e 1721 unsigned int func = U_I(POPn);
533c011a 1722 int optype = PL_op->op_type;
a0d0e21e 1723 char *s;
324aa91a 1724 IV retval;
a0d0e21e
LW		 1725 GV *gv = (GV*)POPs;
1726 IO *io = GvIOn(gv);
1727
748a9306
LW		 1728 if (!io || !argsv || !IoIFP(io)) {
1729 SETERRNO(EBADF,RMS$_IFI); /* well, sort of... */
a0d0e21e
LW		 1730 RETPUSHUNDEF;
1731 }
1732
748a9306 1733 if (SvPOK(argsv) || !SvNIOK(argsv)) {
a0d0e21e 1734 STRLEN len;
324aa91a 1735 STRLEN need;
748a9306 1736 s = SvPV_force(argsv, len);
324aa91a
HF		 1737 need = IOCPARM_LEN(func);
1738 if (len < need) {
1739 s = Sv_Grow(argsv, need + 1);
1740 SvCUR_set(argsv, need);
a0d0e21e
LW		 1741 }
1742
748a9306 1743 s[SvCUR(argsv)] = 17; /* a little sanity check here */
a0d0e21e
LW		 1744 }
1745 else {
748a9306 1746 retval = SvIV(argsv);
a0d0e21e 1747 s = (char*)retval; /* ouch */
a0d0e21e
LW		 1748 }
1749
1750 TAINT_PROPER(optype == OP_IOCTL ? "ioctl" : "fcntl");
1751
1752 if (optype == OP_IOCTL)
1753#ifdef HAS_IOCTL
76e3520e 1754 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
a0d0e21e
LW		 1755#else
1756 DIE("ioctl is not implemented");
1757#endif
1758 else
55497cff 1759#ifdef HAS_FCNTL
1760#if defined(OS2) && defined(__EMX__)
760ac839 1761 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
55497cff 1762#else
760ac839 1763 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
55497cff 1764#endif
1765#else
a0d0e21e 1766 DIE("fcntl is not implemented");
a0d0e21e
LW		 1767#endif
1768
748a9306
LW		 1769 if (SvPOK(argsv)) {
1770 if (s[SvCUR(argsv)] != 17)
a0d0e21e 1771 DIE("Possible memory corruption: %s overflowed 3rd argument",
22c35a8c 1772 PL_op_name[optype]);
748a9306
LW		 1773 s[SvCUR(argsv)] = 0; /* put our null back */
1774 SvSETMAGIC(argsv); /* Assume it has changed */
a0d0e21e
LW		 1775 }
1776
1777 if (retval == -1)
1778 RETPUSHUNDEF;
1779 if (retval != 0) {
1780 PUSHi(retval);
1781 }
1782 else {
8903cb82 1783 PUSHp(zero_but_true, ZBTLEN);
a0d0e21e
LW		 1784 }
1785 RETURN;
1786}
1787
1788PP(pp_flock)
1789{
4e35701f 1790 djSP; dTARGET;
a0d0e21e
LW		 1791 I32 value;
1792 int argtype;
1793 GV *gv;
760ac839 1794 PerlIO *fp;
16d20bd9 1795
ff68c719 1796#ifdef FLOCK
a0d0e21e
LW		 1797 argtype = POPi;
1798 if (MAXARG <= 0)
3280af22 1799 gv = PL_last_in_gv;
a0d0e21e
LW		 1800 else
1801 gv = (GV*)POPs;
1802 if (gv && GvIO(gv))
1803 fp = IoIFP(GvIOp(gv));
1804 else
1805 fp = Nullfp;
1806 if (fp) {
68dc0745 1807 (void)PerlIO_flush(fp);
76e3520e 1808 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
a0d0e21e
LW		 1809 }
1810 else
1811 value = 0;
1812 PUSHi(value);
1813 RETURN;
1814#else
22c35a8c 1815 DIE(PL_no_func, "flock()");
a0d0e21e
LW		 1816#endif
1817}
1818
1819/* Sockets. */
1820
1821PP(pp_socket)
1822{
4e35701f 1823 djSP;
a0d0e21e
LW		 1824#ifdef HAS_SOCKET
1825 GV *gv;
1826 register IO *io;
1827 int protocol = POPi;
1828 int type = POPi;
1829 int domain = POPi;
1830 int fd;
1831
1832 gv = (GV*)POPs;
1833
1834 if (!gv) {
748a9306 1835 SETERRNO(EBADF,LIB$_INVARG);
a0d0e21e
LW		 1836 RETPUSHUNDEF;
1837 }
1838
1839 io = GvIOn(gv);
1840 if (IoIFP(io))
1841 do_close(gv, FALSE);
1842
1843 TAINT_PROPER("socket");
6ad3d225 1844 fd = PerlSock_socket(domain, type, protocol);
a0d0e21e
LW		 1845 if (fd < 0)
1846 RETPUSHUNDEF;
760ac839
LW		 1847 IoIFP(io) = PerlIO_fdopen(fd, "r"); /* stdio gets confused about sockets */
1848 IoOFP(io) = PerlIO_fdopen(fd, "w");
a0d0e21e
LW		 1849 IoTYPE(io) = 's';
1850 if (!IoIFP(io) || !IoOFP(io)) {
760ac839
LW		 1851 if (IoIFP(io)) PerlIO_close(IoIFP(io));
1852 if (IoOFP(io)) PerlIO_close(IoOFP(io));
6ad3d225 1853 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
a0d0e21e
LW		 1854 RETPUSHUNDEF;
1855 }
1856
1857 RETPUSHYES;
1858#else
22c35a8c 1859 DIE(PL_no_sock_func, "socket");
a0d0e21e
LW		 1860#endif
1861}
1862
1863PP(pp_sockpair)
1864{
4e35701f 1865 djSP;
a0d0e21e
LW		 1866#ifdef HAS_SOCKETPAIR
1867 GV *gv1;
1868 GV *gv2;
1869 register IO *io1;
1870 register IO *io2;
1871 int protocol = POPi;
1872 int type = POPi;
1873 int domain = POPi;
1874 int fd[2];
1875
1876 gv2 = (GV*)POPs;
1877 gv1 = (GV*)POPs;
1878 if (!gv1 || !gv2)
1879 RETPUSHUNDEF;
1880
1881 io1 = GvIOn(gv1);
1882 io2 = GvIOn(gv2);
1883 if (IoIFP(io1))
1884 do_close(gv1, FALSE);
1885 if (IoIFP(io2))
1886 do_close(gv2, FALSE);
1887
1888 TAINT_PROPER("socketpair");
6ad3d225 1889 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
a0d0e21e 1890 RETPUSHUNDEF;
760ac839
LW		 1891 IoIFP(io1) = PerlIO_fdopen(fd[0], "r");
1892 IoOFP(io1) = PerlIO_fdopen(fd[0], "w");
a0d0e21e 1893 IoTYPE(io1) = 's';
760ac839
LW		 1894 IoIFP(io2) = PerlIO_fdopen(fd[1], "r");
1895 IoOFP(io2) = PerlIO_fdopen(fd[1], "w");
a0d0e21e
LW		 1896 IoTYPE(io2) = 's';
1897 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
760ac839
LW		 1898 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
1899 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
6ad3d225 1900 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
760ac839
LW		 1901 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
1902 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
6ad3d225 1903 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
a0d0e21e
LW		 1904 RETPUSHUNDEF;
1905 }
1906
1907 RETPUSHYES;
1908#else
22c35a8c 1909 DIE(PL_no_sock_func, "socketpair");
a0d0e21e
LW		 1910#endif
1911}
1912
1913PP(pp_bind)
1914{
4e35701f 1915 djSP;
a0d0e21e 1916#ifdef HAS_SOCKET
eec2d3df
GS		 1917#ifdef MPE /* Requires PRIV mode to bind() to ports < 1024 */
1918 extern GETPRIVMODE();
1919 extern GETUSERMODE();
1920#endif
748a9306 1921 SV *addrsv = POPs;
a0d0e21e
LW		 1922 char *addr;
1923 GV *gv = (GV*)POPs;
1924 register IO *io = GvIOn(gv);
1925 STRLEN len;
eec2d3df
GS		 1926 int bind_ok = 0;
1927#ifdef MPE
1928 int mpeprivmode = 0;
1929#endif
a0d0e21e
LW		 1930
1931 if (!io || !IoIFP(io))
1932 goto nuts;
1933
748a9306 1934 addr = SvPV(addrsv, len);
a0d0e21e 1935 TAINT_PROPER("bind");
eec2d3df
GS		 1936#ifdef MPE /* Deal with MPE bind() peculiarities */
1937 if (((struct sockaddr *)addr)->sa_family == AF_INET) {
1938 /* The address *MUST* stupidly be zero. */
1939 ((struct sockaddr_in *)addr)->sin_addr.s_addr = INADDR_ANY;
1940 /* PRIV mode is required to bind() to ports < 1024. */
1941 if (((struct sockaddr_in *)addr)->sin_port < 1024 &&
1942 ((struct sockaddr_in *)addr)->sin_port > 0) {
1943 GETPRIVMODE(); /* If this fails, we are aborted by MPE/iX. */
1944 mpeprivmode = 1;
1945 }
1946 }
1947#endif /* MPE */
1948 if (PerlSock_bind(PerlIO_fileno(IoIFP(io)),
1949 (struct sockaddr *)addr, len) >= 0)
1950 bind_ok = 1;
1951
1952#ifdef MPE /* Switch back to USER mode */
1953 if (mpeprivmode)
1954 GETUSERMODE();
1955#endif /* MPE */
1956
1957 if (bind_ok)
a0d0e21e
LW		 1958 RETPUSHYES;
1959 else
1960 RETPUSHUNDEF;
1961
1962nuts:
599cee73
PM		 1963 if (ckWARN(WARN_CLOSED))
1964 warner(WARN_CLOSED, "bind() on closed fd");
748a9306 1965 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 1966 RETPUSHUNDEF;
1967#else
22c35a8c 1968 DIE(PL_no_sock_func, "bind");
a0d0e21e
LW		 1969#endif
1970}
1971
1972PP(pp_connect)
1973{
4e35701f 1974 djSP;
a0d0e21e 1975#ifdef HAS_SOCKET
748a9306 1976 SV *addrsv = POPs;
a0d0e21e
LW		 1977 char *addr;
1978 GV *gv = (GV*)POPs;
1979 register IO *io = GvIOn(gv);
1980 STRLEN len;
1981
1982 if (!io || !IoIFP(io))
1983 goto nuts;
1984
748a9306 1985 addr = SvPV(addrsv, len);
a0d0e21e 1986 TAINT_PROPER("connect");
6ad3d225 1987 if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
a0d0e21e
LW		 1988 RETPUSHYES;
1989 else
1990 RETPUSHUNDEF;
1991
1992nuts:
599cee73
PM		 1993 if (ckWARN(WARN_CLOSED))
1994 warner(WARN_CLOSED, "connect() on closed fd");
748a9306 1995 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 1996 RETPUSHUNDEF;
1997#else
22c35a8c 1998 DIE(PL_no_sock_func, "connect");
a0d0e21e
LW		 1999#endif
2000}
2001
2002PP(pp_listen)
2003{
4e35701f 2004 djSP;
a0d0e21e
LW		 2005#ifdef HAS_SOCKET
2006 int backlog = POPi;
2007 GV *gv = (GV*)POPs;
2008 register IO *io = GvIOn(gv);
2009
2010 if (!io || !IoIFP(io))
2011 goto nuts;
2012
6ad3d225 2013 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
a0d0e21e
LW		 2014 RETPUSHYES;
2015 else
2016 RETPUSHUNDEF;
2017
2018nuts:
599cee73
PM		 2019 if (ckWARN(WARN_CLOSED))
2020 warner(WARN_CLOSED, "listen() on closed fd");
748a9306 2021 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2022 RETPUSHUNDEF;
2023#else
22c35a8c 2024 DIE(PL_no_sock_func, "listen");
a0d0e21e
LW		 2025#endif
2026}
2027
2028PP(pp_accept)
2029{
4e35701f 2030 djSP; dTARGET;
a0d0e21e
LW		 2031#ifdef HAS_SOCKET
2032 GV *ngv;
2033 GV *ggv;
2034 register IO *nstio;
2035 register IO *gstio;
4633a7c4 2036 struct sockaddr saddr; /* use a struct to avoid alignment problems */
1e422769 2037 Sock_size_t len = sizeof saddr;
a0d0e21e
LW		 2038 int fd;
2039
2040 ggv = (GV*)POPs;
2041 ngv = (GV*)POPs;
2042
2043 if (!ngv)
2044 goto badexit;
2045 if (!ggv)
2046 goto nuts;
2047
2048 gstio = GvIO(ggv);
2049 if (!gstio || !IoIFP(gstio))
2050 goto nuts;
2051
2052 nstio = GvIOn(ngv);
2053 if (IoIFP(nstio))
2054 do_close(ngv, FALSE);
2055
6ad3d225 2056 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *)&saddr, &len);
a0d0e21e
LW		 2057 if (fd < 0)
2058 goto badexit;
760ac839
LW		 2059 IoIFP(nstio) = PerlIO_fdopen(fd, "r");
2060 IoOFP(nstio) = PerlIO_fdopen(fd, "w");
a0d0e21e
LW		 2061 IoTYPE(nstio) = 's';
2062 if (!IoIFP(nstio) || !IoOFP(nstio)) {
760ac839
LW		 2063 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2064 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
6ad3d225 2065 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
a0d0e21e
LW		 2066 goto badexit;
2067 }
2068
748a9306 2069 PUSHp((char *)&saddr, len);
a0d0e21e
LW		 2070 RETURN;
2071
2072nuts:
599cee73
PM		 2073 if (ckWARN(WARN_CLOSED))
2074 warner(WARN_CLOSED, "accept() on closed fd");
748a9306 2075 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2076
2077badexit:
2078 RETPUSHUNDEF;
2079
2080#else
22c35a8c 2081 DIE(PL_no_sock_func, "accept");
a0d0e21e
LW		 2082#endif
2083}
2084
2085PP(pp_shutdown)
2086{
4e35701f 2087 djSP; dTARGET;
a0d0e21e
LW		 2088#ifdef HAS_SOCKET
2089 int how = POPi;
2090 GV *gv = (GV*)POPs;
2091 register IO *io = GvIOn(gv);
2092
2093 if (!io || !IoIFP(io))
2094 goto nuts;
2095
6ad3d225 2096 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
a0d0e21e
LW		 2097 RETURN;
2098
2099nuts:
599cee73
PM		 2100 if (ckWARN(WARN_CLOSED))
2101 warner(WARN_CLOSED, "shutdown() on closed fd");
748a9306 2102 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2103 RETPUSHUNDEF;
2104#else
22c35a8c 2105 DIE(PL_no_sock_func, "shutdown");
a0d0e21e
LW		 2106#endif
2107}
2108
2109PP(pp_gsockopt)
2110{
2111#ifdef HAS_SOCKET
2112 return pp_ssockopt(ARGS);
2113#else
22c35a8c 2114 DIE(PL_no_sock_func, "getsockopt");
a0d0e21e
LW		 2115#endif
2116}
2117
2118PP(pp_ssockopt)
2119{
4e35701f 2120 djSP;
a0d0e21e 2121#ifdef HAS_SOCKET
533c011a 2122 int optype = PL_op->op_type;
a0d0e21e
LW		 2123 SV *sv;
2124 int fd;
2125 unsigned int optname;
2126 unsigned int lvl;
2127 GV *gv;
2128 register IO *io;
1e422769 2129 Sock_size_t len;
a0d0e21e
LW		 2130
2131 if (optype == OP_GSOCKOPT)
2132 sv = sv_2mortal(NEWSV(22, 257));
2133 else
2134 sv = POPs;
2135 optname = (unsigned int) POPi;
2136 lvl = (unsigned int) POPi;
2137
2138 gv = (GV*)POPs;
2139 io = GvIOn(gv);
2140 if (!io || !IoIFP(io))
2141 goto nuts;
2142
760ac839 2143 fd = PerlIO_fileno(IoIFP(io));
a0d0e21e
LW		 2144 switch (optype) {
2145 case OP_GSOCKOPT:
748a9306 2146 SvGROW(sv, 257);
a0d0e21e 2147 (void)SvPOK_only(sv);
748a9306
LW		 2148 SvCUR_set(sv,256);
2149 *SvEND(sv) ='\0';
1e422769 2150 len = SvCUR(sv);
6ad3d225 2151 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
a0d0e21e 2152 goto nuts2;
1e422769 2153 SvCUR_set(sv, len);
748a9306 2154 *SvEND(sv) ='\0';
a0d0e21e
LW		 2155 PUSHs(sv);
2156 break;
2157 case OP_SSOCKOPT: {
1e422769 2158 char *buf;
2159 int aint;
2160 if (SvPOKp(sv)) {
2d8e6c8d
GS		 2161 STRLEN l;
2162 buf = SvPV(sv, l);
2163 len = l;
1e422769 2164 }
56ee1660 2165 else {
a0d0e21e
LW		 2166 aint = (int)SvIV(sv);
2167 buf = (char*)&aint;
2168 len = sizeof(int);
2169 }
6ad3d225 2170 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
a0d0e21e 2171 goto nuts2;
3280af22 2172 PUSHs(&PL_sv_yes);
a0d0e21e
LW		 2173 }
2174 break;
2175 }
2176 RETURN;
2177
2178nuts:
599cee73
PM		 2179 if (ckWARN(WARN_CLOSED))
2180 warner(WARN_CLOSED, "[gs]etsockopt() on closed fd");
748a9306 2181 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2182nuts2:
2183 RETPUSHUNDEF;
2184
2185#else
22c35a8c 2186 DIE(PL_no_sock_func, "setsockopt");
a0d0e21e
LW		 2187#endif
2188}
2189
2190PP(pp_getsockname)
2191{
2192#ifdef HAS_SOCKET
2193 return pp_getpeername(ARGS);
2194#else
22c35a8c 2195 DIE(PL_no_sock_func, "getsockname");
a0d0e21e
LW		 2196#endif
2197}
2198
2199PP(pp_getpeername)
2200{
4e35701f 2201 djSP;
a0d0e21e 2202#ifdef HAS_SOCKET
533c011a 2203 int optype = PL_op->op_type;
a0d0e21e
LW		 2204 SV *sv;
2205 int fd;
2206 GV *gv = (GV*)POPs;
2207 register IO *io = GvIOn(gv);
1e422769 2208 Sock_size_t len;
a0d0e21e
LW		 2209
2210 if (!io || !IoIFP(io))
2211 goto nuts;
2212
2213 sv = sv_2mortal(NEWSV(22, 257));
748a9306 2214 (void)SvPOK_only(sv);
1e422769 2215 len = 256;
2216 SvCUR_set(sv, len);
748a9306 2217 *SvEND(sv) ='\0';
760ac839 2218 fd = PerlIO_fileno(IoIFP(io));
a0d0e21e
LW		 2219 switch (optype) {
2220 case OP_GETSOCKNAME:
6ad3d225 2221 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
a0d0e21e
LW		 2222 goto nuts2;
2223 break;
2224 case OP_GETPEERNAME:
6ad3d225 2225 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
a0d0e21e 2226 goto nuts2;
490ab354
JH		 2227#if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2228 {
2229 static const char nowhere[] = "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0";
2230 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2231 if (((struct sockaddr *)SvPVX(sv))->sa_family == AF_INET &&
2232 !memcmp((char *)SvPVX(sv) + sizeof(u_short), nowhere,
2233 sizeof(u_short) + sizeof(struct in_addr))) {
2234 goto nuts2;
2235 }
2236 }
2237#endif
a0d0e21e
LW		 2238 break;
2239 }
13826f2c
CS		 2240#ifdef BOGUS_GETNAME_RETURN
2241 /* Interactive Unix, getpeername() and getsockname()
2242 does not return valid namelen */
1e422769 2243 if (len == BOGUS_GETNAME_RETURN)
2244 len = sizeof(struct sockaddr);
13826f2c 2245#endif
1e422769 2246 SvCUR_set(sv, len);
748a9306 2247 *SvEND(sv) ='\0';
a0d0e21e
LW		 2248 PUSHs(sv);
2249 RETURN;
2250
2251nuts:
599cee73
PM		 2252 if (ckWARN(WARN_CLOSED))
2253 warner(WARN_CLOSED, "get{sock, peer}name() on closed fd");
748a9306 2254 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2255nuts2:
2256 RETPUSHUNDEF;
2257
2258#else
22c35a8c 2259 DIE(PL_no_sock_func, "getpeername");
a0d0e21e
LW		 2260#endif
2261}
2262
2263/* Stat calls. */
2264
2265PP(pp_lstat)
2266{
2267 return pp_stat(ARGS);
2268}
2269
2270PP(pp_stat)
2271{
4e35701f 2272 djSP;
a0d0e21e 2273 GV *tmpgv;
54310121 2274 I32 gimme;
a0d0e21e 2275 I32 max = 13;
2d8e6c8d 2276 STRLEN n_a;
a0d0e21e 2277
533c011a 2278 if (PL_op->op_flags & OPf_REF) {
a0d0e21e 2279 tmpgv = cGVOP->op_gv;
748a9306 2280 do_fstat:
3280af22
NIS		 2281 if (tmpgv != PL_defgv) {
2282 PL_laststype = OP_STAT;
2283 PL_statgv = tmpgv;
2284 sv_setpv(PL_statname, "");
2285 PL_laststatval = (GvIO(tmpgv) && IoIFP(GvIOp(tmpgv))
2286 ? PerlLIO_fstat(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), &PL_statcache) : -1);
a0d0e21e 2287 }
3280af22 2288 if (PL_laststatval < 0)
a0d0e21e
LW		 2289 max = 0;
2290 }
2291 else {
748a9306
LW		 2292 SV* sv = POPs;
2293 if (SvTYPE(sv) == SVt_PVGV) {
2294 tmpgv = (GV*)sv;
2295 goto do_fstat;
2296 }
2297 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2298 tmpgv = (GV*)SvRV(sv);
2299 goto do_fstat;
2300 }
2d8e6c8d 2301 sv_setpv(PL_statname, SvPV(sv,n_a));
3280af22 2302 PL_statgv = Nullgv;
a0d0e21e 2303#ifdef HAS_LSTAT
533c011a
NIS		 2304 PL_laststype = PL_op->op_type;
2305 if (PL_op->op_type == OP_LSTAT)
2d8e6c8d 2306 PL_laststatval = PerlLIO_lstat(SvPV(PL_statname, n_a), &PL_statcache);
a0d0e21e
LW		 2307 else
2308#endif
2d8e6c8d 2309 PL_laststatval = PerlLIO_stat(SvPV(PL_statname, n_a), &PL_statcache);
3280af22 2310 if (PL_laststatval < 0) {
2d8e6c8d 2311 if (ckWARN(WARN_NEWLINE) && strchr(SvPV(PL_statname, n_a), '\n'))
22c35a8c 2312 warner(WARN_NEWLINE, PL_warn_nl, "stat");
a0d0e21e
LW		 2313 max = 0;
2314 }
2315 }
2316
54310121 2317 gimme = GIMME_V;
2318 if (gimme != G_ARRAY) {
2319 if (gimme != G_VOID)
2320 XPUSHs(boolSV(max));
2321 RETURN;
a0d0e21e
LW		 2322 }
2323 if (max) {
36477c24 2324 EXTEND(SP, max);
2325 EXTEND_MORTAL(max);
3280af22
NIS		 2326 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_dev)));
2327 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_ino)));
2328 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_mode)));
2329 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_nlink)));
2330 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_uid)));
2331 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_gid)));
cbdc8872 2332#ifdef USE_STAT_RDEV
3280af22 2333 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_rdev)));
cbdc8872 2334#else
79cb57f6 2335 PUSHs(sv_2mortal(newSVpvn("", 0)));
cbdc8872 2336#endif
3280af22 2337 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_size)));
cbdc8872 2338#ifdef BIG_TIME
6b88bc9c
GS		 2339 PUSHs(sv_2mortal(newSVnv((U32)PL_statcache.st_atime)));
2340 PUSHs(sv_2mortal(newSVnv((U32)PL_statcache.st_mtime)));
2341 PUSHs(sv_2mortal(newSVnv((U32)PL_statcache.st_ctime)));
cbdc8872 2342#else
3280af22
NIS		 2343 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_atime)));
2344 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_mtime)));
2345 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_ctime)));
cbdc8872 2346#endif
a0d0e21e 2347#ifdef USE_STAT_BLOCKS
3280af22
NIS		 2348 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_blksize)));
2349 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_blocks)));
a0d0e21e 2350#else
79cb57f6
GS		 2351 PUSHs(sv_2mortal(newSVpvn("", 0)));
2352 PUSHs(sv_2mortal(newSVpvn("", 0)));
a0d0e21e
LW		 2353#endif
2354 }
2355 RETURN;
2356}
2357
2358PP(pp_ftrread)
2359{
5ff3f7a4 2360 I32 result;
4e35701f 2361 djSP;
5ff3f7a4 2362#if defined(HAS_ACCESS) && defined(R_OK)
2d8e6c8d 2363 STRLEN n_a;
5ff3f7a4 2364 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2365 result = access(TOPpx, R_OK);
5ff3f7a4
GS		 2366 if (result == 0)
2367 RETPUSHYES;
2368 if (result < 0)
2369 RETPUSHUNDEF;
2370 RETPUSHNO;
22865c03
GS		 2371 }
2372 else
5ff3f7a4
GS		 2373 result = my_stat(ARGS);
2374#else
2375 result = my_stat(ARGS);
2376#endif
22865c03 2377 SPAGAIN;
a0d0e21e
LW		 2378 if (result < 0)
2379 RETPUSHUNDEF;
3280af22 2380 if (cando(S_IRUSR, 0, &PL_statcache))
a0d0e21e
LW		 2381 RETPUSHYES;
2382 RETPUSHNO;
2383}
2384
2385PP(pp_ftrwrite)
2386{
5ff3f7a4 2387 I32 result;
4e35701f 2388 djSP;
5ff3f7a4 2389#if defined(HAS_ACCESS) && defined(W_OK)
2d8e6c8d 2390 STRLEN n_a;
5ff3f7a4 2391 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2392 result = access(TOPpx, W_OK);
5ff3f7a4
GS		 2393 if (result == 0)
2394 RETPUSHYES;
2395 if (result < 0)
2396 RETPUSHUNDEF;
2397 RETPUSHNO;
22865c03
GS		 2398 }
2399 else
5ff3f7a4
GS		 2400 result = my_stat(ARGS);
2401#else
2402 result = my_stat(ARGS);
2403#endif
22865c03 2404 SPAGAIN;
a0d0e21e
LW		 2405 if (result < 0)
2406 RETPUSHUNDEF;
3280af22 2407 if (cando(S_IWUSR, 0, &PL_statcache))
a0d0e21e
LW		 2408 RETPUSHYES;
2409 RETPUSHNO;
2410}
2411
2412PP(pp_ftrexec)
2413{
5ff3f7a4 2414 I32 result;
4e35701f 2415 djSP;
5ff3f7a4 2416#if defined(HAS_ACCESS) && defined(X_OK)
2d8e6c8d 2417 STRLEN n_a;
5ff3f7a4 2418 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2419 result = access(TOPpx, X_OK);
5ff3f7a4
GS		 2420 if (result == 0)
2421 RETPUSHYES;
2422 if (result < 0)
2423 RETPUSHUNDEF;
2424 RETPUSHNO;
22865c03
GS		 2425 }
2426 else
5ff3f7a4
GS		 2427 result = my_stat(ARGS);
2428#else
2429 result = my_stat(ARGS);
2430#endif
22865c03 2431 SPAGAIN;
a0d0e21e
LW		 2432 if (result < 0)
2433 RETPUSHUNDEF;
3280af22 2434 if (cando(S_IXUSR, 0, &PL_statcache))
a0d0e21e
LW		 2435 RETPUSHYES;
2436 RETPUSHNO;
2437}
2438
2439PP(pp_fteread)
2440{
5ff3f7a4 2441 I32 result;
4e35701f 2442 djSP;
5ff3f7a4 2443#ifdef PERL_EFF_ACCESS_R_OK
2d8e6c8d 2444 STRLEN n_a;
5ff3f7a4 2445 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2446 result = PERL_EFF_ACCESS_R_OK(TOPpx);
5ff3f7a4
GS		 2447 if (result == 0)
2448 RETPUSHYES;
2449 if (result < 0)
2450 RETPUSHUNDEF;
2451 RETPUSHNO;
22865c03
GS		 2452 }
2453 else
5ff3f7a4
GS		 2454 result = my_stat(ARGS);
2455#else
2456 result = my_stat(ARGS);
2457#endif
22865c03 2458 SPAGAIN;
a0d0e21e
LW		 2459 if (result < 0)
2460 RETPUSHUNDEF;
3280af22 2461 if (cando(S_IRUSR, 1, &PL_statcache))
a0d0e21e
LW		 2462 RETPUSHYES;
2463 RETPUSHNO;
2464}
2465
2466PP(pp_ftewrite)
2467{
5ff3f7a4 2468 I32 result;
4e35701f 2469 djSP;
5ff3f7a4 2470#ifdef PERL_EFF_ACCESS_W_OK
2d8e6c8d 2471 STRLEN n_a;
5ff3f7a4 2472 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2473 result = PERL_EFF_ACCESS_W_OK(TOPpx);
5ff3f7a4
GS		 2474 if (result == 0)
2475 RETPUSHYES;
2476 if (result < 0)
2477 RETPUSHUNDEF;
2478 RETPUSHNO;
22865c03
GS		 2479 }
2480 else
5ff3f7a4
GS		 2481 result = my_stat(ARGS);
2482#else
2483 result = my_stat(ARGS);
2484#endif
22865c03 2485 SPAGAIN;
a0d0e21e
LW		 2486 if (result < 0)
2487 RETPUSHUNDEF;
3280af22 2488 if (cando(S_IWUSR, 1, &PL_statcache))
a0d0e21e
LW		 2489 RETPUSHYES;
2490 RETPUSHNO;
2491}
2492
2493PP(pp_fteexec)
2494{
5ff3f7a4 2495 I32 result;
4e35701f 2496 djSP;
5ff3f7a4 2497#ifdef PERL_EFF_ACCESS_X_OK
2d8e6c8d 2498 STRLEN n_a;
5ff3f7a4 2499 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2500 result = PERL_EFF_ACCESS_X_OK(TOPpx);
5ff3f7a4
GS		 2501 if (result == 0)
2502 RETPUSHYES;
2503 if (result < 0)
2504 RETPUSHUNDEF;
2505 RETPUSHNO;
22865c03
GS		 2506 }
2507 else
5ff3f7a4
GS		 2508 result = my_stat(ARGS);
2509#else
2510 result = my_stat(ARGS);
2511#endif
22865c03 2512 SPAGAIN;
a0d0e21e
LW		 2513 if (result < 0)
2514 RETPUSHUNDEF;
3280af22 2515 if (cando(S_IXUSR, 1, &PL_statcache))
a0d0e21e
LW		 2516 RETPUSHYES;
2517 RETPUSHNO;
2518}
2519
2520PP(pp_ftis)
2521{
2522 I32 result = my_stat(ARGS);
4e35701f 2523 djSP;
a0d0e21e
LW		 2524 if (result < 0)
2525 RETPUSHUNDEF;
2526 RETPUSHYES;
2527}
2528
2529PP(pp_fteowned)
2530{
2531 return pp_ftrowned(ARGS);
2532}
2533
2534PP(pp_ftrowned)
2535{
2536 I32 result = my_stat(ARGS);
4e35701f 2537 djSP;
a0d0e21e
LW		 2538 if (result < 0)
2539 RETPUSHUNDEF;
533c011a 2540 if (PL_statcache.st_uid == (PL_op->op_type == OP_FTEOWNED ? PL_euid : PL_uid) )
a0d0e21e
LW		 2541 RETPUSHYES;
2542 RETPUSHNO;
2543}
2544
2545PP(pp_ftzero)
2546{
2547 I32 result = my_stat(ARGS);
4e35701f 2548 djSP;
a0d0e21e
LW		 2549 if (result < 0)
2550 RETPUSHUNDEF;
3280af22 2551 if (!PL_statcache.st_size)
a0d0e21e
LW		 2552 RETPUSHYES;
2553 RETPUSHNO;
2554}
2555
2556PP(pp_ftsize)
2557{
2558 I32 result = my_stat(ARGS);
4e35701f 2559 djSP; dTARGET;
a0d0e21e
LW		 2560 if (result < 0)
2561 RETPUSHUNDEF;
3280af22 2562 PUSHi(PL_statcache.st_size);
a0d0e21e
LW		 2563 RETURN;
2564}
2565
2566PP(pp_ftmtime)
2567{
2568 I32 result = my_stat(ARGS);
4e35701f 2569 djSP; dTARGET;
a0d0e21e
LW		 2570 if (result < 0)
2571 RETPUSHUNDEF;
3280af22 2572 PUSHn( ((I32)PL_basetime - (I32)PL_statcache.st_mtime) / 86400.0 );
a0d0e21e
LW		 2573 RETURN;
2574}
2575
2576PP(pp_ftatime)
2577{
2578 I32 result = my_stat(ARGS);
4e35701f 2579 djSP; dTARGET;
a0d0e21e
LW		 2580 if (result < 0)
2581 RETPUSHUNDEF;
3280af22 2582 PUSHn( ((I32)PL_basetime - (I32)PL_statcache.st_atime) / 86400.0 );
a0d0e21e
LW		 2583 RETURN;
2584}
2585
2586PP(pp_ftctime)
2587{
2588 I32 result = my_stat(ARGS);
4e35701f 2589 djSP; dTARGET;
a0d0e21e
LW		 2590 if (result < 0)
2591 RETPUSHUNDEF;
3280af22 2592 PUSHn( ((I32)PL_basetime - (I32)PL_statcache.st_ctime) / 86400.0 );
a0d0e21e
LW		 2593 RETURN;
2594}
2595
2596PP(pp_ftsock)
2597{
2598 I32 result = my_stat(ARGS);
4e35701f 2599 djSP;
a0d0e21e
LW		 2600 if (result < 0)
2601 RETPUSHUNDEF;
3280af22 2602 if (S_ISSOCK(PL_statcache.st_mode))
a0d0e21e
LW		 2603 RETPUSHYES;
2604 RETPUSHNO;
2605}
2606
2607PP(pp_ftchr)
2608{
2609 I32 result = my_stat(ARGS);
4e35701f 2610 djSP;
a0d0e21e
LW		 2611 if (result < 0)
2612 RETPUSHUNDEF;
3280af22 2613 if (S_ISCHR(PL_statcache.st_mode))
a0d0e21e
LW		 2614 RETPUSHYES;
2615 RETPUSHNO;
2616}
2617
2618PP(pp_ftblk)
2619{
2620 I32 result = my_stat(ARGS);
4e35701f 2621 djSP;
a0d0e21e
LW		 2622 if (result < 0)
2623 RETPUSHUNDEF;
3280af22 2624 if (S_ISBLK(PL_statcache.st_mode))
a0d0e21e
LW		 2625 RETPUSHYES;
2626 RETPUSHNO;
2627}
2628
2629PP(pp_ftfile)
2630{
2631 I32 result = my_stat(ARGS);
4e35701f 2632 djSP;
a0d0e21e
LW		 2633 if (result < 0)
2634 RETPUSHUNDEF;
3280af22 2635 if (S_ISREG(PL_statcache.st_mode))
a0d0e21e
LW		 2636 RETPUSHYES;
2637 RETPUSHNO;
2638}
2639
2640PP(pp_ftdir)
2641{
2642 I32 result = my_stat(ARGS);
4e35701f 2643 djSP;
a0d0e21e
LW		 2644 if (result < 0)
2645 RETPUSHUNDEF;
3280af22 2646 if (S_ISDIR(PL_statcache.st_mode))
a0d0e21e
LW		 2647 RETPUSHYES;
2648 RETPUSHNO;
2649}
2650
2651PP(pp_ftpipe)
2652{
2653 I32 result = my_stat(ARGS);
4e35701f 2654 djSP;
a0d0e21e
LW		 2655 if (result < 0)
2656 RETPUSHUNDEF;
3280af22 2657 if (S_ISFIFO(PL_statcache.st_mode))
a0d0e21e
LW		 2658 RETPUSHYES;
2659 RETPUSHNO;
2660}
2661
2662PP(pp_ftlink)
2663{
2664 I32 result = my_lstat(ARGS);
4e35701f 2665 djSP;
a0d0e21e
LW		 2666 if (result < 0)
2667 RETPUSHUNDEF;
3280af22 2668 if (S_ISLNK(PL_statcache.st_mode))
a0d0e21e
LW		 2669 RETPUSHYES;
2670 RETPUSHNO;
2671}
2672
2673PP(pp_ftsuid)
2674{
4e35701f 2675 djSP;
a0d0e21e
LW		 2676#ifdef S_ISUID
2677 I32 result = my_stat(ARGS);
2678 SPAGAIN;
2679 if (result < 0)
2680 RETPUSHUNDEF;
3280af22 2681 if (PL_statcache.st_mode & S_ISUID)
a0d0e21e
LW		 2682 RETPUSHYES;
2683#endif
2684 RETPUSHNO;
2685}
2686
2687PP(pp_ftsgid)
2688{
4e35701f 2689 djSP;
a0d0e21e
LW		 2690#ifdef S_ISGID
2691 I32 result = my_stat(ARGS);
2692 SPAGAIN;
2693 if (result < 0)
2694 RETPUSHUNDEF;
3280af22 2695 if (PL_statcache.st_mode & S_ISGID)
a0d0e21e
LW		 2696 RETPUSHYES;
2697#endif
2698 RETPUSHNO;
2699}
2700
2701PP(pp_ftsvtx)
2702{
4e35701f 2703 djSP;
a0d0e21e
LW		 2704#ifdef S_ISVTX
2705 I32 result = my_stat(ARGS);
2706 SPAGAIN;
2707 if (result < 0)
2708 RETPUSHUNDEF;
3280af22 2709 if (PL_statcache.st_mode & S_ISVTX)
a0d0e21e
LW		 2710 RETPUSHYES;
2711#endif
2712 RETPUSHNO;
2713}
2714
2715PP(pp_fttty)
2716{
4e35701f 2717 djSP;
a0d0e21e
LW		 2718 int fd;
2719 GV *gv;
fb73857a 2720 char *tmps = Nullch;
2d8e6c8d 2721 STRLEN n_a;
fb73857a 2722
533c011a 2723 if (PL_op->op_flags & OPf_REF)
a0d0e21e 2724 gv = cGVOP->op_gv;
fb73857a 2725 else if (isGV(TOPs))
2726 gv = (GV*)POPs;
2727 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
2728 gv = (GV*)SvRV(POPs);
a0d0e21e 2729 else
2d8e6c8d 2730 gv = gv_fetchpv(tmps = POPpx, FALSE, SVt_PVIO);
fb73857a 2731
a0d0e21e 2732 if (GvIO(gv) && IoIFP(GvIOp(gv)))
760ac839 2733 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
fb73857a 2734 else if (tmps && isDIGIT(*tmps))
a0d0e21e
LW		 2735 fd = atoi(tmps);
2736 else
2737 RETPUSHUNDEF;
6ad3d225 2738 if (PerlLIO_isatty(fd))
a0d0e21e
LW		 2739 RETPUSHYES;
2740 RETPUSHNO;
2741}
2742
16d20bd9
AD		 2743#if defined(atarist) /* this will work with atariST. Configure will
2744 make guesses for other systems. */
2745# define FILE_base(f) ((f)->_base)
2746# define FILE_ptr(f) ((f)->_ptr)
2747# define FILE_cnt(f) ((f)->_cnt)
2748# define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
a0d0e21e
LW		 2749#endif
2750
2751PP(pp_fttext)
2752{
4e35701f 2753 djSP;
a0d0e21e
LW		 2754 I32 i;
2755 I32 len;
2756 I32 odd = 0;
2757 STDCHAR tbuf[512];
2758 register STDCHAR *s;
2759 register IO *io;
5f05dabc 2760 register SV *sv;
2761 GV *gv;
2d8e6c8d 2762 STRLEN n_a;
a0d0e21e 2763
533c011a 2764 if (PL_op->op_flags & OPf_REF)
5f05dabc 2765 gv = cGVOP->op_gv;
2766 else if (isGV(TOPs))
2767 gv = (GV*)POPs;
2768 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
2769 gv = (GV*)SvRV(POPs);
2770 else
2771 gv = Nullgv;
2772
2773 if (gv) {
a0d0e21e 2774 EXTEND(SP, 1);
3280af22
NIS		 2775 if (gv == PL_defgv) {
2776 if (PL_statgv)
2777 io = GvIO(PL_statgv);
a0d0e21e 2778 else {
3280af22 2779 sv = PL_statname;
a0d0e21e
LW		 2780 goto really_filename;
2781 }
2782 }
2783 else {
3280af22
NIS		 2784 PL_statgv = gv;
2785 PL_laststatval = -1;
2786 sv_setpv(PL_statname, "");
2787 io = GvIO(PL_statgv);
a0d0e21e
LW		 2788 }
2789 if (io && IoIFP(io)) {
5f05dabc 2790 if (! PerlIO_has_base(IoIFP(io)))
2791 DIE("-T and -B not implemented on filehandles");
3280af22
NIS		 2792 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
2793 if (PL_laststatval < 0)
5f05dabc 2794 RETPUSHUNDEF;
3280af22 2795 if (S_ISDIR(PL_statcache.st_mode)) /* handle NFS glitch */
533c011a 2796 if (PL_op->op_type == OP_FTTEXT)
a0d0e21e
LW		 2797 RETPUSHNO;
2798 else
2799 RETPUSHYES;
760ac839
LW		 2800 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
2801 i = PerlIO_getc(IoIFP(io));
a0d0e21e 2802 if (i != EOF)
760ac839 2803 (void)PerlIO_ungetc(IoIFP(io),i);
a0d0e21e 2804 }
760ac839 2805 if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
a0d0e21e 2806 RETPUSHYES;
760ac839
LW		 2807 len = PerlIO_get_bufsiz(IoIFP(io));
2808 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
2809 /* sfio can have large buffers - limit to 512 */
2810 if (len > 512)
2811 len = 512;
a0d0e21e
LW		 2812 }
2813 else {
599cee73
PM		 2814 if (ckWARN(WARN_UNOPENED))
2815 warner(WARN_UNOPENED, "Test on unopened file <%s>",
a0d0e21e 2816 GvENAME(cGVOP->op_gv));
748a9306 2817 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW		 2818 RETPUSHUNDEF;
2819 }
2820 }
2821 else {
2822 sv = POPs;
5f05dabc 2823 really_filename:
3280af22
NIS		 2824 PL_statgv = Nullgv;
2825 PL_laststatval = -1;
2d8e6c8d 2826 sv_setpv(PL_statname, SvPV(sv, n_a));
a0d0e21e 2827#ifdef HAS_OPEN3
2d8e6c8d 2828 i = PerlLIO_open3(SvPV(sv, n_a), O_RDONLY, 0);
a0d0e21e 2829#else
2d8e6c8d 2830 i = PerlLIO_open(SvPV(sv, n_a), 0);
a0d0e21e
LW		 2831#endif
2832 if (i < 0) {
2d8e6c8d 2833 if (ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, n_a), '\n'))
22c35a8c 2834 warner(WARN_NEWLINE, PL_warn_nl, "open");
a0d0e21e
LW		 2835 RETPUSHUNDEF;
2836 }
3280af22
NIS		 2837 PL_laststatval = PerlLIO_fstat(i, &PL_statcache);
2838 if (PL_laststatval < 0)
5f05dabc 2839 RETPUSHUNDEF;
6ad3d225
GS		 2840 len = PerlLIO_read(i, tbuf, 512);
2841 (void)PerlLIO_close(i);
a0d0e21e 2842 if (len <= 0) {
533c011a 2843 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
a0d0e21e
LW		 2844 RETPUSHNO; /* special case NFS directories */
2845 RETPUSHYES; /* null file is anything */
2846 }
2847 s = tbuf;
2848 }
2849
2850 /* now scan s to look for textiness */
4633a7c4 2851 /* XXX ASCII dependent code */
a0d0e21e
LW		 2852
2853 for (i = 0; i < len; i++, s++) {
2854 if (!*s) { /* null never allowed in text */
2855 odd += len;
2856 break;
2857 }
9d116dd7
JH		 2858#ifdef EBCDIC
2859 else if (!(isPRINT(*s) || isSPACE(*s)))
2860 odd++;
2861#else
a0d0e21e
LW		 2862 else if (*s & 128)
2863 odd++;
2864 else if (*s < 32 &&
2865 *s != '\n' && *s != '\r' && *s != '\b' &&
2866 *s != '\t' && *s != '\f' && *s != 27)
2867 odd++;
9d116dd7 2868#endif
a0d0e21e
LW		 2869 }
2870
533c011a 2871 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
a0d0e21e
LW		 2872 RETPUSHNO;
2873 else
2874 RETPUSHYES;
2875}
2876
2877PP(pp_ftbinary)
2878{
2879 return pp_fttext(ARGS);
2880}
2881
2882/* File calls. */
2883
2884PP(pp_chdir)
2885{
4e35701f 2886 djSP; dTARGET;
a0d0e21e
LW		 2887 char *tmps;
2888 SV **svp;
2d8e6c8d 2889 STRLEN n_a;
a0d0e21e
LW		 2890
2891 if (MAXARG < 1)
2892 tmps = Nullch;
2893 else
2d8e6c8d 2894 tmps = POPpx;
a0d0e21e 2895 if (!tmps || !*tmps) {
3280af22 2896 svp = hv_fetch(GvHVn(PL_envgv), "HOME", 4, FALSE);
a0d0e21e 2897 if (svp)
2d8e6c8d 2898 tmps = SvPV(*svp, n_a);
a0d0e21e
LW		 2899 }
2900 if (!tmps || !*tmps) {
3280af22 2901 svp = hv_fetch(GvHVn(PL_envgv), "LOGDIR", 6, FALSE);
a0d0e21e 2902 if (svp)
2d8e6c8d 2903 tmps = SvPV(*svp, n_a);
a0d0e21e 2904 }
491527d0
GS		 2905#ifdef VMS
2906 if (!tmps || !*tmps) {
6b88bc9c 2907 svp = hv_fetch(GvHVn(PL_envgv), "SYS$LOGIN", 9, FALSE);
491527d0 2908 if (svp)
2d8e6c8d 2909 tmps = SvPV(*svp, n_a);
491527d0
GS		 2910 }
2911#endif
a0d0e21e 2912 TAINT_PROPER("chdir");
6ad3d225 2913 PUSHi( PerlDir_chdir(tmps) >= 0 );
748a9306
LW		 2914#ifdef VMS
2915 /* Clear the DEFAULT element of ENV so we'll get the new value
2916 * in the future. */
6b88bc9c 2917 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
748a9306 2918#endif
a0d0e21e
LW		 2919 RETURN;
2920}
2921
2922PP(pp_chown)
2923{
4e35701f 2924 djSP; dMARK; dTARGET;
a0d0e21e
LW		 2925 I32 value;
2926#ifdef HAS_CHOWN
533c011a 2927 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 2928 SP = MARK;
2929 PUSHi(value);
2930 RETURN;
2931#else
22c35a8c 2932 DIE(PL_no_func, "Unsupported function chown");
a0d0e21e
LW		 2933#endif
2934}
2935
2936PP(pp_chroot)
2937{
4e35701f 2938 djSP; dTARGET;
a0d0e21e
LW		 2939 char *tmps;
2940#ifdef HAS_CHROOT
2d8e6c8d
GS		 2941 STRLEN n_a;
2942 tmps = POPpx;
a0d0e21e
LW		 2943 TAINT_PROPER("chroot");
2944 PUSHi( chroot(tmps) >= 0 );
2945 RETURN;
2946#else
22c35a8c 2947 DIE(PL_no_func, "chroot");
a0d0e21e
LW		 2948#endif
2949}
2950
2951PP(pp_unlink)
2952{
4e35701f 2953 djSP; dMARK; dTARGET;
a0d0e21e 2954 I32 value;
533c011a 2955 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 2956 SP = MARK;
2957 PUSHi(value);
2958 RETURN;
2959}
2960
2961PP(pp_chmod)
2962{
4e35701f 2963 djSP; dMARK; dTARGET;
a0d0e21e 2964 I32 value;
533c011a 2965 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 2966 SP = MARK;
2967 PUSHi(value);
2968 RETURN;
2969}
2970
2971PP(pp_utime)
2972{
4e35701f 2973 djSP; dMARK; dTARGET;
a0d0e21e 2974 I32 value;
533c011a 2975 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 2976 SP = MARK;
2977 PUSHi(value);
2978 RETURN;
2979}
2980
2981PP(pp_rename)
2982{
4e35701f 2983 djSP; dTARGET;
a0d0e21e 2984 int anum;
2d8e6c8d 2985 STRLEN n_a;
a0d0e21e 2986
2d8e6c8d
GS		 2987 char *tmps2 = POPpx;
2988 char *tmps = SvPV(TOPs, n_a);
a0d0e21e
LW		 2989 TAINT_PROPER("rename");
2990#ifdef HAS_RENAME
baed7233 2991 anum = PerlLIO_rename(tmps, tmps2);
a0d0e21e 2992#else
6b88bc9c 2993 if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
ed969818
W		 2994 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
2995 anum = 1;
2996 else {
3654eb6c 2997 if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
ed969818
W		 2998 (void)UNLINK(tmps2);
2999 if (!(anum = link(tmps, tmps2)))
3000 anum = UNLINK(tmps);
3001 }
a0d0e21e
LW		 3002 }
3003#endif
3004 SETi( anum >= 0 );
3005 RETURN;
3006}
3007
3008PP(pp_link)
3009{
4e35701f 3010 djSP; dTARGET;
a0d0e21e 3011#ifdef HAS_LINK
2d8e6c8d
GS		 3012 STRLEN n_a;
3013 char *tmps2 = POPpx;
3014 char *tmps = SvPV(TOPs, n_a);
a0d0e21e
LW		 3015 TAINT_PROPER("link");
3016 SETi( link(tmps, tmps2) >= 0 );
3017#else
22c35a8c 3018 DIE(PL_no_func, "Unsupported function link");
a0d0e21e
LW		 3019#endif
3020 RETURN;
3021}
3022
3023PP(pp_symlink)
3024{
4e35701f 3025 djSP; dTARGET;
a0d0e21e 3026#ifdef HAS_SYMLINK
2d8e6c8d
GS		 3027 STRLEN n_a;
3028 char *tmps2 = POPpx;
3029 char *tmps = SvPV(TOPs, n_a);
a0d0e21e
LW		 3030 TAINT_PROPER("symlink");
3031 SETi( symlink(tmps, tmps2) >= 0 );
3032 RETURN;
3033#else
22c35a8c 3034 DIE(PL_no_func, "symlink");
a0d0e21e
LW		 3035#endif
3036}
3037
3038PP(pp_readlink)
3039{
4e35701f 3040 djSP; dTARGET;
a0d0e21e
LW		 3041#ifdef HAS_SYMLINK
3042 char *tmps;
46fc3d4c 3043 char buf[MAXPATHLEN];
a0d0e21e 3044 int len;
2d8e6c8d 3045 STRLEN n_a;
46fc3d4c 3046
fb73857a 3047#ifndef INCOMPLETE_TAINTS
3048 TAINT;
3049#endif
2d8e6c8d 3050 tmps = POPpx;
a0d0e21e
LW		 3051 len = readlink(tmps, buf, sizeof buf);
3052 EXTEND(SP, 1);
3053 if (len < 0)
3054 RETPUSHUNDEF;
3055 PUSHp(buf, len);
3056 RETURN;
3057#else
3058 EXTEND(SP, 1);
3059 RETSETUNDEF; /* just pretend it's a normal file */
3060#endif
3061}
3062
3063#if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3064static int
3065dooneliner(cmd, filename)
3066char *cmd;
3067char *filename;
3068{
1e422769 3069 char *save_filename = filename;
3070 char *cmdline;
3071 char *s;
760ac839 3072 PerlIO *myfp;
1e422769 3073 int anum = 1;
a0d0e21e 3074
1e422769 3075 New(666, cmdline, strlen(cmd) + (strlen(filename) * 2) + 10, char);
3076 strcpy(cmdline, cmd);
3077 strcat(cmdline, " ");
3078 for (s = cmdline + strlen(cmdline); *filename; ) {
a0d0e21e
LW		 3079 *s++ = '\\';
3080 *s++ = *filename++;
3081 }
3082 strcpy(s, " 2>&1");
6ad3d225 3083 myfp = PerlProc_popen(cmdline, "r");
1e422769 3084 Safefree(cmdline);
3085
a0d0e21e 3086 if (myfp) {
1e422769 3087 SV *tmpsv = sv_newmortal();
6b88bc9c 3088 /* Need to save/restore 'PL_rs' ?? */
760ac839 3089 s = sv_gets(tmpsv, myfp, 0);
6ad3d225 3090 (void)PerlProc_pclose(myfp);
a0d0e21e 3091 if (s != Nullch) {
1e422769 3092 int e;
3093 for (e = 1;
a0d0e21e 3094#ifdef HAS_SYS_ERRLIST
1e422769 3095 e <= sys_nerr
3096#endif
3097 ; e++)
3098 {
3099 /* you don't see this */
3100 char *errmsg =
3101#ifdef HAS_SYS_ERRLIST
3102 sys_errlist[e]
a0d0e21e 3103#else
1e422769 3104 strerror(e)
a0d0e21e 3105#endif
1e422769 3106 ;
3107 if (!errmsg)
3108 break;
3109 if (instr(s, errmsg)) {
3110 SETERRNO(e,0);
3111 return 0;
3112 }
a0d0e21e 3113 }
748a9306 3114 SETERRNO(0,0);
a0d0e21e
LW		 3115#ifndef EACCES
3116#define EACCES EPERM
3117#endif
1e422769 3118 if (instr(s, "cannot make"))
748a9306 3119 SETERRNO(EEXIST,RMS$_FEX);
1e422769 3120 else if (instr(s, "existing file"))
748a9306 3121 SETERRNO(EEXIST,RMS$_FEX);
1e422769 3122 else if (instr(s, "ile exists"))
748a9306 3123 SETERRNO(EEXIST,RMS$_FEX);
1e422769 3124 else if (instr(s, "non-exist"))
748a9306 3125 SETERRNO(ENOENT,RMS$_FNF);
1e422769 3126 else if (instr(s, "does not exist"))
748a9306 3127 SETERRNO(ENOENT,RMS$_FNF);
1e422769 3128 else if (instr(s, "not empty"))
748a9306 3129 SETERRNO(EBUSY,SS$_DEVOFFLINE);
1e422769 3130 else if (instr(s, "cannot access"))
748a9306 3131 SETERRNO(EACCES,RMS$_PRV);
a0d0e21e 3132 else
748a9306 3133 SETERRNO(EPERM,RMS$_PRV);
a0d0e21e
LW		 3134 return 0;
3135 }
3136 else { /* some mkdirs return no failure indication */
6b88bc9c 3137 anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
911d147d 3138 if (PL_op->op_type == OP_RMDIR)
a0d0e21e
LW		 3139 anum = !anum;
3140 if (anum)
748a9306 3141 SETERRNO(0,0);
a0d0e21e 3142 else
748a9306 3143 SETERRNO(EACCES,RMS$_PRV); /* a guess */
a0d0e21e
LW		 3144 }
3145 return anum;
3146 }
3147 else
3148 return 0;
3149}
3150#endif
3151
3152PP(pp_mkdir)
3153{
4e35701f 3154 djSP; dTARGET;
a0d0e21e
LW		 3155 int mode = POPi;
3156#ifndef HAS_MKDIR
3157 int oldumask;
3158#endif
2d8e6c8d
GS		 3159 STRLEN n_a;
3160 char *tmps = SvPV(TOPs, n_a);
a0d0e21e
LW		 3161
3162 TAINT_PROPER("mkdir");
3163#ifdef HAS_MKDIR
6ad3d225 3164 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
a0d0e21e
LW		 3165#else
3166 SETi( dooneliner("mkdir", tmps) );
6ad3d225
GS		 3167 oldumask = PerlLIO_umask(0);
3168 PerlLIO_umask(oldumask);
3169 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
a0d0e21e
LW		 3170#endif
3171 RETURN;
3172}
3173
3174PP(pp_rmdir)
3175{
4e35701f 3176 djSP; dTARGET;
a0d0e21e 3177 char *tmps;
2d8e6c8d 3178 STRLEN n_a;
a0d0e21e 3179
2d8e6c8d 3180 tmps = POPpx;
a0d0e21e
LW		 3181 TAINT_PROPER("rmdir");
3182#ifdef HAS_RMDIR
6ad3d225 3183 XPUSHi( PerlDir_rmdir(tmps) >= 0 );
a0d0e21e
LW		 3184#else
3185 XPUSHi( dooneliner("rmdir", tmps) );
3186#endif
3187 RETURN;
3188}
3189
3190/* Directory calls. */
3191
3192PP(pp_open_dir)
3193{
4e35701f 3194 djSP;
a0d0e21e 3195#if defined(Direntry_t) && defined(HAS_READDIR)
2d8e6c8d
GS		 3196 STRLEN n_a;
3197 char *dirname = POPpx;
a0d0e21e
LW		 3198 GV *gv = (GV*)POPs;
3199 register IO *io = GvIOn(gv);
3200
3201 if (!io)
3202 goto nope;
3203
3204 if (IoDIRP(io))
6ad3d225
GS		 3205 PerlDir_close(IoDIRP(io));
3206 if (!(IoDIRP(io) = PerlDir_open(dirname)))
a0d0e21e
LW		 3207 goto nope;
3208
3209 RETPUSHYES;
3210nope:
3211 if (!errno)
748a9306 3212 SETERRNO(EBADF,RMS$_DIR);
a0d0e21e
LW		 3213 RETPUSHUNDEF;
3214#else
22c35a8c 3215 DIE(PL_no_dir_func, "opendir");
a0d0e21e
LW		 3216#endif
3217}
3218
3219PP(pp_readdir)
3220{
4e35701f 3221 djSP;
a0d0e21e
LW		 3222#if defined(Direntry_t) && defined(HAS_READDIR)
3223#ifndef I_DIRENT
3224 Direntry_t *readdir _((DIR *));
3225#endif
3226 register Direntry_t *dp;
3227 GV *gv = (GV*)POPs;
3228 register IO *io = GvIOn(gv);
fb73857a 3229 SV *sv;
a0d0e21e
LW		 3230
3231 if (!io || !IoDIRP(io))
3232 goto nope;
3233
3234 if (GIMME == G_ARRAY) {
3235 /*SUPPRESS 560*/
6ad3d225 3236 while (dp = (Direntry_t *)PerlDir_read(IoDIRP(io))) {
a0d0e21e 3237#ifdef DIRNAMLEN
79cb57f6 3238 sv = newSVpvn(dp->d_name, dp->d_namlen);
a0d0e21e 3239#else
fb73857a 3240 sv = newSVpv(dp->d_name, 0);
3241#endif
3242#ifndef INCOMPLETE_TAINTS
3243 SvTAINTED_on(sv);
a0d0e21e 3244#endif
fb73857a 3245 XPUSHs(sv_2mortal(sv));
a0d0e21e
LW		 3246 }
3247 }
3248 else {
6ad3d225 3249 if (!(dp = (Direntry_t *)PerlDir_read(IoDIRP(io))))
a0d0e21e
LW		 3250 goto nope;
3251#ifdef DIRNAMLEN
79cb57f6 3252 sv = newSVpvn(dp->d_name, dp->d_namlen);
a0d0e21e 3253#else
fb73857a 3254 sv = newSVpv(dp->d_name, 0);
a0d0e21e 3255#endif
fb73857a 3256#ifndef INCOMPLETE_TAINTS
3257 SvTAINTED_on(sv);
3258#endif
3259 XPUSHs(sv_2mortal(sv));
a0d0e21e
LW		 3260 }
3261 RETURN;
3262
3263nope:
3264 if (!errno)
748a9306 3265 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 3266 if (GIMME == G_ARRAY)
3267 RETURN;
3268 else
3269 RETPUSHUNDEF;
3270#else
22c35a8c 3271 DIE(PL_no_dir_func, "readdir");
a0d0e21e
LW		 3272#endif
3273}
3274
3275PP(pp_telldir)
3276{
4e35701f 3277 djSP; dTARGET;
a0d0e21e 3278#if defined(HAS_TELLDIR) || defined(telldir)
968dcd91
JH		 3279 /* XXX does _anyone_ need this? --AD 2/20/1998 */
3280 /* XXX netbsd still seemed to.
3281 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3282 --JHI 1999-Feb-02 */
3283# if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
a0d0e21e 3284 long telldir _((DIR *));
dfe9444c 3285# endif
a0d0e21e
LW		 3286 GV *gv = (GV*)POPs;
3287 register IO *io = GvIOn(gv);
3288
3289 if (!io || !IoDIRP(io))
3290 goto nope;
3291
6ad3d225 3292 PUSHi( PerlDir_tell(IoDIRP(io)) );
a0d0e21e
LW		 3293 RETURN;
3294nope:
3295 if (!errno)
748a9306 3296 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 3297 RETPUSHUNDEF;
3298#else
22c35a8c 3299 DIE(PL_no_dir_func, "telldir");
a0d0e21e
LW		 3300#endif
3301}
3302
3303PP(pp_seekdir)
3304{
4e35701f 3305 djSP;
a0d0e21e
LW		 3306#if defined(HAS_SEEKDIR) || defined(seekdir)
3307 long along = POPl;
3308 GV *gv = (GV*)POPs;
3309 register IO *io = GvIOn(gv);
3310
3311 if (!io || !IoDIRP(io))
3312 goto nope;
3313
6ad3d225 3314 (void)PerlDir_seek(IoDIRP(io), along);
a0d0e21e
LW		 3315
3316 RETPUSHYES;
3317nope:
3318 if (!errno)
748a9306 3319 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 3320 RETPUSHUNDEF;
3321#else
22c35a8c 3322 DIE(PL_no_dir_func, "seekdir");
a0d0e21e
LW		 3323#endif
3324}
3325
3326PP(pp_rewinddir)
3327{
4e35701f 3328 djSP;
a0d0e21e
LW		 3329#if defined(HAS_REWINDDIR) || defined(rewinddir)
3330 GV *gv = (GV*)POPs;
3331 register IO *io = GvIOn(gv);
3332
3333 if (!io || !IoDIRP(io))
3334 goto nope;
3335
6ad3d225 3336 (void)PerlDir_rewind(IoDIRP(io));
a0d0e21e
LW		 3337 RETPUSHYES;
3338nope:
3339 if (!errno)
748a9306 3340 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 3341 RETPUSHUNDEF;
3342#else
22c35a8c 3343 DIE(PL_no_dir_func, "rewinddir");
a0d0e21e
LW		 3344#endif
3345}
3346
3347PP(pp_closedir)
3348{
4e35701f 3349 djSP;
a0d0e21e
LW		 3350#if defined(Direntry_t) && defined(HAS_READDIR)
3351 GV *gv = (GV*)POPs;
3352 register IO *io = GvIOn(gv);
3353
3354 if (!io || !IoDIRP(io))
3355 goto nope;
3356
3357#ifdef VOID_CLOSEDIR
6ad3d225 3358 PerlDir_close(IoDIRP(io));
a0d0e21e 3359#else
6ad3d225 3360 if (PerlDir_close(IoDIRP(io)) < 0) {
748a9306 3361 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
a0d0e21e 3362 goto nope;
748a9306 3363 }
a0d0e21e
LW		 3364#endif
3365 IoDIRP(io) = 0;
3366
3367 RETPUSHYES;
3368nope:
3369 if (!errno)
748a9306 3370 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW		 3371 RETPUSHUNDEF;
3372#else
22c35a8c 3373 DIE(PL_no_dir_func, "closedir");
a0d0e21e
LW		 3374#endif
3375}
3376
3377/* Process control. */
3378
3379PP(pp_fork)
3380{
44a8e56a 3381#ifdef HAS_FORK
4e35701f 3382 djSP; dTARGET;
761237fe 3383 Pid_t childpid;
a0d0e21e
LW		 3384 GV *tmpgv;
3385
3386 EXTEND(SP, 1);
a0d0e21e
LW		 3387 childpid = fork();
3388 if (childpid < 0)
3389 RETSETUNDEF;
3390 if (!childpid) {
3391 /*SUPPRESS 560*/
3392 if (tmpgv = gv_fetchpv("$", TRUE, SVt_PV))
1e422769 3393 sv_setiv(GvSV(tmpgv), (IV)getpid());
3280af22 3394 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
a0d0e21e
LW		 3395 }
3396 PUSHi(childpid);
3397 RETURN;
3398#else
22c35a8c 3399 DIE(PL_no_func, "Unsupported function fork");
a0d0e21e
LW		 3400#endif
3401}
3402
3403PP(pp_wait)
3404{
2d7a9237 3405#if !defined(DOSISH) || defined(OS2) || defined(WIN32)
4e35701f 3406 djSP; dTARGET;
761237fe 3407 Pid_t childpid;
a0d0e21e 3408 int argflags;
a0d0e21e 3409
44a8e56a 3410 childpid = wait4pid(-1, &argflags, 0);
f86702cc 3411 STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
44a8e56a 3412 XPUSHi(childpid);
a0d0e21e
LW		 3413 RETURN;
3414#else
22c35a8c 3415 DIE(PL_no_func, "Unsupported function wait");
a0d0e21e
LW		 3416#endif
3417}
3418
3419PP(pp_waitpid)
3420{
2d7a9237 3421#if !defined(DOSISH) || defined(OS2) || defined(WIN32)
4e35701f 3422 djSP; dTARGET;
761237fe 3423 Pid_t childpid;
a0d0e21e
LW		 3424 int optype;
3425 int argflags;
a0d0e21e 3426
a0d0e21e
LW		 3427 optype = POPi;
3428 childpid = TOPi;
3429 childpid = wait4pid(childpid, &argflags, optype);
f86702cc 3430 STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
44a8e56a 3431 SETi(childpid);
a0d0e21e
LW		 3432 RETURN;
3433#else
22c35a8c 3434 DIE(PL_no_func, "Unsupported function waitpid");
a0d0e21e
LW		 3435#endif
3436}
3437
3438PP(pp_system)
3439{
4e35701f 3440 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e 3441 I32 value;
761237fe 3442 Pid_t childpid;
a0d0e21e
LW		 3443 int result;
3444 int status;
ff68c719 3445 Sigsave_t ihand,qhand; /* place to save signals during system() */
2d8e6c8d 3446 STRLEN n_a;
a0d0e21e 3447
a0d0e21e 3448 if (SP - MARK == 1) {
3280af22 3449 if (PL_tainting) {
2d8e6c8d 3450 char *junk = SvPV(TOPs, n_a);
a0d0e21e
LW		 3451 TAINT_ENV();
3452 TAINT_PROPER("system");
3453 }
3454 }
1e422769 3455#if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2)
a0d0e21e
LW		 3456 while ((childpid = vfork()) == -1) {
3457 if (errno != EAGAIN) {
3458 value = -1;
3459 SP = ORIGMARK;
3460 PUSHi(value);
3461 RETURN;
3462 }
3463 sleep(5);
3464 }
3465 if (childpid > 0) {
ff68c719 3466 rsignal_save(SIGINT, SIG_IGN, &ihand);
3467 rsignal_save(SIGQUIT, SIG_IGN, &qhand);
748a9306
LW		 3468 do {
3469 result = wait4pid(childpid, &status, 0);
3470 } while (result == -1 && errno == EINTR);
ff68c719 3471 (void)rsignal_restore(SIGINT, &ihand);
3472 (void)rsignal_restore(SIGQUIT, &qhand);
91e9c03f 3473 STATUS_NATIVE_SET(result == -1 ? -1 : status);
a0d0e21e
LW		 3474 do_execfree(); /* free any memory child malloced on vfork */
3475 SP = ORIGMARK;
ff0cee69 3476 PUSHi(STATUS_CURRENT);
a0d0e21e
LW		 3477 RETURN;
3478 }
533c011a 3479 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e
LW		 3480 SV *really = *++MARK;
3481 value = (I32)do_aexec(really, MARK, SP);
3482 }
3483 else if (SP - MARK != 1)
3484 value = (I32)do_aexec(Nullsv, MARK, SP);
3485 else {
2d8e6c8d 3486 value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
a0d0e21e 3487 }
6ad3d225 3488 PerlProc__exit(-1);
c3293030 3489#else /* ! FORK or VMS or OS/2 */
911d147d 3490 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e 3491 SV *really = *++MARK;
4e35701f 3492 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
a0d0e21e
LW		 3493 }
3494 else if (SP - MARK != 1)
4e35701f 3495 value = (I32)do_aspawn(Nullsv, (void **)MARK, (void **)SP);
a0d0e21e 3496 else {
2d8e6c8d 3497 value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
a0d0e21e 3498 }
f86702cc 3499 STATUS_NATIVE_SET(value);
a0d0e21e
LW		 3500 do_execfree();
3501 SP = ORIGMARK;
ff0cee69 3502 PUSHi(STATUS_CURRENT);
a0d0e21e
LW		 3503#endif /* !FORK or VMS */
3504 RETURN;
3505}
3506
3507PP(pp_exec)
3508{
4e35701f 3509 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e 3510 I32 value;
2d8e6c8d 3511 STRLEN n_a;
a0d0e21e 3512
533c011a 3513 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e
LW		 3514 SV *really = *++MARK;
3515 value = (I32)do_aexec(really, MARK, SP);
3516 }
3517 else if (SP - MARK != 1)
3518#ifdef VMS
3519 value = (I32)vms_do_aexec(Nullsv, MARK, SP);
3520#else
092bebab
JH		 3521# ifdef __OPEN_VM
3522 {
3523 (void ) do_aspawn(Nullsv, MARK, SP);
3524 value = 0;
3525 }
3526# else
a0d0e21e 3527 value = (I32)do_aexec(Nullsv, MARK, SP);
092bebab 3528# endif
a0d0e21e
LW		 3529#endif
3530 else {
3280af22 3531 if (PL_tainting) {
2d8e6c8d 3532 char *junk = SvPV(*SP, n_a);
a0d0e21e
LW		 3533 TAINT_ENV();
3534 TAINT_PROPER("exec");
3535 }
3536#ifdef VMS
2d8e6c8d 3537 value = (I32)vms_do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
a0d0e21e 3538#else
092bebab 3539# ifdef __OPEN_VM
2d8e6c8d 3540 (void) do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
092bebab
JH		 3541 value = 0;
3542# else
2d8e6c8d 3543 value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
092bebab 3544# endif
a0d0e21e
LW		 3545#endif
3546 }
3547 SP = ORIGMARK;
3548 PUSHi(value);
3549 RETURN;
3550}
3551
3552PP(pp_kill)
3553{
4e35701f 3554 djSP; dMARK; dTARGET;
a0d0e21e
LW		 3555 I32 value;
3556#ifdef HAS_KILL
533c011a 3557 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 3558 SP = MARK;
3559 PUSHi(value);
3560 RETURN;
3561#else
22c35a8c 3562 DIE(PL_no_func, "Unsupported function kill");
a0d0e21e
LW		 3563#endif
3564}
3565
3566PP(pp_getppid)
3567{
3568#ifdef HAS_GETPPID
4e35701f 3569 djSP; dTARGET;
a0d0e21e
LW		 3570 XPUSHi( getppid() );
3571 RETURN;
3572#else
22c35a8c 3573 DIE(PL_no_func, "getppid");
a0d0e21e
LW		 3574#endif
3575}
3576
3577PP(pp_getpgrp)
3578{
3579#ifdef HAS_GETPGRP
4e35701f 3580 djSP; dTARGET;
a0d0e21e
LW		 3581 int pid;
3582 I32 value;
3583
3584 if (MAXARG < 1)
3585 pid = 0;
3586 else
3587 pid = SvIVx(POPs);
c3293030
IZ		 3588#ifdef BSD_GETPGRP
3589 value = (I32)BSD_GETPGRP(pid);
a0d0e21e 3590#else
aa689395 3591 if (pid != 0 && pid != getpid())
a0d0e21e
LW		 3592 DIE("POSIX getpgrp can't take an argument");
3593 value = (I32)getpgrp();
3594#endif
3595 XPUSHi(value);
3596 RETURN;
3597#else
22c35a8c 3598 DIE(PL_no_func, "getpgrp()");
a0d0e21e
LW		 3599#endif
3600}
3601
3602PP(pp_setpgrp)
3603{
3604#ifdef HAS_SETPGRP
4e35701f 3605 djSP; dTARGET;
a0d0e21e
LW		 3606 int pgrp;
3607 int pid;
3608 if (MAXARG < 2) {
3609 pgrp = 0;
3610 pid = 0;
3611 }
3612 else {
3613 pgrp = POPi;
3614 pid = TOPi;
3615 }
3616
3617 TAINT_PROPER("setpgrp");
c3293030
IZ		 3618#ifdef BSD_SETPGRP
3619 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
a0d0e21e 3620#else
c90c0ff4 3621 if ((pgrp != 0 && pgrp != getpid()) || (pid != 0 && pid != getpid()))
a0d0e21e 3622 DIE("POSIX setpgrp can't take an argument");
a0d0e21e
LW		 3623 SETi( setpgrp() >= 0 );
3624#endif /* USE_BSDPGRP */
3625 RETURN;
3626#else
22c35a8c 3627 DIE(PL_no_func, "setpgrp()");
a0d0e21e
LW		 3628#endif
3629}
3630
3631PP(pp_getpriority)
3632{
4e35701f 3633 djSP; dTARGET;
a0d0e21e
LW		 3634 int which;
3635 int who;
3636#ifdef HAS_GETPRIORITY
3637 who = POPi;
3638 which = TOPi;
3639 SETi( getpriority(which, who) );
3640 RETURN;
3641#else
22c35a8c 3642 DIE(PL_no_func, "getpriority()");
a0d0e21e
LW		 3643#endif
3644}
3645
3646PP(pp_setpriority)
3647{
4e35701f 3648 djSP; dTARGET;
a0d0e21e
LW		 3649 int which;
3650 int who;
3651 int niceval;
3652#ifdef HAS_SETPRIORITY
3653 niceval = POPi;
3654 who = POPi;
3655 which = TOPi;
3656 TAINT_PROPER("setpriority");
3657 SETi( setpriority(which, who, niceval) >= 0 );
3658 RETURN;
3659#else
22c35a8c 3660 DIE(PL_no_func, "setpriority()");
a0d0e21e
LW		 3661#endif
3662}
3663
3664/* Time calls. */
3665
3666PP(pp_time)
3667{
4e35701f 3668 djSP; dTARGET;
cbdc8872 3669#ifdef BIG_TIME
3670 XPUSHn( time(Null(Time_t*)) );
3671#else
a0d0e21e 3672 XPUSHi( time(Null(Time_t*)) );
cbdc8872 3673#endif
a0d0e21e
LW		 3674 RETURN;
3675}
3676
cd52b7b2 3677/* XXX The POSIX name is CLK_TCK; it is to be preferred
3678 to HZ. Probably. For now, assume that if the system
3679 defines HZ, it does so correctly. (Will this break
3680 on VMS?)
3681 Probably we ought to use _sysconf(_SC_CLK_TCK), if
3682 it's supported. --AD 9/96.
3683*/
3684
a0d0e21e 3685#ifndef HZ
cd52b7b2 3686# ifdef CLK_TCK
3687# define HZ CLK_TCK
3688# else
3689# define HZ 60
3690# endif
a0d0e21e
LW		 3691#endif
3692
3693PP(pp_tms)
3694{
4e35701f 3695 djSP;
a0d0e21e 3696
55497cff 3697#ifndef HAS_TIMES
a0d0e21e
LW		 3698 DIE("times not implemented");
3699#else
3700 EXTEND(SP, 4);
3701
3702#ifndef VMS
3280af22 3703 (void)PerlProc_times(&PL_timesbuf);
a0d0e21e 3704#else
6b88bc9c 3705 (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */
76e3520e
GS		 3706 /* struct tms, though same data */
3707 /* is returned. */
a0d0e21e
LW		 3708#endif
3709
3280af22 3710 PUSHs(sv_2mortal(newSVnv(((double)PL_timesbuf.tms_utime)/HZ)));
a0d0e21e 3711 if (GIMME == G_ARRAY) {
3280af22
NIS		 3712 PUSHs(sv_2mortal(newSVnv(((double)PL_timesbuf.tms_stime)/HZ)));
3713 PUSHs(sv_2mortal(newSVnv(((double)PL_timesbuf.tms_cutime)/HZ)));
3714 PUSHs(sv_2mortal(newSVnv(((double)PL_timesbuf.tms_cstime)/HZ)));
a0d0e21e
LW		 3715 }
3716 RETURN;
55497cff 3717#endif /* HAS_TIMES */
a0d0e21e
LW		 3718}
3719
3720PP(pp_localtime)
3721{
3722 return pp_gmtime(ARGS);
3723}
3724
3725PP(pp_gmtime)
3726{
4e35701f 3727 djSP;
a0d0e21e
LW		 3728 Time_t when;
3729 struct tm *tmbuf;
3730 static char *dayname[] = {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
3731 static char *monname[] = {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
3732 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
3733
3734 if (MAXARG < 1)
3735 (void)time(&when);
3736 else
cbdc8872 3737#ifdef BIG_TIME
3738 when = (Time_t)SvNVx(POPs);
3739#else
a0d0e21e 3740 when = (Time_t)SvIVx(POPs);
cbdc8872 3741#endif
a0d0e21e 3742
533c011a 3743 if (PL_op->op_type == OP_LOCALTIME)
a0d0e21e
LW		 3744 tmbuf = localtime(&when);
3745 else
3746 tmbuf = gmtime(&when);
3747
3748 EXTEND(SP, 9);
bbce6d69 3749 EXTEND_MORTAL(9);
a0d0e21e
LW		 3750 if (GIMME != G_ARRAY) {
3751 dTARGET;
46fc3d4c 3752 SV *tsv;
a0d0e21e
LW		 3753 if (!tmbuf)
3754 RETPUSHUNDEF;
46fc3d4c 3755 tsv = newSVpvf("%s %s %2d %02d:%02d:%02d %d",
3756 dayname[tmbuf->tm_wday],
3757 monname[tmbuf->tm_mon],
3758 tmbuf->tm_mday,
3759 tmbuf->tm_hour,
3760 tmbuf->tm_min,
3761 tmbuf->tm_sec,
3762 tmbuf->tm_year + 1900);
3763 PUSHs(sv_2mortal(tsv));
a0d0e21e
LW		 3764 }
3765 else if (tmbuf) {
3766 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_sec)));
3767 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_min)));
3768 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_hour)));
3769 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_mday)));
3770 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_mon)));
3771 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_year)));
3772 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_wday)));
3773 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_yday)));
3774 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_isdst)));
3775 }
3776 RETURN;
3777}
3778
3779PP(pp_alarm)
3780{
4e35701f 3781 djSP; dTARGET;
a0d0e21e
LW		 3782 int anum;
3783#ifdef HAS_ALARM
3784 anum = POPi;
3785 anum = alarm((unsigned int)anum);
3786 EXTEND(SP, 1);
3787 if (anum < 0)
3788 RETPUSHUNDEF;
3789 PUSHi((I32)anum);
3790 RETURN;
3791#else
22c35a8c 3792 DIE(PL_no_func, "Unsupported function alarm");
a0d0e21e
LW		 3793#endif
3794}
3795
3796PP(pp_sleep)
3797{
4e35701f 3798 djSP; dTARGET;
a0d0e21e
LW		 3799 I32 duration;
3800 Time_t lasttime;
3801 Time_t when;
3802
3803 (void)time(&lasttime);
3804 if (MAXARG < 1)
76e3520e 3805 PerlProc_pause();
a0d0e21e
LW		 3806 else {
3807 duration = POPi;
76e3520e 3808 PerlProc_sleep((unsigned int)duration);
a0d0e21e
LW		 3809 }
3810 (void)time(&when);
3811 XPUSHi(when - lasttime);
3812 RETURN;
3813}
3814
3815/* Shared memory. */
3816
3817PP(pp_shmget)
3818{
3819 return pp_semget(ARGS);
3820}
3821
3822PP(pp_shmctl)
3823{
3824 return pp_semctl(ARGS);
3825}
3826
3827PP(pp_shmread)
3828{
3829 return pp_shmwrite(ARGS);
3830}
3831
3832PP(pp_shmwrite)
3833{
3834#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 3835 djSP; dMARK; dTARGET;
533c011a 3836 I32 value = (I32)(do_shmio(PL_op->op_type, MARK, SP) >= 0);
a0d0e21e
LW		 3837 SP = MARK;
3838 PUSHi(value);
3839 RETURN;
3840#else
748a9306 3841 return pp_semget(ARGS);
a0d0e21e
LW		 3842#endif
3843}
3844
3845/* Message passing. */
3846
3847PP(pp_msgget)
3848{
3849 return pp_semget(ARGS);
3850}
3851
3852PP(pp_msgctl)
3853{
3854 return pp_semctl(ARGS);
3855}
3856
3857PP(pp_msgsnd)
3858{
3859#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 3860 djSP; dMARK; dTARGET;
a0d0e21e
LW		 3861 I32 value = (I32)(do_msgsnd(MARK, SP) >= 0);
3862 SP = MARK;
3863 PUSHi(value);
3864 RETURN;
3865#else
748a9306 3866 return pp_semget(ARGS);
a0d0e21e
LW		 3867#endif
3868}
3869
3870PP(pp_msgrcv)
3871{
3872#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 3873 djSP; dMARK; dTARGET;
a0d0e21e
LW		 3874 I32 value = (I32)(do_msgrcv(MARK, SP) >= 0);
3875 SP = MARK;
3876 PUSHi(value);
3877 RETURN;
3878#else
748a9306 3879 return pp_semget(ARGS);
a0d0e21e
LW		 3880#endif
3881}
3882
3883/* Semaphores. */
3884
3885PP(pp_semget)
3886{
3887#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 3888 djSP; dMARK; dTARGET;
533c011a 3889 int anum = do_ipcget(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 3890 SP = MARK;
3891 if (anum == -1)
3892 RETPUSHUNDEF;
3893 PUSHi(anum);
3894 RETURN;
3895#else
3896 DIE("System V IPC is not implemented on this machine");
3897#endif
3898}
3899
3900PP(pp_semctl)
3901{
3902#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 3903 djSP; dMARK; dTARGET;
533c011a 3904 int anum = do_ipcctl(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 3905 SP = MARK;
3906 if (anum == -1)
3907 RETSETUNDEF;
3908 if (anum != 0) {
3909 PUSHi(anum);
3910 }
3911 else {
8903cb82 3912 PUSHp(zero_but_true, ZBTLEN);
a0d0e21e
LW		 3913 }
3914 RETURN;
3915#else
748a9306 3916 return pp_semget(ARGS);
a0d0e21e
LW		 3917#endif
3918}
3919
3920PP(pp_semop)
3921{
3922#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 3923 djSP; dMARK; dTARGET;
a0d0e21e
LW		 3924 I32 value = (I32)(do_semop(MARK, SP) >= 0);
3925 SP = MARK;
3926 PUSHi(value);
3927 RETURN;
3928#else
748a9306 3929 return pp_semget(ARGS);
a0d0e21e
LW		 3930#endif
3931}
3932
3933/* Get system info. */
3934
3935PP(pp_ghbyname)
3936{
693762b4 3937#ifdef HAS_GETHOSTBYNAME
a0d0e21e
LW		 3938 return pp_ghostent(ARGS);
3939#else
22c35a8c 3940 DIE(PL_no_sock_func, "gethostbyname");
a0d0e21e
LW		 3941#endif
3942}
3943
3944PP(pp_ghbyaddr)
3945{
693762b4 3946#ifdef HAS_GETHOSTBYADDR
a0d0e21e
LW		 3947 return pp_ghostent(ARGS);
3948#else
22c35a8c 3949 DIE(PL_no_sock_func, "gethostbyaddr");
a0d0e21e
LW		 3950#endif
3951}
3952
3953PP(pp_ghostent)
3954{
4e35701f 3955 djSP;
693762b4 3956#if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
533c011a 3957 I32 which = PL_op->op_type;
a0d0e21e
LW		 3958 register char **elem;
3959 register SV *sv;
dc45a647 3960#ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4599a1de
JH		 3961 struct hostent *PerlSock_gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
3962 struct hostent *PerlSock_gethostbyname(Netdb_name_t);
6ad3d225 3963 struct hostent *PerlSock_gethostent(void);
a0d0e21e
LW		 3964#endif
3965 struct hostent *hent;
3966 unsigned long len;
2d8e6c8d 3967 STRLEN n_a;
a0d0e21e
LW		 3968
3969 EXTEND(SP, 10);
dc45a647
MB		 3970 if (which == OP_GHBYNAME)
3971#ifdef HAS_GETHOSTBYNAME
2d8e6c8d 3972 hent = PerlSock_gethostbyname(POPpx);
dc45a647 3973#else
22c35a8c 3974 DIE(PL_no_sock_func, "gethostbyname");
dc45a647 3975#endif
a0d0e21e 3976 else if (which == OP_GHBYADDR) {
dc45a647 3977#ifdef HAS_GETHOSTBYADDR
a0d0e21e 3978 int addrtype = POPi;
748a9306 3979 SV *addrsv = POPs;
a0d0e21e 3980 STRLEN addrlen;
4599a1de 3981 Netdb_host_t addr = (Netdb_host_t) SvPV(addrsv, addrlen);
a0d0e21e 3982
4599a1de 3983 hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
dc45a647 3984#else
22c35a8c 3985 DIE(PL_no_sock_func, "gethostbyaddr");
dc45a647 3986#endif
a0d0e21e
LW		 3987 }
3988 else
3989#ifdef HAS_GETHOSTENT
6ad3d225 3990 hent = PerlSock_gethostent();
a0d0e21e 3991#else
22c35a8c 3992 DIE(PL_no_sock_func, "gethostent");
a0d0e21e
LW		 3993#endif
3994
3995#ifdef HOST_NOT_FOUND
3996 if (!hent)
f86702cc 3997 STATUS_NATIVE_SET(h_errno);
a0d0e21e
LW		 3998#endif
3999
4000 if (GIMME != G_ARRAY) {
4001 PUSHs(sv = sv_newmortal());
4002 if (hent) {
4003 if (which == OP_GHBYNAME) {
fd0af264 4004 if (hent->h_addr)
4005 sv_setpvn(sv, hent->h_addr, hent->h_length);
a0d0e21e
LW		 4006 }
4007 else
4008 sv_setpv(sv, (char*)hent->h_name);
4009 }
4010 RETURN;
4011 }
4012
4013 if (hent) {
3280af22 4014 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4015 sv_setpv(sv, (char*)hent->h_name);
3280af22 4016 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 4017 for (elem = hent->h_aliases; elem && *elem; elem++) {
4018 sv_catpv(sv, *elem);
4019 if (elem[1])
4020 sv_catpvn(sv, " ", 1);
4021 }
3280af22 4022 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4023 sv_setiv(sv, (IV)hent->h_addrtype);
3280af22 4024 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4025 len = hent->h_length;
1e422769 4026 sv_setiv(sv, (IV)len);
a0d0e21e
LW		 4027#ifdef h_addr
4028 for (elem = hent->h_addr_list; elem && *elem; elem++) {
3280af22 4029 XPUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 4030 sv_setpvn(sv, *elem, len);
4031 }
4032#else
6b88bc9c 4033 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
fd0af264 4034 if (hent->h_addr)
4035 sv_setpvn(sv, hent->h_addr, len);
a0d0e21e
LW		 4036#endif /* h_addr */
4037 }
4038 RETURN;
4039#else
22c35a8c 4040 DIE(PL_no_sock_func, "gethostent");
a0d0e21e
LW		 4041#endif
4042}
4043
4044PP(pp_gnbyname)
4045{
693762b4 4046#ifdef HAS_GETNETBYNAME
a0d0e21e
LW		 4047 return pp_gnetent(ARGS);
4048#else
22c35a8c 4049 DIE(PL_no_sock_func, "getnetbyname");
a0d0e21e
LW		 4050#endif
4051}
4052
4053PP(pp_gnbyaddr)
4054{
693762b4 4055#ifdef HAS_GETNETBYADDR
a0d0e21e
LW		 4056 return pp_gnetent(ARGS);
4057#else
22c35a8c 4058 DIE(PL_no_sock_func, "getnetbyaddr");
a0d0e21e
LW		 4059#endif
4060}
4061
4062PP(pp_gnetent)
4063{
4e35701f 4064 djSP;
693762b4 4065#if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
533c011a 4066 I32 which = PL_op->op_type;
a0d0e21e
LW		 4067 register char **elem;
4068 register SV *sv;
dc45a647
MB		 4069#ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4070 struct netent *PerlSock_getnetbyaddr(Netdb_net_t, int);
4071 struct netent *PerlSock_getnetbyname(Netdb_name_t);
4072 struct netent *PerlSock_getnetent(void);
8ac85365 4073#endif
a0d0e21e 4074 struct netent *nent;
2d8e6c8d 4075 STRLEN n_a;
a0d0e21e
LW		 4076
4077 if (which == OP_GNBYNAME)
dc45a647 4078#ifdef HAS_GETNETBYNAME
2d8e6c8d 4079 nent = PerlSock_getnetbyname(POPpx);
dc45a647 4080#else
22c35a8c 4081 DIE(PL_no_sock_func, "getnetbyname");
dc45a647 4082#endif
a0d0e21e 4083 else if (which == OP_GNBYADDR) {
dc45a647 4084#ifdef HAS_GETNETBYADDR
a0d0e21e 4085 int addrtype = POPi;
4599a1de 4086 Netdb_net_t addr = (Netdb_net_t) U_L(POPn);
76e3520e 4087 nent = PerlSock_getnetbyaddr(addr, addrtype);
dc45a647 4088#else
22c35a8c 4089 DIE(PL_no_sock_func, "getnetbyaddr");
dc45a647 4090#endif
a0d0e21e
LW		 4091 }
4092 else
dc45a647 4093#ifdef HAS_GETNETENT
76e3520e 4094 nent = PerlSock_getnetent();
dc45a647 4095#else
22c35a8c 4096 DIE(PL_no_sock_func, "getnetent");
dc45a647 4097#endif
a0d0e21e
LW		 4098
4099 EXTEND(SP, 4);
4100 if (GIMME != G_ARRAY) {
4101 PUSHs(sv = sv_newmortal());
4102 if (nent) {
4103 if (which == OP_GNBYNAME)
1e422769 4104 sv_setiv(sv, (IV)nent->n_net);
a0d0e21e
LW		 4105 else
4106 sv_setpv(sv, nent->n_name);
4107 }
4108 RETURN;
4109 }
4110
4111 if (nent) {
3280af22 4112 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4113 sv_setpv(sv, nent->n_name);
3280af22 4114 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 4115 for (elem = nent->n_aliases; elem && *elem; elem++) {
a0d0e21e
LW		 4116 sv_catpv(sv, *elem);
4117 if (elem[1])
4118 sv_catpvn(sv, " ", 1);
4119 }
3280af22 4120 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4121 sv_setiv(sv, (IV)nent->n_addrtype);
3280af22 4122 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4123 sv_setiv(sv, (IV)nent->n_net);
a0d0e21e
LW		 4124 }
4125
4126 RETURN;
4127#else
22c35a8c 4128 DIE(PL_no_sock_func, "getnetent");
a0d0e21e
LW		 4129#endif
4130}
4131
4132PP(pp_gpbyname)
4133{
693762b4 4134#ifdef HAS_GETPROTOBYNAME
a0d0e21e
LW		 4135 return pp_gprotoent(ARGS);
4136#else
22c35a8c 4137 DIE(PL_no_sock_func, "getprotobyname");
a0d0e21e
LW		 4138#endif
4139}
4140
4141PP(pp_gpbynumber)
4142{
693762b4 4143#ifdef HAS_GETPROTOBYNUMBER
a0d0e21e
LW		 4144 return pp_gprotoent(ARGS);
4145#else
22c35a8c 4146 DIE(PL_no_sock_func, "getprotobynumber");
a0d0e21e
LW		 4147#endif
4148}
4149
4150PP(pp_gprotoent)
4151{
4e35701f 4152 djSP;
693762b4 4153#if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
533c011a 4154 I32 which = PL_op->op_type;
a0d0e21e 4155 register char **elem;
8ac85365 4156 register SV *sv;
dc45a647 4157#ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4599a1de 4158 struct protoent *PerlSock_getprotobyname(Netdb_name_t);
6ad3d225
GS		 4159 struct protoent *PerlSock_getprotobynumber(int);
4160 struct protoent *PerlSock_getprotoent(void);
8ac85365 4161#endif
a0d0e21e 4162 struct protoent *pent;
2d8e6c8d 4163 STRLEN n_a;
a0d0e21e
LW		 4164
4165 if (which == OP_GPBYNAME)
e5c9fcd0 4166#ifdef HAS_GETPROTOBYNAME
2d8e6c8d 4167 pent = PerlSock_getprotobyname(POPpx);
e5c9fcd0 4168#else
22c35a8c 4169 DIE(PL_no_sock_func, "getprotobyname");
e5c9fcd0 4170#endif
a0d0e21e 4171 else if (which == OP_GPBYNUMBER)
e5c9fcd0 4172#ifdef HAS_GETPROTOBYNUMBER
6ad3d225 4173 pent = PerlSock_getprotobynumber(POPi);
e5c9fcd0 4174#else
22c35a8c 4175 DIE(PL_no_sock_func, "getprotobynumber");
e5c9fcd0 4176#endif
a0d0e21e 4177 else
e5c9fcd0 4178#ifdef HAS_GETPROTOENT
6ad3d225 4179 pent = PerlSock_getprotoent();
e5c9fcd0 4180#else
22c35a8c 4181 DIE(PL_no_sock_func, "getprotoent");
e5c9fcd0 4182#endif
a0d0e21e
LW		 4183
4184 EXTEND(SP, 3);
4185 if (GIMME != G_ARRAY) {
4186 PUSHs(sv = sv_newmortal());
4187 if (pent) {
4188 if (which == OP_GPBYNAME)
1e422769 4189 sv_setiv(sv, (IV)pent->p_proto);
a0d0e21e
LW		 4190 else
4191 sv_setpv(sv, pent->p_name);
4192 }
4193 RETURN;
4194 }
4195
4196 if (pent) {
3280af22 4197 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4198 sv_setpv(sv, pent->p_name);
3280af22 4199 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 4200 for (elem = pent->p_aliases; elem && *elem; elem++) {
a0d0e21e
LW		 4201 sv_catpv(sv, *elem);
4202 if (elem[1])
4203 sv_catpvn(sv, " ", 1);
4204 }
3280af22 4205 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4206 sv_setiv(sv, (IV)pent->p_proto);
a0d0e21e
LW		 4207 }
4208
4209 RETURN;
4210#else
22c35a8c 4211 DIE(PL_no_sock_func, "getprotoent");
a0d0e21e
LW		 4212#endif
4213}
4214
4215PP(pp_gsbyname)
4216{
9ec75305 4217#ifdef HAS_GETSERVBYNAME
a0d0e21e
LW		 4218 return pp_gservent(ARGS);
4219#else
22c35a8c 4220 DIE(PL_no_sock_func, "getservbyname");
a0d0e21e
LW		 4221#endif
4222}
4223
4224PP(pp_gsbyport)
4225{
9ec75305 4226#ifdef HAS_GETSERVBYPORT
a0d0e21e
LW		 4227 return pp_gservent(ARGS);
4228#else
22c35a8c 4229 DIE(PL_no_sock_func, "getservbyport");
a0d0e21e
LW		 4230#endif
4231}
4232
4233PP(pp_gservent)
4234{
4e35701f 4235 djSP;
693762b4 4236#if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
533c011a 4237 I32 which = PL_op->op_type;
a0d0e21e
LW		 4238 register char **elem;
4239 register SV *sv;
dc45a647 4240#ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4599a1de
JH		 4241 struct servent *PerlSock_getservbyname(Netdb_name_t, Netdb_name_t);
4242 struct servent *PerlSock_getservbyport(int, Netdb_name_t);
6ad3d225 4243 struct servent *PerlSock_getservent(void);
8ac85365 4244#endif
a0d0e21e 4245 struct servent *sent;
2d8e6c8d 4246 STRLEN n_a;
a0d0e21e
LW		 4247
4248 if (which == OP_GSBYNAME) {
dc45a647 4249#ifdef HAS_GETSERVBYNAME
2d8e6c8d
GS		 4250 char *proto = POPpx;
4251 char *name = POPpx;
a0d0e21e
LW		 4252
4253 if (proto && !*proto)
4254 proto = Nullch;
4255
6ad3d225 4256 sent = PerlSock_getservbyname(name, proto);
dc45a647 4257#else
22c35a8c 4258 DIE(PL_no_sock_func, "getservbyname");
dc45a647 4259#endif
a0d0e21e
LW		 4260 }
4261 else if (which == OP_GSBYPORT) {
dc45a647 4262#ifdef HAS_GETSERVBYPORT
2d8e6c8d 4263 char *proto = POPpx;
36477c24 4264 unsigned short port = POPu;
a0d0e21e 4265
36477c24 4266#ifdef HAS_HTONS
6ad3d225 4267 port = PerlSock_htons(port);
36477c24 4268#endif
6ad3d225 4269 sent = PerlSock_getservbyport(port, proto);
dc45a647 4270#else
22c35a8c 4271 DIE(PL_no_sock_func, "getservbyport");
dc45a647 4272#endif
a0d0e21e
LW		 4273 }
4274 else
e5c9fcd0 4275#ifdef HAS_GETSERVENT
6ad3d225 4276 sent = PerlSock_getservent();
e5c9fcd0 4277#else
22c35a8c 4278 DIE(PL_no_sock_func, "getservent");
e5c9fcd0 4279#endif
a0d0e21e
LW		 4280
4281 EXTEND(SP, 4);
4282 if (GIMME != G_ARRAY) {
4283 PUSHs(sv = sv_newmortal());
4284 if (sent) {
4285 if (which == OP_GSBYNAME) {
4286#ifdef HAS_NTOHS
6ad3d225 4287 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
a0d0e21e 4288#else
1e422769 4289 sv_setiv(sv, (IV)(sent->s_port));
a0d0e21e
LW		 4290#endif
4291 }
4292 else
4293 sv_setpv(sv, sent->s_name);
4294 }
4295 RETURN;
4296 }
4297
4298 if (sent) {
3280af22 4299 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4300 sv_setpv(sv, sent->s_name);
3280af22 4301 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 4302 for (elem = sent->s_aliases; elem && *elem; elem++) {
a0d0e21e
LW		 4303 sv_catpv(sv, *elem);
4304 if (elem[1])
4305 sv_catpvn(sv, " ", 1);
4306 }
3280af22 4307 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4308#ifdef HAS_NTOHS
76e3520e 4309 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
a0d0e21e 4310#else
1e422769 4311 sv_setiv(sv, (IV)(sent->s_port));
a0d0e21e 4312#endif
3280af22 4313 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 4314 sv_setpv(sv, sent->s_proto);
4315 }
4316
4317 RETURN;
4318#else
22c35a8c 4319 DIE(PL_no_sock_func, "getservent");
a0d0e21e
LW		 4320#endif
4321}
4322
4323PP(pp_shostent)
4324{
4e35701f 4325 djSP;
693762b4 4326#ifdef HAS_SETHOSTENT
76e3520e 4327 PerlSock_sethostent(TOPi);
a0d0e21e
LW		 4328 RETSETYES;
4329#else
22c35a8c 4330 DIE(PL_no_sock_func, "sethostent");
a0d0e21e
LW		 4331#endif
4332}
4333
4334PP(pp_snetent)
4335{
4e35701f 4336 djSP;
693762b4 4337#ifdef HAS_SETNETENT
76e3520e 4338 PerlSock_setnetent(TOPi);
a0d0e21e
LW		 4339 RETSETYES;
4340#else
22c35a8c 4341 DIE(PL_no_sock_func, "setnetent");
a0d0e21e
LW		 4342#endif
4343}
4344
4345PP(pp_sprotoent)
4346{
4e35701f 4347 djSP;
693762b4 4348#ifdef HAS_SETPROTOENT
76e3520e 4349 PerlSock_setprotoent(TOPi);
a0d0e21e
LW		 4350 RETSETYES;
4351#else
22c35a8c 4352 DIE(PL_no_sock_func, "setprotoent");
a0d0e21e
LW		 4353#endif
4354}
4355
4356PP(pp_sservent)
4357{
4e35701f 4358 djSP;
693762b4 4359#ifdef HAS_SETSERVENT
76e3520e 4360 PerlSock_setservent(TOPi);
a0d0e21e
LW		 4361 RETSETYES;
4362#else
22c35a8c 4363 DIE(PL_no_sock_func, "setservent");
a0d0e21e
LW		 4364#endif
4365}
4366
4367PP(pp_ehostent)
4368{
4e35701f 4369 djSP;
693762b4 4370#ifdef HAS_ENDHOSTENT
76e3520e 4371 PerlSock_endhostent();
924508f0 4372 EXTEND(SP,1);
a0d0e21e
LW		 4373 RETPUSHYES;
4374#else
22c35a8c 4375 DIE(PL_no_sock_func, "endhostent");
a0d0e21e
LW		 4376#endif
4377}
4378
4379PP(pp_enetent)
4380{
4e35701f 4381 djSP;
693762b4 4382#ifdef HAS_ENDNETENT
76e3520e 4383 PerlSock_endnetent();
924508f0 4384 EXTEND(SP,1);
a0d0e21e
LW		 4385 RETPUSHYES;
4386#else
22c35a8c 4387 DIE(PL_no_sock_func, "endnetent");
a0d0e21e
LW		 4388#endif
4389}
4390
4391PP(pp_eprotoent)
4392{
4e35701f 4393 djSP;
693762b4 4394#ifdef HAS_ENDPROTOENT
76e3520e 4395 PerlSock_endprotoent();
924508f0 4396 EXTEND(SP,1);
a0d0e21e
LW		 4397 RETPUSHYES;
4398#else
22c35a8c 4399 DIE(PL_no_sock_func, "endprotoent");
a0d0e21e
LW		 4400#endif
4401}
4402
4403PP(pp_eservent)
4404{
4e35701f 4405 djSP;
693762b4 4406#ifdef HAS_ENDSERVENT
76e3520e 4407 PerlSock_endservent();
924508f0 4408 EXTEND(SP,1);
a0d0e21e
LW		 4409 RETPUSHYES;
4410#else
22c35a8c 4411 DIE(PL_no_sock_func, "endservent");
a0d0e21e
LW		 4412#endif
4413}
4414
4415PP(pp_gpwnam)
4416{
4417#ifdef HAS_PASSWD
4418 return pp_gpwent(ARGS);
4419#else
22c35a8c 4420 DIE(PL_no_func, "getpwnam");
a0d0e21e
LW		 4421#endif
4422}
4423
4424PP(pp_gpwuid)
4425{
4426#ifdef HAS_PASSWD
4427 return pp_gpwent(ARGS);
4428#else
22c35a8c 4429 DIE(PL_no_func, "getpwuid");
a0d0e21e
LW		 4430#endif
4431}
4432
4433PP(pp_gpwent)
4434{
4e35701f 4435 djSP;
28e8609d 4436#if defined(HAS_PASSWD) && defined(HAS_GETPWENT)
533c011a 4437 I32 which = PL_op->op_type;
a0d0e21e
LW		 4438 register SV *sv;
4439 struct passwd *pwent;
2d8e6c8d 4440 STRLEN n_a;
a0d0e21e
LW		 4441
4442 if (which == OP_GPWNAM)
2d8e6c8d 4443 pwent = getpwnam(POPpx);
a0d0e21e
LW		 4444 else if (which == OP_GPWUID)
4445 pwent = getpwuid(POPi);
4446 else
4447 pwent = (struct passwd *)getpwent();
4448
4449 EXTEND(SP, 10);
4450 if (GIMME != G_ARRAY) {
4451 PUSHs(sv = sv_newmortal());
4452 if (pwent) {
4453 if (which == OP_GPWNAM)
1e422769 4454 sv_setiv(sv, (IV)pwent->pw_uid);
a0d0e21e
LW		 4455 else
4456 sv_setpv(sv, pwent->pw_name);
4457 }
4458 RETURN;
4459 }
4460
4461 if (pwent) {
3280af22 4462 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4463 sv_setpv(sv, pwent->pw_name);
6ee623d5 4464
3280af22 4465 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
28e8609d 4466#ifdef PWPASSWD
a0d0e21e 4467 sv_setpv(sv, pwent->pw_passwd);
28e8609d 4468#endif
6ee623d5 4469
3280af22 4470 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4471 sv_setiv(sv, (IV)pwent->pw_uid);
6ee623d5 4472
3280af22 4473 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4474 sv_setiv(sv, (IV)pwent->pw_gid);
6ee623d5
GS		 4475
4476 /* pw_change, pw_quota, and pw_age are mutually exclusive. */
3280af22 4477 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4478#ifdef PWCHANGE
1e422769 4479 sv_setiv(sv, (IV)pwent->pw_change);
a0d0e21e 4480#else
6ee623d5 4481# ifdef PWQUOTA
1e422769 4482 sv_setiv(sv, (IV)pwent->pw_quota);
6ee623d5
GS		 4483# else
4484# ifdef PWAGE
a0d0e21e 4485 sv_setpv(sv, pwent->pw_age);
6ee623d5
GS		 4486# endif
4487# endif
a0d0e21e 4488#endif
6ee623d5
GS		 4489
4490 /* pw_class and pw_comment are mutually exclusive. */
3280af22 4491 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 4492#ifdef PWCLASS
4493 sv_setpv(sv, pwent->pw_class);
4494#else
6ee623d5 4495# ifdef PWCOMMENT
a0d0e21e 4496 sv_setpv(sv, pwent->pw_comment);
6ee623d5 4497# endif
a0d0e21e 4498#endif
6ee623d5 4499
3280af22 4500 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
6ee623d5 4501#ifdef PWGECOS
a0d0e21e 4502 sv_setpv(sv, pwent->pw_gecos);
6ee623d5 4503#endif
fb73857a 4504#ifndef INCOMPLETE_TAINTS
d2719217 4505 /* pw_gecos is tainted because user himself can diddle with it. */
fb73857a 4506 SvTAINTED_on(sv);
4507#endif
6ee623d5 4508
3280af22 4509 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4510 sv_setpv(sv, pwent->pw_dir);
6ee623d5 4511
3280af22 4512 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4513 sv_setpv(sv, pwent->pw_shell);
6ee623d5 4514
a0d0e21e 4515#ifdef PWEXPIRE
6b88bc9c 4516 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4517 sv_setiv(sv, (IV)pwent->pw_expire);
a0d0e21e
LW		 4518#endif
4519 }
4520 RETURN;
4521#else
22c35a8c 4522 DIE(PL_no_func, "getpwent");
a0d0e21e
LW		 4523#endif
4524}
4525
4526PP(pp_spwent)
4527{
4e35701f 4528 djSP;
28e8609d 4529#if defined(HAS_PASSWD) && defined(HAS_SETPWENT) && !defined(CYGWIN32)
a0d0e21e
LW		 4530 setpwent();
4531 RETPUSHYES;
4532#else
22c35a8c 4533 DIE(PL_no_func, "setpwent");
a0d0e21e
LW		 4534#endif
4535}
4536
4537PP(pp_epwent)
4538{
4e35701f 4539 djSP;
28e8609d 4540#if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
a0d0e21e
LW		 4541 endpwent();
4542 RETPUSHYES;
4543#else
22c35a8c 4544 DIE(PL_no_func, "endpwent");
a0d0e21e
LW		 4545#endif
4546}
4547
4548PP(pp_ggrnam)
4549{
4550#ifdef HAS_GROUP
4551 return pp_ggrent(ARGS);
4552#else
22c35a8c 4553 DIE(PL_no_func, "getgrnam");
a0d0e21e
LW		 4554#endif
4555}
4556
4557PP(pp_ggrgid)
4558{
4559#ifdef HAS_GROUP
4560 return pp_ggrent(ARGS);
4561#else
22c35a8c 4562 DIE(PL_no_func, "getgrgid");
a0d0e21e
LW		 4563#endif
4564}
4565
4566PP(pp_ggrent)
4567{
4e35701f 4568 djSP;
28e8609d 4569#if defined(HAS_GROUP) && defined(HAS_GETGRENT)
533c011a 4570 I32 which = PL_op->op_type;
a0d0e21e
LW		 4571 register char **elem;
4572 register SV *sv;
4573 struct group *grent;
2d8e6c8d 4574 STRLEN n_a;
a0d0e21e
LW		 4575
4576 if (which == OP_GGRNAM)
2d8e6c8d 4577 grent = (struct group *)getgrnam(POPpx);
a0d0e21e
LW		 4578 else if (which == OP_GGRGID)
4579 grent = (struct group *)getgrgid(POPi);
4580 else
4581 grent = (struct group *)getgrent();
4582
4583 EXTEND(SP, 4);
4584 if (GIMME != G_ARRAY) {
4585 PUSHs(sv = sv_newmortal());
4586 if (grent) {
4587 if (which == OP_GGRNAM)
1e422769 4588 sv_setiv(sv, (IV)grent->gr_gid);
a0d0e21e
LW		 4589 else
4590 sv_setpv(sv, grent->gr_name);
4591 }
4592 RETURN;
4593 }
4594
4595 if (grent) {
3280af22 4596 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4597 sv_setpv(sv, grent->gr_name);
28e8609d 4598
3280af22 4599 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
28e8609d 4600#ifdef GRPASSWD
a0d0e21e 4601 sv_setpv(sv, grent->gr_passwd);
28e8609d
JH		 4602#endif
4603
3280af22 4604 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4605 sv_setiv(sv, (IV)grent->gr_gid);
28e8609d 4606
3280af22 4607 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 4608 for (elem = grent->gr_mem; elem && *elem; elem++) {
a0d0e21e
LW		 4609 sv_catpv(sv, *elem);
4610 if (elem[1])
4611 sv_catpvn(sv, " ", 1);
4612 }
4613 }
4614
4615 RETURN;
4616#else
22c35a8c 4617 DIE(PL_no_func, "getgrent");
a0d0e21e
LW		 4618#endif
4619}
4620
4621PP(pp_sgrent)
4622{
4e35701f 4623 djSP;
28e8609d 4624#if defined(HAS_GROUP) && defined(HAS_SETGRENT)
a0d0e21e
LW		 4625 setgrent();
4626 RETPUSHYES;
4627#else
22c35a8c 4628 DIE(PL_no_func, "setgrent");
a0d0e21e
LW		 4629#endif
4630}
4631
4632PP(pp_egrent)
4633{
4e35701f 4634 djSP;
28e8609d 4635#if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
a0d0e21e
LW		 4636 endgrent();
4637 RETPUSHYES;
4638#else
22c35a8c 4639 DIE(PL_no_func, "endgrent");
a0d0e21e
LW		 4640#endif
4641}
4642
4643PP(pp_getlogin)
4644{
4e35701f 4645 djSP; dTARGET;
a0d0e21e
LW		 4646#ifdef HAS_GETLOGIN
4647 char *tmps;
4648 EXTEND(SP, 1);
76e3520e 4649 if (!(tmps = PerlProc_getlogin()))
a0d0e21e
LW		 4650 RETPUSHUNDEF;
4651 PUSHp(tmps, strlen(tmps));
4652 RETURN;
4653#else
22c35a8c 4654 DIE(PL_no_func, "getlogin");
a0d0e21e
LW		 4655#endif
4656}
4657
4658/* Miscellaneous. */
4659
4660PP(pp_syscall)
4661{
d2719217 4662#ifdef HAS_SYSCALL
4e35701f 4663 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW		 4664 register I32 items = SP - MARK;
4665 unsigned long a[20];
4666 register I32 i = 0;
4667 I32 retval = -1;
748a9306 4668 MAGIC *mg;
2d8e6c8d 4669 STRLEN n_a;
a0d0e21e 4670
3280af22 4671 if (PL_tainting) {
a0d0e21e 4672 while (++MARK <= SP) {
bbce6d69 4673 if (SvTAINTED(*MARK)) {
4674 TAINT;
4675 break;
4676 }
a0d0e21e
LW		 4677 }
4678 MARK = ORIGMARK;
4679 TAINT_PROPER("syscall");
4680 }
4681
4682 /* This probably won't work on machines where sizeof(long) != sizeof(int)
4683 * or where sizeof(long) != sizeof(char*). But such machines will
4684 * not likely have syscall implemented either, so who cares?
4685 */
4686 while (++MARK <= SP) {
4687 if (SvNIOK(*MARK) || !i)
4688 a[i++] = SvIV(*MARK);
3280af22 4689 else if (*MARK == &PL_sv_undef)
748a9306
LW		 4690 a[i++] = 0;
4691 else
2d8e6c8d 4692 a[i++] = (unsigned long)SvPV_force(*MARK, n_a);
a0d0e21e
LW		 4693 if (i > 15)
4694 break;
4695 }
4696 switch (items) {
4697 default:
4698 DIE("Too many args to syscall");
4699 case 0:
4700 DIE("Too few args to syscall");
4701 case 1:
4702 retval = syscall(a[0]);
4703 break;
4704 case 2:
4705 retval = syscall(a[0],a[1]);
4706 break;
4707 case 3:
4708 retval = syscall(a[0],a[1],a[2]);
4709 break;
4710 case 4:
4711 retval = syscall(a[0],a[1],a[2],a[3]);
4712 break;
4713 case 5:
4714 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
4715 break;
4716 case 6:
4717 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
4718 break;
4719 case 7:
4720 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
4721 break;
4722 case 8:
4723 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
4724 break;
4725#ifdef atarist
4726 case 9:
4727 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
4728 break;
4729 case 10:
4730 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
4731 break;
4732 case 11:
4733 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
4734 a[10]);
4735 break;
4736 case 12:
4737 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
4738 a[10],a[11]);
4739 break;
4740 case 13:
4741 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
4742 a[10],a[11],a[12]);
4743 break;
4744 case 14:
4745 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
4746 a[10],a[11],a[12],a[13]);
4747 break;
4748#endif /* atarist */
4749 }
4750 SP = ORIGMARK;
4751 PUSHi(retval);
4752 RETURN;
4753#else
22c35a8c 4754 DIE(PL_no_func, "syscall");
a0d0e21e
LW		 4755#endif
4756}
4757
ff68c719 4758#ifdef FCNTL_EMULATE_FLOCK
4759
4760/* XXX Emulate flock() with fcntl().
4761 What's really needed is a good file locking module.
4762*/
4763
4764static int
8ac85365 4765fcntl_emulate_flock(int fd, int operation)
ff68c719 4766{
4767 struct flock flock;
4768
4769 switch (operation & ~LOCK_NB) {
4770 case LOCK_SH:
4771 flock.l_type = F_RDLCK;
4772 break;
4773 case LOCK_EX:
4774 flock.l_type = F_WRLCK;
4775 break;
4776 case LOCK_UN:
4777 flock.l_type = F_UNLCK;
4778 break;
4779 default:
4780 errno = EINVAL;
4781 return -1;
4782 }
4783 flock.l_whence = SEEK_SET;
4784 flock.l_start = flock.l_len = 0L;
4785
4786 return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
4787}
4788
4789#endif /* FCNTL_EMULATE_FLOCK */
4790
4791#ifdef LOCKF_EMULATE_FLOCK
16d20bd9
AD		 4792
4793/* XXX Emulate flock() with lockf(). This is just to increase
4794 portability of scripts. The calls are not completely
4795 interchangeable. What's really needed is a good file
4796 locking module.
4797*/
4798
76c32331 4799/* The lockf() constants might have been defined in <unistd.h>.
4800 Unfortunately, <unistd.h> causes troubles on some mixed
4801 (BSD/POSIX) systems, such as SunOS 4.1.3.
16d20bd9
AD		 4802
4803 Further, the lockf() constants aren't POSIX, so they might not be
4804 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
4805 just stick in the SVID values and be done with it. Sigh.
4806*/
4807
4808# ifndef F_ULOCK
4809# define F_ULOCK 0 /* Unlock a previously locked region */
4810# endif
4811# ifndef F_LOCK
4812# define F_LOCK 1 /* Lock a region for exclusive use */
4813# endif
4814# ifndef F_TLOCK
4815# define F_TLOCK 2 /* Test and lock a region for exclusive use */
4816# endif
4817# ifndef F_TEST
4818# define F_TEST 3 /* Test a region for other processes locks */
4819# endif
4820
55497cff 4821static int
16d20bd9
AD		 4822lockf_emulate_flock (fd, operation)
4823int fd;
4824int operation;
4825{
4826 int i;
84902520
TB		 4827 int save_errno;
4828 Off_t pos;
4829
4830 /* flock locks entire file so for lockf we need to do the same */
4831 save_errno = errno;
6ad3d225 4832 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
84902520 4833 if (pos > 0) /* is seekable and needs to be repositioned */
6ad3d225 4834 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
08b714dd 4835 pos = -1; /* seek failed, so don't seek back afterwards */
84902520
TB		 4836 errno = save_errno;
4837
16d20bd9
AD		 4838 switch (operation) {
4839
4840 /* LOCK_SH - get a shared lock */
4841 case LOCK_SH:
4842 /* LOCK_EX - get an exclusive lock */
4843 case LOCK_EX:
4844 i = lockf (fd, F_LOCK, 0);
4845 break;
4846
4847 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
4848 case LOCK_SH|LOCK_NB:
4849 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
4850 case LOCK_EX|LOCK_NB:
4851 i = lockf (fd, F_TLOCK, 0);
4852 if (i == -1)
4853 if ((errno == EAGAIN) || (errno == EACCES))
4854 errno = EWOULDBLOCK;
4855 break;
4856
ff68c719 4857 /* LOCK_UN - unlock (non-blocking is a no-op) */
16d20bd9 4858 case LOCK_UN:
ff68c719 4859 case LOCK_UN|LOCK_NB:
16d20bd9
AD		 4860 i = lockf (fd, F_ULOCK, 0);
4861 break;
4862
4863 /* Default - can't decipher operation */
4864 default:
4865 i = -1;
4866 errno = EINVAL;
4867 break;
4868 }
84902520
TB		 4869
4870 if (pos > 0) /* need to restore position of the handle */
6ad3d225 4871 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
84902520 4872
16d20bd9
AD		 4873 return (i);
4874}
ff68c719 4875
4876#endif /* LOCKF_EMULATE_FLOCK */
Unnamed repository; edit this file 'description' to name the repository.