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
Add non-blocking thread doneness checking
[perl5.git] / pp_sys.c
CommitLineData
a0d0e21e
LW		 1/* pp_sys.c
2 *
cb50131a 3 * Copyright (c) 1991-2000, 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"
864dbfa3 18#define PERL_IN_PP_SYS_C
a0d0e21e
LW		 19#include "perl.h"
20
f1066039
JH		 21#ifdef I_SHADOW
22/* Shadow password support for solaris - pdo@cs.umd.edu
23 * Not just Solaris: at least HP-UX, IRIX, Linux.
3813c136
JH		 24 * The API is from SysV.
25 *
26 * There are at least two more shadow interfaces,
27 * see the comments in pp_gpwent().
28 *
29 * --jhi */
30# ifdef __hpux__
c529f79d 31/* There is a MAXINT coming from <shadow.h> <- <hpsecurity.h> <- <values.h>
301e8125 32 * and another MAXINT from "perl.h" <- <sys/param.h>. */
3813c136
JH		 33# undef MAXINT
34# endif
35# include <shadow.h>
8c0bfa08
PB		 36#endif
37
76c32331 38/* XXX If this causes problems, set i_unistd=undef in the hint file. */
39#ifdef I_UNISTD
40# include <unistd.h>
41#endif
42
301e8125
NIS		 43#ifdef HAS_SYSCALL
44#ifdef __cplusplus
8ac85365
NIS		 45extern "C" int syscall(unsigned long,...);
46#endif
47#endif
48
76c32331 49#ifdef I_SYS_WAIT
50# include <sys/wait.h>
51#endif
52
53#ifdef I_SYS_RESOURCE
54# include <sys/resource.h>
16d20bd9 55#endif
a0d0e21e
LW		 56
57#if defined(HAS_SOCKET) && !defined(VMS) /* VMS handles sockets via vmsish.h */
58# include <sys/socket.h>
29209bc5 59# if defined(USE_SOCKS) && defined(I_SOCKS)
f269dd06
JH		 60# if !defined(INCLUDE_PROTOTYPES)
61# define INCLUDE_PROTOTYPES /* for <socks.h> */
62# define PERL_SOCKS_NEED_PROTOTYPES
63# endif
86959918 64# include <socks.h>
f269dd06
JH		 65# ifdef PERL_SOCKS_NEED_PROTOTYPES /* keep cpp space clean */
66# undef INCLUDE_PROTOTYPES
67# undef PERL_SOCKS_NEED_PROTOTYPES
68# endif
301e8125 69# endif
3fd537d4
JH		 70# ifdef I_NETDB
71# include <netdb.h>
72# endif
a0d0e21e
LW		 73# ifndef ENOTSOCK
74# ifdef I_NET_ERRNO
75# include <net/errno.h>
76# endif
77# endif
78#endif
79
80#ifdef HAS_SELECT
81#ifdef I_SYS_SELECT
a0d0e21e
LW		 82#include <sys/select.h>
83#endif
84#endif
a0d0e21e 85
dc45a647
MB		 86/* XXX Configure test needed.
87 h_errno might not be a simple 'int', especially for multi-threaded
5ff3f7a4
GS		 88 applications, see "extern int errno in perl.h". Creating such
89 a test requires taking into account the differences between
90 compiling multithreaded and singlethreaded ($ccflags et al).
91 HOST_NOT_FOUND is typically defined in <netdb.h>.
dc45a647 92*/
cb50131a 93#if defined(HOST_NOT_FOUND) && !defined(h_errno) && !defined(__CYGWIN__)
a0d0e21e
LW		 94extern int h_errno;
95#endif
96
97#ifdef HAS_PASSWD
98# ifdef I_PWD
99# include <pwd.h>
100# else
20ce7b12
GS		 101 struct passwd *getpwnam (char *);
102 struct passwd *getpwuid (Uid_t);
a0d0e21e 103# endif
28e8609d 104# ifdef HAS_GETPWENT
20ce7b12 105 struct passwd *getpwent (void);
28e8609d 106# endif
a0d0e21e
LW		 107#endif
108
109#ifdef HAS_GROUP
110# ifdef I_GRP
111# include <grp.h>
112# else
20ce7b12
GS		 113 struct group *getgrnam (char *);
114 struct group *getgrgid (Gid_t);
a0d0e21e 115# endif
28e8609d 116# ifdef HAS_GETGRENT
20ce7b12 117 struct group *getgrent (void);
28e8609d 118# endif
a0d0e21e
LW		 119#endif
120
121#ifdef I_UTIME
3730b96e 122# if defined(_MSC_VER) || defined(__MINGW32__)
3fe9a6f1 123# include <sys/utime.h>
124# else
125# include <utime.h>
126# endif
a0d0e21e 127#endif
a0d0e21e 128
54310121 129/* Put this after #includes because fork and vfork prototypes may conflict. */
130#ifndef HAS_VFORK
131# define vfork fork
132#endif
133
cbdc8872 134#ifdef HAS_CHSIZE
cd52b7b2 135# ifdef my_chsize /* Probably #defined to Perl_my_chsize in embed.h */
136# undef my_chsize
137# endif
6ad3d225 138# define my_chsize PerlLIO_chsize
cbdc8872 139#endif
140
ff68c719 141#ifdef HAS_FLOCK
142# define FLOCK flock
143#else /* no flock() */
144
36477c24 145 /* fcntl.h might not have been included, even if it exists, because
146 the current Configure only sets I_FCNTL if it's needed to pick up
147 the *_OK constants. Make sure it has been included before testing
148 the fcntl() locking constants. */
149# if defined(HAS_FCNTL) && !defined(I_FCNTL)
150# include <fcntl.h>
151# endif
152
ff68c719 153# if defined(HAS_FCNTL) && defined(F_SETLK) && defined (F_SETLKW)
154# define FLOCK fcntl_emulate_flock
155# define FCNTL_EMULATE_FLOCK
156# else /* no flock() or fcntl(F_SETLK,...) */
157# ifdef HAS_LOCKF
158# define FLOCK lockf_emulate_flock
159# define LOCKF_EMULATE_FLOCK
160# endif /* lockf */
161# endif /* no flock() or fcntl(F_SETLK,...) */
162
163# ifdef FLOCK
20ce7b12 164 static int FLOCK (int, int);
ff68c719 165
166 /*
167 * These are the flock() constants. Since this sytems doesn't have
168 * flock(), the values of the constants are probably not available.
169 */
170# ifndef LOCK_SH
171# define LOCK_SH 1
172# endif
173# ifndef LOCK_EX
174# define LOCK_EX 2
175# endif
176# ifndef LOCK_NB
177# define LOCK_NB 4
178# endif
179# ifndef LOCK_UN
180# define LOCK_UN 8
181# endif
182# endif /* emulating flock() */
183
184#endif /* no flock() */
55497cff 185
85ab1d1d
JH		 186#define ZBTLEN 10
187static char zero_but_true[ZBTLEN + 1] = "0 but true";
188
5ff3f7a4
GS		 189#if defined(I_SYS_ACCESS) && !defined(R_OK)
190# include <sys/access.h>
191#endif
192
c529f79d
CB		 193#if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
194# define FD_CLOEXEC 1 /* NeXT needs this */
195#endif
196
5ff3f7a4
GS		 197#undef PERL_EFF_ACCESS_R_OK /* EFFective uid/gid ACCESS R_OK */
198#undef PERL_EFF_ACCESS_W_OK
199#undef PERL_EFF_ACCESS_X_OK
200
201/* F_OK unused: if stat() cannot find it... */
202
203#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_ACCESS) && defined(EFF_ONLY_OK) && !defined(NO_EFF_ONLY_OK)
c955f117 204 /* Digital UNIX (when the EFF_ONLY_OK gets fixed), UnixWare */
5ff3f7a4
GS		 205# define PERL_EFF_ACCESS_R_OK(p) (access((p), R_OK | EFF_ONLY_OK))
206# define PERL_EFF_ACCESS_W_OK(p) (access((p), W_OK | EFF_ONLY_OK))
207# define PERL_EFF_ACCESS_X_OK(p) (access((p), X_OK | EFF_ONLY_OK))
208#endif
209
210#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_EACCESS)
3813c136 211# ifdef I_SYS_SECURITY
5ff3f7a4
GS		 212# include <sys/security.h>
213# endif
c955f117
JH		 214# ifdef ACC_SELF
215 /* HP SecureWare */
216# define PERL_EFF_ACCESS_R_OK(p) (eaccess((p), R_OK, ACC_SELF))
217# define PERL_EFF_ACCESS_W_OK(p) (eaccess((p), W_OK, ACC_SELF))
218# define PERL_EFF_ACCESS_X_OK(p) (eaccess((p), X_OK, ACC_SELF))
219# else
220 /* SCO */
221# define PERL_EFF_ACCESS_R_OK(p) (eaccess((p), R_OK))
222# define PERL_EFF_ACCESS_W_OK(p) (eaccess((p), W_OK))
223# define PERL_EFF_ACCESS_X_OK(p) (eaccess((p), X_OK))
224# endif
5ff3f7a4
GS		 225#endif
226
227#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_ACCESSX) && defined(ACC_SELF)
c955f117 228 /* AIX */
5ff3f7a4
GS		 229# define PERL_EFF_ACCESS_R_OK(p) (accessx((p), R_OK, ACC_SELF))
230# define PERL_EFF_ACCESS_W_OK(p) (accessx((p), W_OK, ACC_SELF))
231# define PERL_EFF_ACCESS_X_OK(p) (accessx((p), X_OK, ACC_SELF))
232#endif
233
327c3667
GS		 234#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_ACCESS) \
235 && (defined(HAS_SETREUID) || defined(HAS_SETRESUID) \
236 || defined(HAS_SETREGID) || defined(HAS_SETRESGID))
5ff3f7a4 237/* The Hard Way. */
327c3667 238STATIC int
7f4774ae 239S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
ba106d47 240{
5ff3f7a4
GS		 241 Uid_t ruid = getuid();
242 Uid_t euid = geteuid();
243 Gid_t rgid = getgid();
244 Gid_t egid = getegid();
245 int res;
246
146174a9 247 LOCK_CRED_MUTEX;
5ff3f7a4 248#if !defined(HAS_SETREUID) && !defined(HAS_SETRESUID)
cea2e8a9 249 Perl_croak(aTHX_ "switching effective uid is not implemented");
5ff3f7a4
GS		 250#else
251#ifdef HAS_SETREUID
252 if (setreuid(euid, ruid))
253#else
254#ifdef HAS_SETRESUID
255 if (setresuid(euid, ruid, (Uid_t)-1))
256#endif
257#endif
cea2e8a9 258 Perl_croak(aTHX_ "entering effective uid failed");
5ff3f7a4
GS		 259#endif
260
261#if !defined(HAS_SETREGID) && !defined(HAS_SETRESGID)
cea2e8a9 262 Perl_croak(aTHX_ "switching effective gid is not implemented");
5ff3f7a4
GS		 263#else
264#ifdef HAS_SETREGID
265 if (setregid(egid, rgid))
266#else
267#ifdef HAS_SETRESGID
268 if (setresgid(egid, rgid, (Gid_t)-1))
269#endif
270#endif
cea2e8a9 271 Perl_croak(aTHX_ "entering effective gid failed");
5ff3f7a4
GS		 272#endif
273
274 res = access(path, mode);
275
276#ifdef HAS_SETREUID
277 if (setreuid(ruid, euid))
278#else
279#ifdef HAS_SETRESUID
280 if (setresuid(ruid, euid, (Uid_t)-1))
281#endif
282#endif
cea2e8a9 283 Perl_croak(aTHX_ "leaving effective uid failed");
5ff3f7a4
GS		 284
285#ifdef HAS_SETREGID
286 if (setregid(rgid, egid))
287#else
288#ifdef HAS_SETRESGID
289 if (setresgid(rgid, egid, (Gid_t)-1))
290#endif
291#endif
cea2e8a9 292 Perl_croak(aTHX_ "leaving effective gid failed");
146174a9 293 UNLOCK_CRED_MUTEX;
5ff3f7a4
GS		 294
295 return res;
296}
297# define PERL_EFF_ACCESS_R_OK(p) (emulate_eaccess((p), R_OK))
298# define PERL_EFF_ACCESS_W_OK(p) (emulate_eaccess((p), W_OK))
299# define PERL_EFF_ACCESS_X_OK(p) (emulate_eaccess((p), X_OK))
300#endif
301
302#if !defined(PERL_EFF_ACCESS_R_OK)
327c3667 303STATIC int
7f4774ae 304S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
ba106d47 305{
cea2e8a9 306 Perl_croak(aTHX_ "switching effective uid is not implemented");
5ff3f7a4
GS		 307 /*NOTREACHED*/
308 return -1;
309}
310#endif
311
a0d0e21e
LW		 312PP(pp_backtick)
313{
4e35701f 314 djSP; dTARGET;
760ac839 315 PerlIO *fp;
2d8e6c8d
GS		 316 STRLEN n_a;
317 char *tmps = POPpx;
54310121 318 I32 gimme = GIMME_V;
16fe6d59 319 char *mode = "r";
54310121 320
a0d0e21e 321 TAINT_PROPER("``");
16fe6d59
GS		 322 if (PL_op->op_private & OPpOPEN_IN_RAW)
323 mode = "rb";
324 else if (PL_op->op_private & OPpOPEN_IN_CRLF)
325 mode = "rt";
326 fp = PerlProc_popen(tmps, mode);
a0d0e21e 327 if (fp) {
54310121 328 if (gimme == G_VOID) {
96827780
MB		 329 char tmpbuf[256];
330 while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0)
54310121 331 /*SUPPRESS 530*/
332 ;
333 }
334 else if (gimme == G_SCALAR) {
aa689395 335 sv_setpv(TARG, ""); /* note that this preserves previous buffer */
a0d0e21e
LW		 336 while (sv_gets(TARG, fp, SvCUR(TARG)) != Nullch)
337 /*SUPPRESS 530*/
338 ;
339 XPUSHs(TARG);
aa689395 340 SvTAINTED_on(TARG);
a0d0e21e
LW		 341 }
342 else {
343 SV *sv;
344
345 for (;;) {
8d6dde3e 346 sv = NEWSV(56, 79);
a0d0e21e
LW		 347 if (sv_gets(sv, fp, 0) == Nullch) {
348 SvREFCNT_dec(sv);
349 break;
350 }
351 XPUSHs(sv_2mortal(sv));
352 if (SvLEN(sv) - SvCUR(sv) > 20) {
353 SvLEN_set(sv, SvCUR(sv)+1);
354 Renew(SvPVX(sv), SvLEN(sv), char);
355 }
aa689395 356 SvTAINTED_on(sv);
a0d0e21e
LW		 357 }
358 }
6ad3d225 359 STATUS_NATIVE_SET(PerlProc_pclose(fp));
aa689395 360 TAINT; /* "I believe that this is not gratuitous!" */
a0d0e21e
LW		 361 }
362 else {
f86702cc 363 STATUS_NATIVE_SET(-1);
54310121 364 if (gimme == G_SCALAR)
a0d0e21e
LW		 365 RETPUSHUNDEF;
366 }
367
368 RETURN;
369}
370
371PP(pp_glob)
372{
373 OP *result;
f5284f61
IZ		 374 tryAMAGICunTARGET(iter, -1);
375
71686f12
GS		 376 /* Note that we only ever get here if File::Glob fails to load
377 * without at the same time croaking, for some reason, or if
378 * perl was built with PERL_EXTERNAL_GLOB */
379
a0d0e21e 380 ENTER;
a0d0e21e 381
c90c0ff4 382#ifndef VMS
3280af22 383 if (PL_tainting) {
7bac28a0 384 /*
385 * The external globbing program may use things we can't control,
386 * so for security reasons we must assume the worst.
387 */
388 TAINT;
22c35a8c 389 taint_proper(PL_no_security, "glob");
7bac28a0 390 }
c90c0ff4 391#endif /* !VMS */
7bac28a0 392
3280af22
NIS		 393 SAVESPTR(PL_last_in_gv); /* We don't want this to be permanent. */
394 PL_last_in_gv = (GV*)*PL_stack_sp--;
a0d0e21e 395
3280af22 396 SAVESPTR(PL_rs); /* This is not permanent, either. */
79cb57f6 397 PL_rs = sv_2mortal(newSVpvn("\000", 1));
c07a80fd 398#ifndef DOSISH
399#ifndef CSH
6b88bc9c 400 *SvPVX(PL_rs) = '\n';
a0d0e21e 401#endif /* !CSH */
55497cff 402#endif /* !DOSISH */
c07a80fd 403
a0d0e21e
LW		 404 result = do_readline();
405 LEAVE;
406 return result;
407}
408
15e52e56 409#if 0 /* XXX never used! */
a0d0e21e
LW		 410PP(pp_indread)
411{
2d8e6c8d
GS		 412 STRLEN n_a;
413 PL_last_in_gv = gv_fetchpv(SvPVx(GvSV((GV*)(*PL_stack_sp--)), n_a), TRUE,SVt_PVIO);
a0d0e21e
LW		 414 return do_readline();
415}
15e52e56 416#endif
a0d0e21e
LW		 417
418PP(pp_rcatline)
419{
146174a9 420 PL_last_in_gv = cGVOP_gv;
a0d0e21e
LW		 421 return do_readline();
422}
423
424PP(pp_warn)
425{
4e35701f 426 djSP; dMARK;
06bf62c7 427 SV *tmpsv;
a0d0e21e 428 char *tmps;
06bf62c7 429 STRLEN len;
a0d0e21e
LW		 430 if (SP - MARK != 1) {
431 dTARGET;
3280af22 432 do_join(TARG, &PL_sv_no, MARK, SP);
06bf62c7 433 tmpsv = TARG;
a0d0e21e
LW		 434 SP = MARK + 1;
435 }
436 else {
06bf62c7 437 tmpsv = TOPs;
a0d0e21e 438 }
06bf62c7
GS		 439 tmps = SvPV(tmpsv, len);
440 if (!tmps || !len) {
4e6ea2c3
GS		 441 SV *error = ERRSV;
442 (void)SvUPGRADE(error, SVt_PV);
443 if (SvPOK(error) && SvCUR(error))
444 sv_catpv(error, "\t...caught");
06bf62c7
GS		 445 tmpsv = error;
446 tmps = SvPV(tmpsv, len);
a0d0e21e 447 }
06bf62c7
GS		 448 if (!tmps || !len)
449 tmpsv = sv_2mortal(newSVpvn("Warning: something's wrong", 26));
450
cb50131a 451 Perl_warn(aTHX_ "%"SVf, tmpsv);
a0d0e21e
LW		 452 RETSETYES;
453}
454
455PP(pp_die)
456{
4e35701f 457 djSP; dMARK;
a0d0e21e 458 char *tmps;
06bf62c7
GS		 459 SV *tmpsv;
460 STRLEN len;
461 bool multiarg = 0;
a0d0e21e
LW		 462 if (SP - MARK != 1) {
463 dTARGET;
3280af22 464 do_join(TARG, &PL_sv_no, MARK, SP);
06bf62c7
GS		 465 tmpsv = TARG;
466 tmps = SvPV(tmpsv, len);
467 multiarg = 1;
a0d0e21e
LW		 468 SP = MARK + 1;
469 }
470 else {
4e6ea2c3 471 tmpsv = TOPs;
06bf62c7 472 tmps = SvROK(tmpsv) ? Nullch : SvPV(tmpsv, len);
a0d0e21e 473 }
06bf62c7 474 if (!tmps || !len) {
4e6ea2c3
GS		 475 SV *error = ERRSV;
476 (void)SvUPGRADE(error, SVt_PV);
06bf62c7
GS		 477 if (multiarg ? SvROK(error) : SvROK(tmpsv)) {
478 if (!multiarg)
4e6ea2c3 479 SvSetSV(error,tmpsv);
06bf62c7 480 else if (sv_isobject(error)) {
05423cc9
GS		 481 HV *stash = SvSTASH(SvRV(error));
482 GV *gv = gv_fetchmethod(stash, "PROPAGATE");
483 if (gv) {
146174a9 484 SV *file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0));
b448e4fe 485 SV *line = sv_2mortal(newSVuv(CopLINE(PL_curcop)));
05423cc9
GS		 486 EXTEND(SP, 3);
487 PUSHMARK(SP);
488 PUSHs(error);
489 PUSHs(file);
490 PUSHs(line);
491 PUTBACK;
864dbfa3
GS		 492 call_sv((SV*)GvCV(gv),
493 G_SCALAR|G_EVAL|G_KEEPERR);
3280af22 494 sv_setsv(error,*PL_stack_sp--);
05423cc9
GS		 495 }
496 }
cea2e8a9 497 DIE(aTHX_ Nullch);
4e6ea2c3
GS		 498 }
499 else {
500 if (SvPOK(error) && SvCUR(error))
501 sv_catpv(error, "\t...propagated");
06bf62c7
GS		 502 tmpsv = error;
503 tmps = SvPV(tmpsv, len);
4e6ea2c3 504 }
a0d0e21e 505 }
06bf62c7
GS		 506 if (!tmps || !len)
507 tmpsv = sv_2mortal(newSVpvn("Died", 4));
508
cb50131a 509 DIE(aTHX_ "%"SVf, tmpsv);
a0d0e21e
LW		 510}
511
512/* I/O. */
513
514PP(pp_open)
515{
4e35701f 516 djSP; dTARGET;
a0d0e21e
LW		 517 GV *gv;
518 SV *sv;
6aa016ca 519 SV *name = Nullsv;
6170680b 520 I32 have_name = 0;
a0d0e21e
LW		 521 char *tmps;
522 STRLEN len;
4592e6ca 523 MAGIC *mg;
a0d0e21e 524
6170680b
IZ		 525 if (MAXARG > 2) {
526 name = POPs;
527 have_name = 1;
528 }
a0d0e21e
LW		 529 if (MAXARG > 1)
530 sv = POPs;
5f05dabc 531 if (!isGV(TOPs))
cea2e8a9 532 DIE(aTHX_ PL_no_usym, "filehandle");
5f05dabc 533 if (MAXARG <= 1)
534 sv = GvSV(TOPs);
a0d0e21e 535 gv = (GV*)POPs;
5f05dabc 536 if (!isGV(gv))
cea2e8a9 537 DIE(aTHX_ PL_no_usym, "filehandle");
36477c24 538 if (GvIOp(gv))
539 IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
853846ea 540
155aba94 541 if ((mg = SvTIED_mg((SV*)gv, 'q'))) {
4592e6ca
NIS		 542 PUSHMARK(SP);
543 XPUSHs(SvTIED_obj((SV*)gv, mg));
544 XPUSHs(sv);
6170680b
IZ		 545 if (have_name)
546 XPUSHs(name);
4592e6ca
NIS		 547 PUTBACK;
548 ENTER;
864dbfa3 549 call_method("OPEN", G_SCALAR);
4592e6ca
NIS		 550 LEAVE;
551 SPAGAIN;
552 RETURN;
553 }
554
a0d0e21e 555 tmps = SvPV(sv, len);
6170680b 556 if (do_open9(gv, tmps, len, FALSE, O_RDONLY, 0, Nullfp, name, have_name))
3280af22
NIS		 557 PUSHi( (I32)PL_forkprocess );
558 else if (PL_forkprocess == 0) /* we are a new child */
a0d0e21e
LW		 559 PUSHi(0);
560 else
561 RETPUSHUNDEF;
562 RETURN;
563}
564
565PP(pp_close)
566{
4e35701f 567 djSP;
a0d0e21e 568 GV *gv;
1d603a67 569 MAGIC *mg;
a0d0e21e
LW		 570
571 if (MAXARG == 0)
3280af22 572 gv = PL_defoutgv;
a0d0e21e
LW		 573 else
574 gv = (GV*)POPs;
1d603a67 575
155aba94 576 if ((mg = SvTIED_mg((SV*)gv, 'q'))) {
1d603a67 577 PUSHMARK(SP);
33c27489 578 XPUSHs(SvTIED_obj((SV*)gv, mg));
1d603a67
GB		 579 PUTBACK;
580 ENTER;
864dbfa3 581 call_method("CLOSE", G_SCALAR);
1d603a67
GB		 582 LEAVE;
583 SPAGAIN;
584 RETURN;
585 }
a0d0e21e 586 EXTEND(SP, 1);
54310121 587 PUSHs(boolSV(do_close(gv, TRUE)));
a0d0e21e
LW		 588 RETURN;
589}
590
591PP(pp_pipe_op)
592{
4e35701f 593 djSP;
a0d0e21e
LW		 594#ifdef HAS_PIPE
595 GV *rgv;
596 GV *wgv;
597 register IO *rstio;
598 register IO *wstio;
599 int fd[2];
600
601 wgv = (GV*)POPs;
602 rgv = (GV*)POPs;
603
604 if (!rgv || !wgv)
605 goto badexit;
606
4633a7c4 607 if (SvTYPE(rgv) != SVt_PVGV || SvTYPE(wgv) != SVt_PVGV)
cea2e8a9 608 DIE(aTHX_ PL_no_usym, "filehandle");
a0d0e21e
LW		 609 rstio = GvIOn(rgv);
610 wstio = GvIOn(wgv);
611
612 if (IoIFP(rstio))
613 do_close(rgv, FALSE);
614 if (IoIFP(wstio))
615 do_close(wgv, FALSE);
616
6ad3d225 617 if (PerlProc_pipe(fd) < 0)
a0d0e21e
LW		 618 goto badexit;
619
760ac839
LW		 620 IoIFP(rstio) = PerlIO_fdopen(fd[0], "r");
621 IoOFP(wstio) = PerlIO_fdopen(fd[1], "w");
a0d0e21e 622 IoIFP(wstio) = IoOFP(wstio);
50952442
JH		 623 IoTYPE(rstio) = IoTYPE_RDONLY;
624 IoTYPE(wstio) = IoTYPE_WRONLY;
a0d0e21e
LW		 625
626 if (!IoIFP(rstio) || !IoOFP(wstio)) {
760ac839 627 if (IoIFP(rstio)) PerlIO_close(IoIFP(rstio));
6ad3d225 628 else PerlLIO_close(fd[0]);
760ac839 629 if (IoOFP(wstio)) PerlIO_close(IoOFP(wstio));
6ad3d225 630 else PerlLIO_close(fd[1]);
a0d0e21e
LW		 631 goto badexit;
632 }
4771b018
GS		 633#if defined(HAS_FCNTL) && defined(F_SETFD)
634 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
635 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
636#endif
a0d0e21e
LW		 637 RETPUSHYES;
638
639badexit:
640 RETPUSHUNDEF;
641#else
cea2e8a9 642 DIE(aTHX_ PL_no_func, "pipe");
a0d0e21e
LW		 643#endif
644}
645
646PP(pp_fileno)
647{
4e35701f 648 djSP; dTARGET;
a0d0e21e
LW		 649 GV *gv;
650 IO *io;
760ac839 651 PerlIO *fp;
4592e6ca
NIS		 652 MAGIC *mg;
653
a0d0e21e
LW		 654 if (MAXARG < 1)
655 RETPUSHUNDEF;
656 gv = (GV*)POPs;
4592e6ca
NIS		 657
658 if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
659 PUSHMARK(SP);
660 XPUSHs(SvTIED_obj((SV*)gv, mg));
661 PUTBACK;
662 ENTER;
864dbfa3 663 call_method("FILENO", G_SCALAR);
4592e6ca
NIS		 664 LEAVE;
665 SPAGAIN;
666 RETURN;
667 }
668
a0d0e21e
LW		 669 if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io)))
670 RETPUSHUNDEF;
760ac839 671 PUSHi(PerlIO_fileno(fp));
a0d0e21e
LW		 672 RETURN;
673}
674
675PP(pp_umask)
676{
4e35701f 677 djSP; dTARGET;
761237fe 678 Mode_t anum;
a0d0e21e
LW		 679
680#ifdef HAS_UMASK
681 if (MAXARG < 1) {
6ad3d225
GS		 682 anum = PerlLIO_umask(0);
683 (void)PerlLIO_umask(anum);
a0d0e21e
LW		 684 }
685 else
6ad3d225 686 anum = PerlLIO_umask(POPi);
a0d0e21e
LW		 687 TAINT_PROPER("umask");
688 XPUSHi(anum);
689#else
eec2d3df
GS		 690 /* Only DIE if trying to restrict permissions on `user' (self).
691 * Otherwise it's harmless and more useful to just return undef
692 * since 'group' and 'other' concepts probably don't exist here. */
693 if (MAXARG >= 1 && (POPi & 0700))
cea2e8a9 694 DIE(aTHX_ "umask not implemented");
6b88bc9c 695 XPUSHs(&PL_sv_undef);
a0d0e21e
LW		 696#endif
697 RETURN;
698}
699
700PP(pp_binmode)
701{
4e35701f 702 djSP;
a0d0e21e
LW		 703 GV *gv;
704 IO *io;
760ac839 705 PerlIO *fp;
4592e6ca 706 MAGIC *mg;
16fe6d59 707 SV *discp = Nullsv;
a0d0e21e
LW		 708
709 if (MAXARG < 1)
710 RETPUSHUNDEF;
16fe6d59
GS		 711 if (MAXARG > 1)
712 discp = POPs;
a0d0e21e 713
301e8125 714 gv = (GV*)POPs;
4592e6ca
NIS		 715
716 if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
717 PUSHMARK(SP);
718 XPUSHs(SvTIED_obj((SV*)gv, mg));
16fe6d59
GS		 719 if (discp)
720 XPUSHs(discp);
4592e6ca
NIS		 721 PUTBACK;
722 ENTER;
864dbfa3 723 call_method("BINMODE", G_SCALAR);
4592e6ca
NIS		 724 LEAVE;
725 SPAGAIN;
726 RETURN;
727 }
a0d0e21e
LW		 728
729 EXTEND(SP, 1);
730 if (!(io = GvIO(gv)) || !(fp = IoIFP(io)))
55497cff 731 RETPUSHUNDEF;
a0d0e21e 732
301e8125 733 if (do_binmode(fp,IoTYPE(io),mode_from_discipline(discp)))
a0d0e21e
LW		 734 RETPUSHYES;
735 else
736 RETPUSHUNDEF;
a0d0e21e
LW		 737}
738
739PP(pp_tie)
740{
4e35701f 741 djSP;
e336de0d 742 dMARK;
a0d0e21e
LW		 743 SV *varsv;
744 HV* stash;
745 GV *gv;
a0d0e21e 746 SV *sv;
3280af22 747 I32 markoff = MARK - PL_stack_base;
a0d0e21e 748 char *methname;
6b05c17a 749 int how = 'P';
e336de0d 750 U32 items;
2d8e6c8d 751 STRLEN n_a;
a0d0e21e 752
e336de0d 753 varsv = *++MARK;
6b05c17a
NIS		 754 switch(SvTYPE(varsv)) {
755 case SVt_PVHV:
756 methname = "TIEHASH";
757 break;
758 case SVt_PVAV:
759 methname = "TIEARRAY";
760 break;
761 case SVt_PVGV:
762 methname = "TIEHANDLE";
763 how = 'q';
764 break;
765 default:
766 methname = "TIESCALAR";
767 how = 'q';
768 break;
769 }
e336de0d
GS		 770 items = SP - MARK++;
771 if (sv_isobject(*MARK)) {
6b05c17a 772 ENTER;
e788e7d3 773 PUSHSTACKi(PERLSI_MAGIC);
e336de0d
GS		 774 PUSHMARK(SP);
775 EXTEND(SP,items);
776 while (items--)
777 PUSHs(*MARK++);
778 PUTBACK;
864dbfa3 779 call_method(methname, G_SCALAR);
301e8125 780 }
6b05c17a 781 else {
864dbfa3 782 /* Not clear why we don't call call_method here too.
6b05c17a
NIS		 783 * perhaps to get different error message ?
784 */
e336de0d 785 stash = gv_stashsv(*MARK, FALSE);
6b05c17a 786 if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
cea2e8a9 787 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%s\"",
301e8125 788 methname, SvPV(*MARK,n_a));
6b05c17a
NIS		 789 }
790 ENTER;
e788e7d3 791 PUSHSTACKi(PERLSI_MAGIC);
e336de0d
GS		 792 PUSHMARK(SP);
793 EXTEND(SP,items);
794 while (items--)
795 PUSHs(*MARK++);
796 PUTBACK;
864dbfa3 797 call_sv((SV*)GvCV(gv), G_SCALAR);
6b05c17a 798 }
a0d0e21e
LW		 799 SPAGAIN;
800
801 sv = TOPs;
d3acc0f7 802 POPSTACK;
a0d0e21e 803 if (sv_isobject(sv)) {
33c27489 804 sv_unmagic(varsv, how);
68a4a7e4
JH		 805 /* Croak if a self-tie is attempted */
806 if (varsv == SvRV(sv))
807 Perl_croak(aTHX_ "Self-ties are not supported");
808 sv_magic(varsv, sv, how, Nullch, 0);
a0d0e21e
LW		 809 }
810 LEAVE;
3280af22 811 SP = PL_stack_base + markoff;
a0d0e21e
LW		 812 PUSHs(sv);
813 RETURN;
814}
815
816PP(pp_untie)
817{
4e35701f 818 djSP;
33c27489
GS		 819 SV *sv = POPs;
820 char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) ? 'P' : 'q';
55497cff 821
cbdc8872 822 MAGIC * mg ;
155aba94 823 if ((mg = SvTIED_mg(sv, how))) {
a29a5827
NIS		 824 SV *obj = SvRV(mg->mg_obj);
825 GV *gv;
826 CV *cv = NULL;
a29a5827
NIS		 827 if ((gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE)) &&
828 isGV(gv) && (cv = GvCV(gv))) {
829 PUSHMARK(SP);
830 XPUSHs(SvTIED_obj((SV*)gv, mg));
301e8125 831 XPUSHs(sv_2mortal(newSViv(SvREFCNT(obj)-1)));
a29a5827
NIS		 832 PUTBACK;
833 ENTER;
834 call_sv((SV *)cv, G_VOID);
835 LEAVE;
836 SPAGAIN;
cbdc8872 837 }
301e8125
NIS		 838 else if (ckWARN(WARN_UNTIE)) {
839 if (mg && SvREFCNT(obj) > 1)
840 Perl_warner(aTHX_ WARN_UNTIE,
841 "untie attempted while %"UVuf" inner references still exist",
842 (UV)SvREFCNT(obj) - 1 ) ;
843 }
cbdc8872 844 }
33c27489 845 sv_unmagic(sv, how);
55497cff 846 RETPUSHYES;
a0d0e21e
LW		 847}
848
c07a80fd 849PP(pp_tied)
850{
4e35701f 851 djSP;
33c27489
GS		 852 SV *sv = POPs;
853 char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) ? 'P' : 'q';
854 MAGIC *mg;
c07a80fd 855
155aba94 856 if ((mg = SvTIED_mg(sv, how))) {
33c27489
GS		 857 SV *osv = SvTIED_obj(sv, mg);
858 if (osv == mg->mg_obj)
859 osv = sv_mortalcopy(osv);
860 PUSHs(osv);
861 RETURN;
c07a80fd 862 }
c07a80fd 863 RETPUSHUNDEF;
864}
865
a0d0e21e
LW		 866PP(pp_dbmopen)
867{
4e35701f 868 djSP;
a0d0e21e
LW		 869 HV *hv;
870 dPOPPOPssrl;
871 HV* stash;
872 GV *gv;
a0d0e21e
LW		 873 SV *sv;
874
875 hv = (HV*)POPs;
876
3280af22 877 sv = sv_mortalcopy(&PL_sv_no);
a0d0e21e
LW		 878 sv_setpv(sv, "AnyDBM_File");
879 stash = gv_stashsv(sv, FALSE);
8ebc5c01 880 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
a0d0e21e 881 PUTBACK;
864dbfa3 882 require_pv("AnyDBM_File.pm");
a0d0e21e 883 SPAGAIN;
8ebc5c01 884 if (!(gv = gv_fetchmethod(stash, "TIEHASH")))
cea2e8a9 885 DIE(aTHX_ "No dbm on this machine");
a0d0e21e
LW		 886 }
887
57d3b86d 888 ENTER;
924508f0 889 PUSHMARK(SP);
6b05c17a 890
924508f0 891 EXTEND(SP, 5);
a0d0e21e
LW		 892 PUSHs(sv);
893 PUSHs(left);
894 if (SvIV(right))
b448e4fe 895 PUSHs(sv_2mortal(newSVuv(O_RDWR|O_CREAT)));
a0d0e21e 896 else
b448e4fe 897 PUSHs(sv_2mortal(newSVuv(O_RDWR)));
a0d0e21e 898 PUSHs(right);
57d3b86d 899 PUTBACK;
864dbfa3 900 call_sv((SV*)GvCV(gv), G_SCALAR);
a0d0e21e
LW		 901 SPAGAIN;
902
903 if (!sv_isobject(TOPs)) {
924508f0
GS		 904 SP--;
905 PUSHMARK(SP);
a0d0e21e
LW		 906 PUSHs(sv);
907 PUSHs(left);
b448e4fe 908 PUSHs(sv_2mortal(newSVuv(O_RDONLY)));
a0d0e21e 909 PUSHs(right);
a0d0e21e 910 PUTBACK;
864dbfa3 911 call_sv((SV*)GvCV(gv), G_SCALAR);
a0d0e21e
LW		 912 SPAGAIN;
913 }
914
6b05c17a 915 if (sv_isobject(TOPs)) {
301e8125 916 sv_unmagic((SV *) hv, 'P');
a0d0e21e 917 sv_magic((SV*)hv, TOPs, 'P', Nullch, 0);
6b05c17a 918 }
a0d0e21e
LW		 919 LEAVE;
920 RETURN;
921}
922
923PP(pp_dbmclose)
924{
cea2e8a9 925 return pp_untie();
a0d0e21e
LW		 926}
927
928PP(pp_sselect)
929{
4e35701f 930 djSP; dTARGET;
a0d0e21e
LW		 931#ifdef HAS_SELECT
932 register I32 i;
933 register I32 j;
934 register char *s;
935 register SV *sv;
65202027 936 NV value;
a0d0e21e
LW		 937 I32 maxlen = 0;
938 I32 nfound;
939 struct timeval timebuf;
940 struct timeval *tbuf = &timebuf;
941 I32 growsize;
942 char *fd_sets[4];
2d8e6c8d 943 STRLEN n_a;
a0d0e21e
LW		 944#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
945 I32 masksize;
946 I32 offset;
947 I32 k;
948
949# if BYTEORDER & 0xf0000
950# define ORDERBYTE (0x88888888 - BYTEORDER)
951# else
952# define ORDERBYTE (0x4444 - BYTEORDER)
953# endif
954
955#endif
956
957 SP -= 4;
958 for (i = 1; i <= 3; i++) {
959 if (!SvPOK(SP[i]))
960 continue;
961 j = SvCUR(SP[i]);
962 if (maxlen < j)
963 maxlen = j;
964 }
965
5ff3f7a4 966/* little endians can use vecs directly */
a0d0e21e 967#if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
5ff3f7a4 968# if SELECT_MIN_BITS > 1
f2da832e
JH		 969 /* If SELECT_MIN_BITS is greater than one we most probably will want
970 * to align the sizes with SELECT_MIN_BITS/8 because for example
971 * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
f556e5b9 972 * UNIX, Solaris, NeXT, Darwin) the smallest quantum select() operates
8f1f23e8 973 * on (sets/tests/clears bits) is 32 bits. */
f2da832e 974 growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
5ff3f7a4 975# else
4633a7c4 976 growsize = sizeof(fd_set);
5ff3f7a4
GS		 977# endif
978# else
979# ifdef NFDBITS
a0d0e21e 980
5ff3f7a4
GS		 981# ifndef NBBY
982# define NBBY 8
983# endif
a0d0e21e
LW		 984
985 masksize = NFDBITS / NBBY;
5ff3f7a4 986# else
a0d0e21e 987 masksize = sizeof(long); /* documented int, everyone seems to use long */
5ff3f7a4 988# endif
a0d0e21e
LW		 989 growsize = maxlen + (masksize - (maxlen % masksize));
990 Zero(&fd_sets[0], 4, char*);
991#endif
992
993 sv = SP[4];
994 if (SvOK(sv)) {
995 value = SvNV(sv);
996 if (value < 0.0)
997 value = 0.0;
998 timebuf.tv_sec = (long)value;
65202027 999 value -= (NV)timebuf.tv_sec;
a0d0e21e
LW		 1000 timebuf.tv_usec = (long)(value * 1000000.0);
1001 }
1002 else
1003 tbuf = Null(struct timeval*);
1004
1005 for (i = 1; i <= 3; i++) {
1006 sv = SP[i];
1007 if (!SvOK(sv)) {
1008 fd_sets[i] = 0;
1009 continue;
1010 }
1011 else if (!SvPOK(sv))
2d8e6c8d 1012 SvPV_force(sv,n_a); /* force string conversion */
a0d0e21e
LW		 1013 j = SvLEN(sv);
1014 if (j < growsize) {
1015 Sv_Grow(sv, growsize);
a0d0e21e 1016 }
c07a80fd 1017 j = SvCUR(sv);
1018 s = SvPVX(sv) + j;
1019 while (++j <= growsize) {
1020 *s++ = '\0';
1021 }
1022
a0d0e21e
LW		 1023#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1024 s = SvPVX(sv);
1025 New(403, fd_sets[i], growsize, char);
1026 for (offset = 0; offset < growsize; offset += masksize) {
1027 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1028 fd_sets[i][j+offset] = s[(k % masksize) + offset];
1029 }
1030#else
1031 fd_sets[i] = SvPVX(sv);
1032#endif
1033 }
1034
6ad3d225 1035 nfound = PerlSock_select(
a0d0e21e
LW		 1036 maxlen * 8,
1037 (Select_fd_set_t) fd_sets[1],
1038 (Select_fd_set_t) fd_sets[2],
1039 (Select_fd_set_t) fd_sets[3],
1040 tbuf);
1041 for (i = 1; i <= 3; i++) {
1042 if (fd_sets[i]) {
1043 sv = SP[i];
1044#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1045 s = SvPVX(sv);
1046 for (offset = 0; offset < growsize; offset += masksize) {
1047 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1048 s[(k % masksize) + offset] = fd_sets[i][j+offset];
1049 }
1050 Safefree(fd_sets[i]);
1051#endif
1052 SvSETMAGIC(sv);
1053 }
1054 }
1055
1056 PUSHi(nfound);
1057 if (GIMME == G_ARRAY && tbuf) {
65202027
DS		 1058 value = (NV)(timebuf.tv_sec) +
1059 (NV)(timebuf.tv_usec) / 1000000.0;
3280af22 1060 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 1061 sv_setnv(sv, value);
1062 }
1063 RETURN;
1064#else
cea2e8a9 1065 DIE(aTHX_ "select not implemented");
a0d0e21e
LW		 1066#endif
1067}
1068
4633a7c4 1069void
864dbfa3 1070Perl_setdefout(pTHX_ GV *gv)
4633a7c4 1071{
11343788 1072 dTHR;
4633a7c4
LW		 1073 if (gv)
1074 (void)SvREFCNT_inc(gv);
3280af22
NIS		 1075 if (PL_defoutgv)
1076 SvREFCNT_dec(PL_defoutgv);
1077 PL_defoutgv = gv;
4633a7c4
LW		 1078}
1079
a0d0e21e
LW		 1080PP(pp_select)
1081{
4e35701f 1082 djSP; dTARGET;
4633a7c4
LW		 1083 GV *newdefout, *egv;
1084 HV *hv;
1085
533c011a 1086 newdefout = (PL_op->op_private > 0) ? ((GV *) POPs) : (GV *) NULL;
4633a7c4 1087
3280af22 1088 egv = GvEGV(PL_defoutgv);
4633a7c4 1089 if (!egv)
3280af22 1090 egv = PL_defoutgv;
4633a7c4
LW		 1091 hv = GvSTASH(egv);
1092 if (! hv)
3280af22 1093 XPUSHs(&PL_sv_undef);
4633a7c4 1094 else {
cbdc8872 1095 GV **gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
f86702cc 1096 if (gvp && *gvp == egv) {
f7aaccc2 1097 gv_efullname4(TARG, PL_defoutgv, Nullch, TRUE);
f86702cc 1098 XPUSHTARG;
1099 }
1100 else {
1101 XPUSHs(sv_2mortal(newRV((SV*)egv)));
1102 }
4633a7c4
LW		 1103 }
1104
1105 if (newdefout) {
ded8aa31
GS		 1106 if (!GvIO(newdefout))
1107 gv_IOadd(newdefout);
4633a7c4
LW		 1108 setdefout(newdefout);
1109 }
1110
a0d0e21e
LW		 1111 RETURN;
1112}
1113
1114PP(pp_getc)
1115{
4e35701f 1116 djSP; dTARGET;
a0d0e21e 1117 GV *gv;
2ae324a7 1118 MAGIC *mg;
a0d0e21e 1119
32da55ab 1120 if (MAXARG == 0)
3280af22 1121 gv = PL_stdingv;
a0d0e21e
LW		 1122 else
1123 gv = (GV*)POPs;
2ae324a7 1124
155aba94 1125 if ((mg = SvTIED_mg((SV*)gv, 'q'))) {
54310121 1126 I32 gimme = GIMME_V;
2ae324a7 1127 PUSHMARK(SP);
33c27489 1128 XPUSHs(SvTIED_obj((SV*)gv, mg));
2ae324a7 1129 PUTBACK;
1130 ENTER;
864dbfa3 1131 call_method("GETC", gimme);
2ae324a7 1132 LEAVE;
1133 SPAGAIN;
54310121 1134 if (gimme == G_SCALAR)
1135 SvSetMagicSV_nosteal(TARG, TOPs);
2ae324a7 1136 RETURN;
1137 }
9bc64814 1138 if (!gv || do_eof(gv)) /* make sure we have fp with something */
a0d0e21e 1139 RETPUSHUNDEF;
bbce6d69 1140 TAINT;
a0d0e21e 1141 sv_setpv(TARG, " ");
9bc64814 1142 *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
a0d0e21e
LW		 1143 PUSHTARG;
1144 RETURN;
1145}
1146
1147PP(pp_read)
1148{
cea2e8a9 1149 return pp_sysread();
a0d0e21e
LW		 1150}
1151
76e3520e 1152STATIC OP *
cea2e8a9 1153S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
a0d0e21e 1154{
11343788 1155 dTHR;
c09156bb 1156 register PERL_CONTEXT *cx;
54310121 1157 I32 gimme = GIMME_V;
a0d0e21e
LW		 1158 AV* padlist = CvPADLIST(cv);
1159 SV** svp = AvARRAY(padlist);
1160
1161 ENTER;
1162 SAVETMPS;
1163
1164 push_return(retop);
146174a9 1165 PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
a0d0e21e 1166 PUSHFORMAT(cx);
146174a9 1167 SAVEVPTR(PL_curpad);
3280af22 1168 PL_curpad = AvARRAY((AV*)svp[1]);
a0d0e21e 1169
4633a7c4 1170 setdefout(gv); /* locally select filehandle so $% et al work */
a0d0e21e
LW		 1171 return CvSTART(cv);
1172}
1173
1174PP(pp_enterwrite)
1175{
4e35701f 1176 djSP;
a0d0e21e
LW		 1177 register GV *gv;
1178 register IO *io;
1179 GV *fgv;
1180 CV *cv;
1181
1182 if (MAXARG == 0)
3280af22 1183 gv = PL_defoutgv;
a0d0e21e
LW		 1184 else {
1185 gv = (GV*)POPs;
1186 if (!gv)
3280af22 1187 gv = PL_defoutgv;
a0d0e21e
LW		 1188 }
1189 EXTEND(SP, 1);
1190 io = GvIO(gv);
1191 if (!io) {
1192 RETPUSHNO;
1193 }
1194 if (IoFMT_GV(io))
1195 fgv = IoFMT_GV(io);
1196 else
1197 fgv = gv;
1198
1199 cv = GvFORM(fgv);
a0d0e21e 1200 if (!cv) {
2dd78f96 1201 char *name = NULL;
a0d0e21e 1202 if (fgv) {
748a9306 1203 SV *tmpsv = sv_newmortal();
43693395 1204 gv_efullname4(tmpsv, fgv, Nullch, FALSE);
2dd78f96 1205 name = SvPV_nolen(tmpsv);
a0d0e21e 1206 }
2dd78f96
JH		 1207 if (name && *name)
1208 DIE(aTHX_ "Undefined format \"%s\" called", name);
cea2e8a9 1209 DIE(aTHX_ "Not a format reference");
a0d0e21e 1210 }
44a8e56a 1211 if (CvCLONE(cv))
1212 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
a0d0e21e 1213
44a8e56a 1214 IoFLAGS(io) &= ~IOf_DIDTOP;
533c011a 1215 return doform(cv,gv,PL_op->op_next);
a0d0e21e
LW		 1216}
1217
1218PP(pp_leavewrite)
1219{
4e35701f 1220 djSP;
a0d0e21e
LW		 1221 GV *gv = cxstack[cxstack_ix].blk_sub.gv;
1222 register IO *io = GvIOp(gv);
760ac839
LW		 1223 PerlIO *ofp = IoOFP(io);
1224 PerlIO *fp;
a0d0e21e
LW		 1225 SV **newsp;
1226 I32 gimme;
c09156bb 1227 register PERL_CONTEXT *cx;
a0d0e21e 1228
760ac839 1229 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
3280af22
NIS		 1230 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1231 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1232 PL_formtarget != PL_toptarget)
a0d0e21e 1233 {
4633a7c4
LW		 1234 GV *fgv;
1235 CV *cv;
a0d0e21e
LW		 1236 if (!IoTOP_GV(io)) {
1237 GV *topgv;
46fc3d4c 1238 SV *topname;
a0d0e21e
LW		 1239
1240 if (!IoTOP_NAME(io)) {
1241 if (!IoFMT_NAME(io))
1242 IoFMT_NAME(io) = savepv(GvNAME(gv));
cea2e8a9 1243 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%s_TOP", IoFMT_NAME(io)));
46fc3d4c 1244 topgv = gv_fetchpv(SvPVX(topname), FALSE, SVt_PVFM);
748a9306 1245 if ((topgv && GvFORM(topgv)) ||
a0d0e21e 1246 !gv_fetchpv("top",FALSE,SVt_PVFM))
46fc3d4c 1247 IoTOP_NAME(io) = savepv(SvPVX(topname));
a0d0e21e
LW		 1248 else
1249 IoTOP_NAME(io) = savepv("top");
1250 }
1251 topgv = gv_fetchpv(IoTOP_NAME(io),FALSE, SVt_PVFM);
1252 if (!topgv || !GvFORM(topgv)) {
1253 IoLINES_LEFT(io) = 100000000;
1254 goto forget_top;
1255 }
1256 IoTOP_GV(io) = topgv;
1257 }
748a9306
LW		 1258 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1259 I32 lines = IoLINES_LEFT(io);
3280af22 1260 char *s = SvPVX(PL_formtarget);
8e07c86e
AD		 1261 if (lines <= 0) /* Yow, header didn't even fit!!! */
1262 goto forget_top;
748a9306
LW		 1263 while (lines-- > 0) {
1264 s = strchr(s, '\n');
1265 if (!s)
1266 break;
1267 s++;
1268 }
1269 if (s) {
3280af22
NIS		 1270 PerlIO_write(ofp, SvPVX(PL_formtarget), s - SvPVX(PL_formtarget));
1271 sv_chop(PL_formtarget, s);
1272 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
748a9306
LW		 1273 }
1274 }
a0d0e21e 1275 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
3280af22 1276 PerlIO_write(ofp, SvPVX(PL_formfeed), SvCUR(PL_formfeed));
a0d0e21e
LW		 1277 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1278 IoPAGE(io)++;
3280af22 1279 PL_formtarget = PL_toptarget;
748a9306 1280 IoFLAGS(io) |= IOf_DIDTOP;
4633a7c4
LW		 1281 fgv = IoTOP_GV(io);
1282 if (!fgv)
cea2e8a9 1283 DIE(aTHX_ "bad top format reference");
4633a7c4 1284 cv = GvFORM(fgv);
2dd78f96
JH		 1285 {
1286 char *name = NULL;
1287 if (!cv) {
1288 SV *sv = sv_newmortal();
1289 gv_efullname4(sv, fgv, Nullch, FALSE);
1290 name = SvPV_nolen(sv);
1291 }
1292 if (name && *name)
1293 DIE(aTHX_ "Undefined top format \"%s\" called",name);
1294 /* why no:
1295 else
1296 DIE(aTHX_ "Undefined top format called");
1297 ?*/
4633a7c4 1298 }
44a8e56a 1299 if (CvCLONE(cv))
1300 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
533c011a 1301 return doform(cv,gv,PL_op);
a0d0e21e
LW		 1302 }
1303
1304 forget_top:
3280af22 1305 POPBLOCK(cx,PL_curpm);
a0d0e21e
LW		 1306 POPFORMAT(cx);
1307 LEAVE;
1308
1309 fp = IoOFP(io);
1310 if (!fp) {
599cee73 1311 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
cb50131a 1312 if (IoIFP(io)) {
2dd78f96
JH		 1313 /* integrate with report_evil_fh()? */
1314 char *name = NULL;
1315 if (isGV(gv)) {
1316 SV* sv = sv_newmortal();
1317 gv_efullname4(sv, gv, Nullch, FALSE);
1318 name = SvPV_nolen(sv);
1319 }
1320 if (name && *name)
1321 Perl_warner(aTHX_ WARN_IO,
1322 "Filehandle %s opened only for input", name);
1323 else
1324 Perl_warner(aTHX_ WARN_IO,
1325 "Filehandle opened only for input");
cb50131a 1326 }
599cee73 1327 else if (ckWARN(WARN_CLOSED))
bc37a18f 1328 report_evil_fh(gv, io, PL_op->op_type);
a0d0e21e 1329 }
3280af22 1330 PUSHs(&PL_sv_no);
a0d0e21e
LW		 1331 }
1332 else {
3280af22 1333 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
599cee73 1334 if (ckWARN(WARN_IO))
cea2e8a9 1335 Perl_warner(aTHX_ WARN_IO, "page overflow");
a0d0e21e 1336 }
3280af22 1337 if (!PerlIO_write(ofp, SvPVX(PL_formtarget), SvCUR(PL_formtarget)) ||
760ac839 1338 PerlIO_error(fp))
3280af22 1339 PUSHs(&PL_sv_no);
a0d0e21e 1340 else {
3280af22
NIS		 1341 FmLINES(PL_formtarget) = 0;
1342 SvCUR_set(PL_formtarget, 0);
1343 *SvEND(PL_formtarget) = '\0';
a0d0e21e 1344 if (IoFLAGS(io) & IOf_FLUSH)
760ac839 1345 (void)PerlIO_flush(fp);
3280af22 1346 PUSHs(&PL_sv_yes);
a0d0e21e
LW		 1347 }
1348 }
3280af22 1349 PL_formtarget = PL_bodytarget;
a0d0e21e
LW		 1350 PUTBACK;
1351 return pop_return();
1352}
1353
1354PP(pp_prtf)
1355{
4e35701f 1356 djSP; dMARK; dORIGMARK;
a0d0e21e
LW		 1357 GV *gv;
1358 IO *io;
760ac839 1359 PerlIO *fp;
26db47c4 1360 SV *sv;
46fc3d4c 1361 MAGIC *mg;
2d8e6c8d 1362 STRLEN n_a;
a0d0e21e 1363
533c011a 1364 if (PL_op->op_flags & OPf_STACKED)
a0d0e21e
LW		 1365 gv = (GV*)*++MARK;
1366 else
3280af22 1367 gv = PL_defoutgv;
46fc3d4c 1368
155aba94 1369 if ((mg = SvTIED_mg((SV*)gv, 'q'))) {
46fc3d4c 1370 if (MARK == ORIGMARK) {
4352c267 1371 MEXTEND(SP, 1);
46fc3d4c 1372 ++MARK;
1373 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1374 ++SP;
1375 }
1376 PUSHMARK(MARK - 1);
33c27489 1377 *MARK = SvTIED_obj((SV*)gv, mg);
46fc3d4c 1378 PUTBACK;
1379 ENTER;
864dbfa3 1380 call_method("PRINTF", G_SCALAR);
46fc3d4c 1381 LEAVE;
1382 SPAGAIN;
1383 MARK = ORIGMARK + 1;
1384 *MARK = *SP;
1385 SP = MARK;
1386 RETURN;
1387 }
1388
26db47c4 1389 sv = NEWSV(0,0);
a0d0e21e 1390 if (!(io = GvIO(gv))) {
2dd78f96
JH		 1391 dTHR;
1392 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1393 report_evil_fh(gv, io, PL_op->op_type);
748a9306 1394 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW		 1395 goto just_say_no;
1396 }
1397 else if (!(fp = IoOFP(io))) {
599cee73 1398 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
2dd78f96 1399 /* integrate with report_evil_fh()? */
cb50131a 1400 if (IoIFP(io)) {
2dd78f96
JH		 1401 char *name = NULL;
1402 if (isGV(gv)) {
1403 gv_efullname4(sv, gv, Nullch, FALSE);
1404 name = SvPV_nolen(sv);
1405 }
1406 if (name && *name)
1407 Perl_warner(aTHX_ WARN_IO,
1408 "Filehandle %s opened only for input", name);
1409 else
1410 Perl_warner(aTHX_ WARN_IO,
1411 "Filehandle opened only for input");
cb50131a 1412 }
599cee73 1413 else if (ckWARN(WARN_CLOSED))
bc37a18f 1414 report_evil_fh(gv, io, PL_op->op_type);
a0d0e21e 1415 }
748a9306 1416 SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
a0d0e21e
LW		 1417 goto just_say_no;
1418 }
1419 else {
1420 do_sprintf(sv, SP - MARK, MARK + 1);
1421 if (!do_print(sv, fp))
1422 goto just_say_no;
1423
1424 if (IoFLAGS(io) & IOf_FLUSH)
760ac839 1425 if (PerlIO_flush(fp) == EOF)
a0d0e21e
LW		 1426 goto just_say_no;
1427 }
1428 SvREFCNT_dec(sv);
1429 SP = ORIGMARK;
3280af22 1430 PUSHs(&PL_sv_yes);
a0d0e21e
LW		 1431 RETURN;
1432
1433 just_say_no:
1434 SvREFCNT_dec(sv);
1435 SP = ORIGMARK;
3280af22 1436 PUSHs(&PL_sv_undef);
a0d0e21e
LW		 1437 RETURN;
1438}
1439
c07a80fd 1440PP(pp_sysopen)
1441{
4e35701f 1442 djSP;
c07a80fd 1443 GV *gv;
c07a80fd 1444 SV *sv;
1445 char *tmps;
1446 STRLEN len;
1447 int mode, perm;
1448
1449 if (MAXARG > 3)
1450 perm = POPi;
1451 else
1452 perm = 0666;
1453 mode = POPi;
1454 sv = POPs;
1455 gv = (GV *)POPs;
1456
4592e6ca
NIS		 1457 /* Need TIEHANDLE method ? */
1458
c07a80fd 1459 tmps = SvPV(sv, len);
1460 if (do_open(gv, tmps, len, TRUE, mode, perm, Nullfp)) {
1461 IoLINES(GvIOp(gv)) = 0;
3280af22 1462 PUSHs(&PL_sv_yes);
c07a80fd 1463 }
1464 else {
3280af22 1465 PUSHs(&PL_sv_undef);
c07a80fd 1466 }
1467 RETURN;
1468}
1469
a0d0e21e
LW		 1470PP(pp_sysread)
1471{
4e35701f 1472 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW		 1473 int offset;
1474 GV *gv;
1475 IO *io;
1476 char *buffer;
5b54f415 1477 SSize_t length;
1e422769 1478 Sock_size_t bufsize;
748a9306 1479 SV *bufsv;
a0d0e21e 1480 STRLEN blen;
2ae324a7 1481 MAGIC *mg;
a0d0e21e
LW		 1482
1483 gv = (GV*)*++MARK;
533c011a 1484 if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD) &&
33c27489 1485 (mg = SvTIED_mg((SV*)gv, 'q')))
137443ea 1486 {
2ae324a7 1487 SV *sv;
1488
1489 PUSHMARK(MARK-1);
33c27489 1490 *MARK = SvTIED_obj((SV*)gv, mg);
2ae324a7 1491 ENTER;
864dbfa3 1492 call_method("READ", G_SCALAR);
2ae324a7 1493 LEAVE;
1494 SPAGAIN;
1495 sv = POPs;
1496 SP = ORIGMARK;
1497 PUSHs(sv);
1498 RETURN;
1499 }
1500
a0d0e21e
LW		 1501 if (!gv)
1502 goto say_undef;
748a9306 1503 bufsv = *++MARK;
ff68c719 1504 if (! SvOK(bufsv))
1505 sv_setpvn(bufsv, "", 0);
748a9306 1506 buffer = SvPV_force(bufsv, blen);
a0d0e21e
LW		 1507 length = SvIVx(*++MARK);
1508 if (length < 0)
cea2e8a9 1509 DIE(aTHX_ "Negative length");
748a9306 1510 SETERRNO(0,0);
a0d0e21e
LW		 1511 if (MARK < SP)
1512 offset = SvIVx(*++MARK);
1513 else
1514 offset = 0;
1515 io = GvIO(gv);
1516 if (!io || !IoIFP(io))
1517 goto say_undef;
1518#ifdef HAS_SOCKET
533c011a 1519 if (PL_op->op_type == OP_RECV) {
46fc3d4c 1520 char namebuf[MAXPATHLEN];
eec2d3df 1521#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE)
490ab354
JH		 1522 bufsize = sizeof (struct sockaddr_in);
1523#else
46fc3d4c 1524 bufsize = sizeof namebuf;
490ab354 1525#endif
abf95952
IZ		 1526#ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1527 if (bufsize >= 256)
1528 bufsize = 255;
1529#endif
626727d5
GS		 1530#ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1531 if (bufsize >= 256)
1532 bufsize = 255;
1533#endif
748a9306 1534 buffer = SvGROW(bufsv, length+1);
bbce6d69 1535 /* 'offset' means 'flags' here */
6ad3d225 1536 length = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
46fc3d4c 1537 (struct sockaddr *)namebuf, &bufsize);
a0d0e21e
LW		 1538 if (length < 0)
1539 RETPUSHUNDEF;
748a9306
LW		 1540 SvCUR_set(bufsv, length);
1541 *SvEND(bufsv) = '\0';
1542 (void)SvPOK_only(bufsv);
1543 SvSETMAGIC(bufsv);
aac0dd9a 1544 /* This should not be marked tainted if the fp is marked clean */
bbce6d69 1545 if (!(IoFLAGS(io) & IOf_UNTAINT))
1546 SvTAINTED_on(bufsv);
a0d0e21e 1547 SP = ORIGMARK;
46fc3d4c 1548 sv_setpvn(TARG, namebuf, bufsize);
a0d0e21e
LW		 1549 PUSHs(TARG);
1550 RETURN;
1551 }
1552#else
911d147d 1553 if (PL_op->op_type == OP_RECV)
cea2e8a9 1554 DIE(aTHX_ PL_no_sock_func, "recv");
a0d0e21e 1555#endif
bbce6d69 1556 if (offset < 0) {
1557 if (-offset > blen)
cea2e8a9 1558 DIE(aTHX_ "Offset outside string");
bbce6d69 1559 offset += blen;
1560 }
cd52b7b2 1561 bufsize = SvCUR(bufsv);
748a9306 1562 buffer = SvGROW(bufsv, length+offset+1);
cd52b7b2 1563 if (offset > bufsize) { /* Zero any newly allocated space */
1564 Zero(buffer+bufsize, offset-bufsize, char);
1565 }
533c011a 1566 if (PL_op->op_type == OP_SYSREAD) {
a7092146 1567#ifdef PERL_SOCK_SYSREAD_IS_RECV
50952442 1568 if (IoTYPE(io) == IoTYPE_SOCKET) {
a7092146
GS		 1569 length = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
1570 buffer+offset, length, 0);
1571 }
1572 else
1573#endif
1574 {
1575 length = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
1576 buffer+offset, length);
1577 }
a0d0e21e
LW		 1578 }
1579 else
1580#ifdef HAS_SOCKET__bad_code_maybe
50952442 1581 if (IoTYPE(io) == IoTYPE_SOCKET) {
46fc3d4c 1582 char namebuf[MAXPATHLEN];
490ab354
JH		 1583#if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
1584 bufsize = sizeof (struct sockaddr_in);
1585#else
46fc3d4c 1586 bufsize = sizeof namebuf;
490ab354 1587#endif
6ad3d225 1588 length = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer+offset, length, 0,
46fc3d4c 1589 (struct sockaddr *)namebuf, &bufsize);
a0d0e21e
LW		 1590 }
1591 else
1592#endif
3b02c43c 1593 {
760ac839 1594 length = PerlIO_read(IoIFP(io), buffer+offset, length);
3b02c43c 1595 /* fread() returns 0 on both error and EOF */
5c7a8c78 1596 if (length == 0 && PerlIO_error(IoIFP(io)))
3b02c43c
GS		 1597 length = -1;
1598 }
af8c498a 1599 if (length < 0) {
50952442 1600 if ((IoTYPE(io) == IoTYPE_WRONLY || IoIFP(io) == PerlIO_stdout()
c529f79d 1601 || IoIFP(io) == PerlIO_stderr()) && ckWARN(WARN_IO))
af8c498a 1602 {
2dd78f96
JH		 1603 /* integrate with report_evil_fh()? */
1604 char *name = NULL;
1605 if (isGV(gv)) {
1606 SV* sv = sv_newmortal();
1607 gv_efullname4(sv, gv, Nullch, FALSE);
1608 name = SvPV_nolen(sv);
1609 }
1610 if (name && *name)
1611 Perl_warner(aTHX_ WARN_IO,
1612 "Filehandle %s opened only for output", name);
1613 else
1614 Perl_warner(aTHX_ WARN_IO,
1615 "Filehandle opened only for output");
af8c498a 1616 }
a0d0e21e 1617 goto say_undef;
af8c498a 1618 }
748a9306
LW		 1619 SvCUR_set(bufsv, length+offset);
1620 *SvEND(bufsv) = '\0';
1621 (void)SvPOK_only(bufsv);
1622 SvSETMAGIC(bufsv);
aac0dd9a 1623 /* This should not be marked tainted if the fp is marked clean */
bbce6d69 1624 if (!(IoFLAGS(io) & IOf_UNTAINT))
1625 SvTAINTED_on(bufsv);
a0d0e21e
LW		 1626 SP = ORIGMARK;
1627 PUSHi(length);
1628 RETURN;
1629
1630 say_undef:
1631 SP = ORIGMARK;
1632 RETPUSHUNDEF;
1633}
1634
1635PP(pp_syswrite)
1636{
092bebab
JH		 1637 djSP;
1638 int items = (SP - PL_stack_base) - TOPMARK;
1639 if (items == 2) {
9f089d78 1640 SV *sv;
092bebab 1641 EXTEND(SP, 1);
9f089d78
SB		 1642 sv = sv_2mortal(newSViv(sv_len(*SP)));
1643 PUSHs(sv);
092bebab
JH		 1644 PUTBACK;
1645 }
cea2e8a9 1646 return pp_send();
a0d0e21e
LW		 1647}
1648
1649PP(pp_send)
1650{
4e35701f 1651 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW		 1652 GV *gv;
1653 IO *io;
748a9306 1654 SV *bufsv;
a0d0e21e 1655 char *buffer;
8c99d73e
GS		 1656 Size_t length;
1657 SSize_t retval;
1658 IV offset;
a0d0e21e 1659 STRLEN blen;
1d603a67 1660 MAGIC *mg;
a0d0e21e
LW		 1661
1662 gv = (GV*)*++MARK;
33c27489 1663 if (PL_op->op_type == OP_SYSWRITE && (mg = SvTIED_mg((SV*)gv, 'q'))) {
1d603a67
GB		 1664 SV *sv;
1665
1666 PUSHMARK(MARK-1);
33c27489 1667 *MARK = SvTIED_obj((SV*)gv, mg);
1d603a67 1668 ENTER;
864dbfa3 1669 call_method("WRITE", G_SCALAR);
1d603a67
GB		 1670 LEAVE;
1671 SPAGAIN;
1672 sv = POPs;
1673 SP = ORIGMARK;
1674 PUSHs(sv);
1675 RETURN;
1676 }
a0d0e21e
LW		 1677 if (!gv)
1678 goto say_undef;
748a9306
LW		 1679 bufsv = *++MARK;
1680 buffer = SvPV(bufsv, blen);
8c99d73e 1681#if Size_t_size > IVSIZE
3c001241 1682 length = (Size_t)SvNVx(*++MARK);
146174a9 1683#else
3c001241 1684 length = (Size_t)SvIVx(*++MARK);
146174a9 1685#endif
3c001241 1686 if ((SSize_t)length < 0)
cea2e8a9 1687 DIE(aTHX_ "Negative length");
748a9306 1688 SETERRNO(0,0);
a0d0e21e
LW		 1689 io = GvIO(gv);
1690 if (!io || !IoIFP(io)) {
8c99d73e 1691 retval = -1;
bc37a18f
RG		 1692 if (ckWARN(WARN_CLOSED))
1693 report_evil_fh(gv, io, PL_op->op_type);
a0d0e21e 1694 }
533c011a 1695 else if (PL_op->op_type == OP_SYSWRITE) {
bbce6d69 1696 if (MARK < SP) {
a0d0e21e 1697 offset = SvIVx(*++MARK);
bbce6d69 1698 if (offset < 0) {
1699 if (-offset > blen)
cea2e8a9 1700 DIE(aTHX_ "Offset outside string");
bbce6d69 1701 offset += blen;
fb73857a 1702 } else if (offset >= blen && blen > 0)
cea2e8a9 1703 DIE(aTHX_ "Offset outside string");
bbce6d69 1704 } else
a0d0e21e
LW		 1705 offset = 0;
1706 if (length > blen - offset)
1707 length = blen - offset;
a7092146 1708#ifdef PERL_SOCK_SYSWRITE_IS_SEND
50952442 1709 if (IoTYPE(io) == IoTYPE_SOCKET) {
8c99d73e 1710 retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
a7092146
GS		 1711 buffer+offset, length, 0);
1712 }
1713 else
1714#endif
1715 {
94e4c244 1716 /* See the note at doio.c:do_print about filesize limits. --jhi */
8c99d73e 1717 retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
a7092146
GS		 1718 buffer+offset, length);
1719 }
a0d0e21e
LW		 1720 }
1721#ifdef HAS_SOCKET
1722 else if (SP > MARK) {
1723 char *sockbuf;
1724 STRLEN mlen;
1725 sockbuf = SvPVx(*++MARK, mlen);
8c99d73e
GS		 1726 retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
1727 length, (struct sockaddr *)sockbuf, mlen);
a0d0e21e
LW		 1728 }
1729 else
8c99d73e 1730 retval = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, length);
490ab354 1731
a0d0e21e
LW		 1732#else
1733 else
cea2e8a9 1734 DIE(aTHX_ PL_no_sock_func, "send");
a0d0e21e 1735#endif
8c99d73e 1736 if (retval < 0)
a0d0e21e
LW		 1737 goto say_undef;
1738 SP = ORIGMARK;
8c99d73e
GS		 1739#if Size_t_size > IVSIZE
1740 PUSHn(retval);
1741#else
1742 PUSHi(retval);
1743#endif
a0d0e21e
LW		 1744 RETURN;
1745
1746 say_undef:
1747 SP = ORIGMARK;
1748 RETPUSHUNDEF;
1749}
1750
1751PP(pp_recv)
1752{
cea2e8a9 1753 return pp_sysread();
a0d0e21e
LW		 1754}
1755
1756PP(pp_eof)
1757{
4e35701f 1758 djSP;
a0d0e21e 1759 GV *gv;
4592e6ca 1760 MAGIC *mg;
a0d0e21e 1761
32da55ab 1762 if (MAXARG == 0) {
146174a9
CB		 1763 if (PL_op->op_flags & OPf_SPECIAL) { /* eof() */
1764 IO *io;
1765 gv = PL_last_in_gv = PL_argvgv;
1766 io = GvIO(gv);
1767 if (io && !IoIFP(io)) {
1768 if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) {
1769 IoLINES(io) = 0;
1770 IoFLAGS(io) &= ~IOf_START;
1771 do_open(gv, "-", 1, FALSE, O_RDONLY, 0, Nullfp);
1772 sv_setpvn(GvSV(gv), "-", 1);
1773 SvSETMAGIC(GvSV(gv));
1774 }
1775 else if (!nextargv(gv))
1776 RETPUSHYES;
1777 }
1778 }
1779 else
1780 gv = PL_last_in_gv; /* eof */
1781 }
a0d0e21e 1782 else
146174a9 1783 gv = PL_last_in_gv = (GV*)POPs; /* eof(FH) */
4592e6ca
NIS		 1784
1785 if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
1786 PUSHMARK(SP);
1787 XPUSHs(SvTIED_obj((SV*)gv, mg));
1788 PUTBACK;
1789 ENTER;
864dbfa3 1790 call_method("EOF", G_SCALAR);
4592e6ca
NIS		 1791 LEAVE;
1792 SPAGAIN;
1793 RETURN;
1794 }
1795
54310121 1796 PUSHs(boolSV(!gv || do_eof(gv)));
a0d0e21e
LW		 1797 RETURN;
1798}
1799
1800PP(pp_tell)
1801{
4e35701f 1802 djSP; dTARGET;
301e8125 1803 GV *gv;
4592e6ca 1804 MAGIC *mg;
a0d0e21e 1805
32da55ab 1806 if (MAXARG == 0)
3280af22 1807 gv = PL_last_in_gv;
a0d0e21e 1808 else
3280af22 1809 gv = PL_last_in_gv = (GV*)POPs;
4592e6ca
NIS		 1810
1811 if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
1812 PUSHMARK(SP);
1813 XPUSHs(SvTIED_obj((SV*)gv, mg));
1814 PUTBACK;
1815 ENTER;
864dbfa3 1816 call_method("TELL", G_SCALAR);
4592e6ca
NIS		 1817 LEAVE;
1818 SPAGAIN;
1819 RETURN;
1820 }
1821
146174a9
CB		 1822#if LSEEKSIZE > IVSIZE
1823 PUSHn( do_tell(gv) );
1824#else
a0d0e21e 1825 PUSHi( do_tell(gv) );
146174a9 1826#endif
a0d0e21e
LW		 1827 RETURN;
1828}
1829
1830PP(pp_seek)
1831{
cea2e8a9 1832 return pp_sysseek();
137443ea 1833}
1834
1835PP(pp_sysseek)
1836{
4e35701f 1837 djSP;
a0d0e21e
LW		 1838 GV *gv;
1839 int whence = POPi;
146174a9
CB		 1840#if LSEEKSIZE > IVSIZE
1841 Off_t offset = (Off_t)SvNVx(POPs);
1842#else
d9b3e12d 1843 Off_t offset = (Off_t)SvIVx(POPs);
146174a9 1844#endif
4592e6ca 1845 MAGIC *mg;
a0d0e21e 1846
3280af22 1847 gv = PL_last_in_gv = (GV*)POPs;
4592e6ca
NIS		 1848
1849 if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
1850 PUSHMARK(SP);
1851 XPUSHs(SvTIED_obj((SV*)gv, mg));
cb50131a
CB		 1852#if LSEEKSIZE > IVSIZE
1853 XPUSHs(sv_2mortal(newSVnv((NV) offset)));
1854#else
b448e4fe 1855 XPUSHs(sv_2mortal(newSViv(offset)));
cb50131a 1856#endif
b448e4fe 1857 XPUSHs(sv_2mortal(newSViv(whence)));
4592e6ca
NIS		 1858 PUTBACK;
1859 ENTER;
864dbfa3 1860 call_method("SEEK", G_SCALAR);
4592e6ca
NIS		 1861 LEAVE;
1862 SPAGAIN;
1863 RETURN;
1864 }
1865
533c011a 1866 if (PL_op->op_type == OP_SEEK)
8903cb82 1867 PUSHs(boolSV(do_seek(gv, offset, whence)));
1868 else {
b448e4fe
JH		 1869 Off_t sought = do_sysseek(gv, offset, whence);
1870 if (sought < 0)
146174a9
CB		 1871 PUSHs(&PL_sv_undef);
1872 else {
b448e4fe 1873 SV* sv = sought ?
146174a9 1874#if LSEEKSIZE > IVSIZE
b448e4fe 1875 newSVnv((NV)sought)
146174a9 1876#else
b448e4fe 1877 newSViv(sought)
146174a9
CB		 1878#endif
1879 : newSVpvn(zero_but_true, ZBTLEN);
1880 PUSHs(sv_2mortal(sv));
1881 }
8903cb82 1882 }
a0d0e21e
LW		 1883 RETURN;
1884}
1885
1886PP(pp_truncate)
1887{
4e35701f 1888 djSP;
8c99d73e
GS		 1889 /* There seems to be no consensus on the length type of truncate()
1890 * and ftruncate(), both off_t and size_t have supporters. In
1891 * general one would think that when using large files, off_t is
1892 * at least as wide as size_t, so using an off_t should be okay. */
1893 /* XXX Configure probe for the length type of *truncate() needed XXX */
1894 Off_t len;
a0d0e21e
LW		 1895 int result = 1;
1896 GV *tmpgv;
2d8e6c8d 1897 STRLEN n_a;
a0d0e21e 1898
8c99d73e
GS		 1899#if Size_t_size > IVSIZE
1900 len = (Off_t)POPn;
1901#else
1902 len = (Off_t)POPi;
1903#endif
1904 /* Checking for length < 0 is problematic as the type might or
301e8125 1905 * might not be signed: if it is not, clever compilers will moan. */
8c99d73e 1906 /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
748a9306 1907 SETERRNO(0,0);
5d94fbed 1908#if defined(HAS_TRUNCATE) || defined(HAS_CHSIZE) || defined(F_FREESP)
533c011a 1909 if (PL_op->op_flags & OPf_SPECIAL) {
2d8e6c8d 1910 tmpgv = gv_fetchpv(POPpx, FALSE, SVt_PVIO);
cbdc8872 1911 do_ftruncate:
1e422769 1912 TAINT_PROPER("truncate");
cb50131a
CB		 1913 if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv)))
1914 result = 0;
1915 else {
1916 PerlIO_flush(IoIFP(GvIOp(tmpgv)));
cbdc8872 1917#ifdef HAS_TRUNCATE
cb50131a 1918 if (ftruncate(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
301e8125 1919#else
cb50131a 1920 if (my_chsize(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
cbdc8872 1921#endif
cb50131a
CB		 1922 result = 0;
1923 }
a0d0e21e
LW		 1924 }
1925 else {
cbdc8872 1926 SV *sv = POPs;
1e422769 1927 char *name;
2d8e6c8d 1928 STRLEN n_a;
1e422769 1929
cbdc8872 1930 if (SvTYPE(sv) == SVt_PVGV) {
1931 tmpgv = (GV*)sv; /* *main::FRED for example */
1932 goto do_ftruncate;
1933 }
1934 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
1935 tmpgv = (GV*) SvRV(sv); /* \*main::FRED for example */
1936 goto do_ftruncate;
1937 }
1e422769 1938
2d8e6c8d 1939 name = SvPV(sv, n_a);
1e422769 1940 TAINT_PROPER("truncate");
cbdc8872 1941#ifdef HAS_TRUNCATE
1e422769 1942 if (truncate(name, len) < 0)
a0d0e21e 1943 result = 0;
cbdc8872 1944#else
1945 {
1946 int tmpfd;
6ad3d225 1947 if ((tmpfd = PerlLIO_open(name, O_RDWR)) < 0)
bbce6d69 1948 result = 0;
cbdc8872 1949 else {
1950 if (my_chsize(tmpfd, len) < 0)
1951 result = 0;
6ad3d225 1952 PerlLIO_close(tmpfd);
cbdc8872 1953 }
a0d0e21e 1954 }
a0d0e21e 1955#endif
cbdc8872 1956 }
a0d0e21e
LW		 1957
1958 if (result)
1959 RETPUSHYES;
1960 if (!errno)
748a9306 1961 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW		 1962 RETPUSHUNDEF;
1963#else
cea2e8a9 1964 DIE(aTHX_ "truncate not implemented");
a0d0e21e
LW		 1965#endif
1966}
1967
1968PP(pp_fcntl)
1969{
cea2e8a9 1970 return pp_ioctl();
a0d0e21e
LW		 1971}
1972
1973PP(pp_ioctl)
1974{
4e35701f 1975 djSP; dTARGET;
748a9306 1976 SV *argsv = POPs;
a0d0e21e 1977 unsigned int func = U_I(POPn);
533c011a 1978 int optype = PL_op->op_type;
a0d0e21e 1979 char *s;
324aa91a 1980 IV retval;
a0d0e21e
LW		 1981 GV *gv = (GV*)POPs;
1982 IO *io = GvIOn(gv);
1983
748a9306
LW		 1984 if (!io || !argsv || !IoIFP(io)) {
1985 SETERRNO(EBADF,RMS$_IFI); /* well, sort of... */
a0d0e21e
LW		 1986 RETPUSHUNDEF;
1987 }
1988
748a9306 1989 if (SvPOK(argsv) || !SvNIOK(argsv)) {
a0d0e21e 1990 STRLEN len;
324aa91a 1991 STRLEN need;
748a9306 1992 s = SvPV_force(argsv, len);
324aa91a
HF		 1993 need = IOCPARM_LEN(func);
1994 if (len < need) {
1995 s = Sv_Grow(argsv, need + 1);
1996 SvCUR_set(argsv, need);
a0d0e21e
LW		 1997 }
1998
748a9306 1999 s[SvCUR(argsv)] = 17; /* a little sanity check here */
a0d0e21e
LW		 2000 }
2001 else {
748a9306 2002 retval = SvIV(argsv);
c529f79d 2003 s = INT2PTR(char*,retval); /* ouch */
a0d0e21e
LW		 2004 }
2005
2006 TAINT_PROPER(optype == OP_IOCTL ? "ioctl" : "fcntl");
2007
2008 if (optype == OP_IOCTL)
2009#ifdef HAS_IOCTL
76e3520e 2010 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
a0d0e21e 2011#else
cea2e8a9 2012 DIE(aTHX_ "ioctl is not implemented");
a0d0e21e
LW		 2013#endif
2014 else
55497cff 2015#ifdef HAS_FCNTL
2016#if defined(OS2) && defined(__EMX__)
760ac839 2017 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
55497cff 2018#else
760ac839 2019 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
301e8125 2020#endif
55497cff 2021#else
cea2e8a9 2022 DIE(aTHX_ "fcntl is not implemented");
a0d0e21e
LW		 2023#endif
2024
748a9306
LW		 2025 if (SvPOK(argsv)) {
2026 if (s[SvCUR(argsv)] != 17)
cea2e8a9 2027 DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
22c35a8c 2028 PL_op_name[optype]);
748a9306
LW		 2029 s[SvCUR(argsv)] = 0; /* put our null back */
2030 SvSETMAGIC(argsv); /* Assume it has changed */
a0d0e21e
LW		 2031 }
2032
2033 if (retval == -1)
2034 RETPUSHUNDEF;
2035 if (retval != 0) {
2036 PUSHi(retval);
2037 }
2038 else {
8903cb82 2039 PUSHp(zero_but_true, ZBTLEN);
a0d0e21e
LW		 2040 }
2041 RETURN;
2042}
2043
2044PP(pp_flock)
2045{
4e35701f 2046 djSP; dTARGET;
a0d0e21e
LW		 2047 I32 value;
2048 int argtype;
2049 GV *gv;
bc37a18f 2050 IO *io = NULL;
760ac839 2051 PerlIO *fp;
16d20bd9 2052
ff68c719 2053#ifdef FLOCK
a0d0e21e 2054 argtype = POPi;
32da55ab 2055 if (MAXARG == 0)
3280af22 2056 gv = PL_last_in_gv;
a0d0e21e
LW		 2057 else
2058 gv = (GV*)POPs;
bc37a18f
RG		 2059 if (gv && (io = GvIO(gv)))
2060 fp = IoIFP(io);
2061 else {
a0d0e21e 2062 fp = Nullfp;
bc37a18f
RG		 2063 io = NULL;
2064 }
a0d0e21e 2065 if (fp) {
68dc0745 2066 (void)PerlIO_flush(fp);
76e3520e 2067 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
a0d0e21e 2068 }
cb50131a 2069 else {
bc37a18f
RG		 2070 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2071 report_evil_fh(gv, io, PL_op->op_type);
a0d0e21e 2072 value = 0;
cb50131a 2073 SETERRNO(EBADF,RMS$_IFI);
cb50131a 2074 }
a0d0e21e
LW		 2075 PUSHi(value);
2076 RETURN;
2077#else
cea2e8a9 2078 DIE(aTHX_ PL_no_func, "flock()");
a0d0e21e
LW		 2079#endif
2080}
2081
2082/* Sockets. */
2083
2084PP(pp_socket)
2085{
4e35701f 2086 djSP;
a0d0e21e
LW		 2087#ifdef HAS_SOCKET
2088 GV *gv;
2089 register IO *io;
2090 int protocol = POPi;
2091 int type = POPi;
2092 int domain = POPi;
2093 int fd;
2094
2095 gv = (GV*)POPs;
2096
2097 if (!gv) {
748a9306 2098 SETERRNO(EBADF,LIB$_INVARG);
a0d0e21e
LW		 2099 RETPUSHUNDEF;
2100 }
2101
2102 io = GvIOn(gv);
2103 if (IoIFP(io))
2104 do_close(gv, FALSE);
2105
2106 TAINT_PROPER("socket");
6ad3d225 2107 fd = PerlSock_socket(domain, type, protocol);
a0d0e21e
LW		 2108 if (fd < 0)
2109 RETPUSHUNDEF;
760ac839
LW		 2110 IoIFP(io) = PerlIO_fdopen(fd, "r"); /* stdio gets confused about sockets */
2111 IoOFP(io) = PerlIO_fdopen(fd, "w");
50952442 2112 IoTYPE(io) = IoTYPE_SOCKET;
a0d0e21e 2113 if (!IoIFP(io) || !IoOFP(io)) {
760ac839
LW		 2114 if (IoIFP(io)) PerlIO_close(IoIFP(io));
2115 if (IoOFP(io)) PerlIO_close(IoOFP(io));
6ad3d225 2116 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
a0d0e21e
LW		 2117 RETPUSHUNDEF;
2118 }
8d2a6795
GS		 2119#if defined(HAS_FCNTL) && defined(F_SETFD)
2120 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2121#endif
a0d0e21e
LW		 2122
2123 RETPUSHYES;
2124#else
cea2e8a9 2125 DIE(aTHX_ PL_no_sock_func, "socket");
a0d0e21e
LW		 2126#endif
2127}
2128
2129PP(pp_sockpair)
2130{
4e35701f 2131 djSP;
a0d0e21e
LW		 2132#ifdef HAS_SOCKETPAIR
2133 GV *gv1;
2134 GV *gv2;
2135 register IO *io1;
2136 register IO *io2;
2137 int protocol = POPi;
2138 int type = POPi;
2139 int domain = POPi;
2140 int fd[2];
2141
2142 gv2 = (GV*)POPs;
2143 gv1 = (GV*)POPs;
2144 if (!gv1 || !gv2)
2145 RETPUSHUNDEF;
2146
2147 io1 = GvIOn(gv1);
2148 io2 = GvIOn(gv2);
2149 if (IoIFP(io1))
2150 do_close(gv1, FALSE);
2151 if (IoIFP(io2))
2152 do_close(gv2, FALSE);
2153
2154 TAINT_PROPER("socketpair");
6ad3d225 2155 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
a0d0e21e 2156 RETPUSHUNDEF;
760ac839
LW		 2157 IoIFP(io1) = PerlIO_fdopen(fd[0], "r");
2158 IoOFP(io1) = PerlIO_fdopen(fd[0], "w");
50952442 2159 IoTYPE(io1) = IoTYPE_SOCKET;
760ac839
LW		 2160 IoIFP(io2) = PerlIO_fdopen(fd[1], "r");
2161 IoOFP(io2) = PerlIO_fdopen(fd[1], "w");
50952442 2162 IoTYPE(io2) = IoTYPE_SOCKET;
a0d0e21e 2163 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
760ac839
LW		 2164 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2165 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
6ad3d225 2166 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
760ac839
LW		 2167 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2168 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
6ad3d225 2169 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
a0d0e21e
LW		 2170 RETPUSHUNDEF;
2171 }
8d2a6795
GS		 2172#if defined(HAS_FCNTL) && defined(F_SETFD)
2173 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
2174 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
2175#endif
a0d0e21e
LW		 2176
2177 RETPUSHYES;
2178#else
cea2e8a9 2179 DIE(aTHX_ PL_no_sock_func, "socketpair");
a0d0e21e
LW		 2180#endif
2181}
2182
2183PP(pp_bind)
2184{
4e35701f 2185 djSP;
a0d0e21e 2186#ifdef HAS_SOCKET
eec2d3df
GS		 2187#ifdef MPE /* Requires PRIV mode to bind() to ports < 1024 */
2188 extern GETPRIVMODE();
2189 extern GETUSERMODE();
2190#endif
748a9306 2191 SV *addrsv = POPs;
a0d0e21e
LW		 2192 char *addr;
2193 GV *gv = (GV*)POPs;
2194 register IO *io = GvIOn(gv);
2195 STRLEN len;
eec2d3df
GS		 2196 int bind_ok = 0;
2197#ifdef MPE
2198 int mpeprivmode = 0;
2199#endif
a0d0e21e
LW		 2200
2201 if (!io || !IoIFP(io))
2202 goto nuts;
2203
748a9306 2204 addr = SvPV(addrsv, len);
a0d0e21e 2205 TAINT_PROPER("bind");
eec2d3df
GS		 2206#ifdef MPE /* Deal with MPE bind() peculiarities */
2207 if (((struct sockaddr *)addr)->sa_family == AF_INET) {
2208 /* The address *MUST* stupidly be zero. */
2209 ((struct sockaddr_in *)addr)->sin_addr.s_addr = INADDR_ANY;
2210 /* PRIV mode is required to bind() to ports < 1024. */
2211 if (((struct sockaddr_in *)addr)->sin_port < 1024 &&
2212 ((struct sockaddr_in *)addr)->sin_port > 0) {
2213 GETPRIVMODE(); /* If this fails, we are aborted by MPE/iX. */
2214 mpeprivmode = 1;
2215 }
2216 }
2217#endif /* MPE */
2218 if (PerlSock_bind(PerlIO_fileno(IoIFP(io)),
2219 (struct sockaddr *)addr, len) >= 0)
2220 bind_ok = 1;
2221
2222#ifdef MPE /* Switch back to USER mode */
2223 if (mpeprivmode)
2224 GETUSERMODE();
2225#endif /* MPE */
2226
2227 if (bind_ok)
a0d0e21e
LW		 2228 RETPUSHYES;
2229 else
2230 RETPUSHUNDEF;
2231
2232nuts:
599cee73 2233 if (ckWARN(WARN_CLOSED))
bc37a18f 2234 report_evil_fh(gv, io, PL_op->op_type);
748a9306 2235 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2236 RETPUSHUNDEF;
2237#else
cea2e8a9 2238 DIE(aTHX_ PL_no_sock_func, "bind");
a0d0e21e
LW		 2239#endif
2240}
2241
2242PP(pp_connect)
2243{
4e35701f 2244 djSP;
a0d0e21e 2245#ifdef HAS_SOCKET
748a9306 2246 SV *addrsv = POPs;
a0d0e21e
LW		 2247 char *addr;
2248 GV *gv = (GV*)POPs;
2249 register IO *io = GvIOn(gv);
2250 STRLEN len;
2251
2252 if (!io || !IoIFP(io))
2253 goto nuts;
2254
748a9306 2255 addr = SvPV(addrsv, len);
a0d0e21e 2256 TAINT_PROPER("connect");
6ad3d225 2257 if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
a0d0e21e
LW		 2258 RETPUSHYES;
2259 else
2260 RETPUSHUNDEF;
2261
2262nuts:
599cee73 2263 if (ckWARN(WARN_CLOSED))
bc37a18f 2264 report_evil_fh(gv, io, PL_op->op_type);
748a9306 2265 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2266 RETPUSHUNDEF;
2267#else
cea2e8a9 2268 DIE(aTHX_ PL_no_sock_func, "connect");
a0d0e21e
LW		 2269#endif
2270}
2271
2272PP(pp_listen)
2273{
4e35701f 2274 djSP;
a0d0e21e
LW		 2275#ifdef HAS_SOCKET
2276 int backlog = POPi;
2277 GV *gv = (GV*)POPs;
2278 register IO *io = GvIOn(gv);
2279
2280 if (!io || !IoIFP(io))
2281 goto nuts;
2282
6ad3d225 2283 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
a0d0e21e
LW		 2284 RETPUSHYES;
2285 else
2286 RETPUSHUNDEF;
2287
2288nuts:
599cee73 2289 if (ckWARN(WARN_CLOSED))
bc37a18f 2290 report_evil_fh(gv, io, PL_op->op_type);
748a9306 2291 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2292 RETPUSHUNDEF;
2293#else
cea2e8a9 2294 DIE(aTHX_ PL_no_sock_func, "listen");
a0d0e21e
LW		 2295#endif
2296}
2297
2298PP(pp_accept)
2299{
4e35701f 2300 djSP; dTARGET;
a0d0e21e
LW		 2301#ifdef HAS_SOCKET
2302 GV *ngv;
2303 GV *ggv;
2304 register IO *nstio;
2305 register IO *gstio;
4633a7c4 2306 struct sockaddr saddr; /* use a struct to avoid alignment problems */
1e422769 2307 Sock_size_t len = sizeof saddr;
a0d0e21e
LW		 2308 int fd;
2309
2310 ggv = (GV*)POPs;
2311 ngv = (GV*)POPs;
2312
2313 if (!ngv)
2314 goto badexit;
2315 if (!ggv)
2316 goto nuts;
2317
2318 gstio = GvIO(ggv);
2319 if (!gstio || !IoIFP(gstio))
2320 goto nuts;
2321
2322 nstio = GvIOn(ngv);
2323 if (IoIFP(nstio))
2324 do_close(ngv, FALSE);
2325
6ad3d225 2326 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *)&saddr, &len);
a0d0e21e
LW		 2327 if (fd < 0)
2328 goto badexit;
760ac839
LW		 2329 IoIFP(nstio) = PerlIO_fdopen(fd, "r");
2330 IoOFP(nstio) = PerlIO_fdopen(fd, "w");
50952442 2331 IoTYPE(nstio) = IoTYPE_SOCKET;
a0d0e21e 2332 if (!IoIFP(nstio) || !IoOFP(nstio)) {
760ac839
LW		 2333 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2334 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
6ad3d225 2335 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
a0d0e21e
LW		 2336 goto badexit;
2337 }
8d2a6795
GS		 2338#if defined(HAS_FCNTL) && defined(F_SETFD)
2339 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2340#endif
a0d0e21e 2341
ed79a026
OF		 2342#ifdef EPOC
2343 len = sizeof saddr; /* EPOC somehow truncates info */
2344#endif
2345
748a9306 2346 PUSHp((char *)&saddr, len);
a0d0e21e
LW		 2347 RETURN;
2348
2349nuts:
599cee73 2350 if (ckWARN(WARN_CLOSED))
bc37a18f 2351 report_evil_fh(ggv, ggv ? GvIO(ggv) : 0, PL_op->op_type);
748a9306 2352 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2353
2354badexit:
2355 RETPUSHUNDEF;
2356
2357#else
cea2e8a9 2358 DIE(aTHX_ PL_no_sock_func, "accept");
a0d0e21e
LW		 2359#endif
2360}
2361
2362PP(pp_shutdown)
2363{
4e35701f 2364 djSP; dTARGET;
a0d0e21e
LW		 2365#ifdef HAS_SOCKET
2366 int how = POPi;
2367 GV *gv = (GV*)POPs;
2368 register IO *io = GvIOn(gv);
2369
2370 if (!io || !IoIFP(io))
2371 goto nuts;
2372
6ad3d225 2373 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
a0d0e21e
LW		 2374 RETURN;
2375
2376nuts:
599cee73 2377 if (ckWARN(WARN_CLOSED))
bc37a18f 2378 report_evil_fh(gv, io, PL_op->op_type);
748a9306 2379 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2380 RETPUSHUNDEF;
2381#else
cea2e8a9 2382 DIE(aTHX_ PL_no_sock_func, "shutdown");
a0d0e21e
LW		 2383#endif
2384}
2385
2386PP(pp_gsockopt)
2387{
2388#ifdef HAS_SOCKET
cea2e8a9 2389 return pp_ssockopt();
a0d0e21e 2390#else
cea2e8a9 2391 DIE(aTHX_ PL_no_sock_func, "getsockopt");
a0d0e21e
LW		 2392#endif
2393}
2394
2395PP(pp_ssockopt)
2396{
4e35701f 2397 djSP;
a0d0e21e 2398#ifdef HAS_SOCKET
533c011a 2399 int optype = PL_op->op_type;
a0d0e21e
LW		 2400 SV *sv;
2401 int fd;
2402 unsigned int optname;
2403 unsigned int lvl;
2404 GV *gv;
2405 register IO *io;
1e422769 2406 Sock_size_t len;
a0d0e21e
LW		 2407
2408 if (optype == OP_GSOCKOPT)
2409 sv = sv_2mortal(NEWSV(22, 257));
2410 else
2411 sv = POPs;
2412 optname = (unsigned int) POPi;
2413 lvl = (unsigned int) POPi;
2414
2415 gv = (GV*)POPs;
2416 io = GvIOn(gv);
2417 if (!io || !IoIFP(io))
2418 goto nuts;
2419
760ac839 2420 fd = PerlIO_fileno(IoIFP(io));
a0d0e21e
LW		 2421 switch (optype) {
2422 case OP_GSOCKOPT:
748a9306 2423 SvGROW(sv, 257);
a0d0e21e 2424 (void)SvPOK_only(sv);
748a9306
LW		 2425 SvCUR_set(sv,256);
2426 *SvEND(sv) ='\0';
1e422769 2427 len = SvCUR(sv);
6ad3d225 2428 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
a0d0e21e 2429 goto nuts2;
1e422769 2430 SvCUR_set(sv, len);
748a9306 2431 *SvEND(sv) ='\0';
a0d0e21e
LW		 2432 PUSHs(sv);
2433 break;
2434 case OP_SSOCKOPT: {
1e422769 2435 char *buf;
2436 int aint;
2437 if (SvPOKp(sv)) {
2d8e6c8d
GS		 2438 STRLEN l;
2439 buf = SvPV(sv, l);
2440 len = l;
1e422769 2441 }
56ee1660 2442 else {
a0d0e21e
LW		 2443 aint = (int)SvIV(sv);
2444 buf = (char*)&aint;
2445 len = sizeof(int);
2446 }
6ad3d225 2447 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
a0d0e21e 2448 goto nuts2;
3280af22 2449 PUSHs(&PL_sv_yes);
a0d0e21e
LW		 2450 }
2451 break;
2452 }
2453 RETURN;
2454
2455nuts:
599cee73 2456 if (ckWARN(WARN_CLOSED))
bc37a18f 2457 report_evil_fh(gv, io, optype);
748a9306 2458 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2459nuts2:
2460 RETPUSHUNDEF;
2461
2462#else
cea2e8a9 2463 DIE(aTHX_ PL_no_sock_func, "setsockopt");
a0d0e21e
LW		 2464#endif
2465}
2466
2467PP(pp_getsockname)
2468{
2469#ifdef HAS_SOCKET
cea2e8a9 2470 return pp_getpeername();
a0d0e21e 2471#else
cea2e8a9 2472 DIE(aTHX_ PL_no_sock_func, "getsockname");
a0d0e21e
LW		 2473#endif
2474}
2475
2476PP(pp_getpeername)
2477{
4e35701f 2478 djSP;
a0d0e21e 2479#ifdef HAS_SOCKET
533c011a 2480 int optype = PL_op->op_type;
a0d0e21e
LW		 2481 SV *sv;
2482 int fd;
2483 GV *gv = (GV*)POPs;
2484 register IO *io = GvIOn(gv);
1e422769 2485 Sock_size_t len;
a0d0e21e
LW		 2486
2487 if (!io || !IoIFP(io))
2488 goto nuts;
2489
2490 sv = sv_2mortal(NEWSV(22, 257));
748a9306 2491 (void)SvPOK_only(sv);
1e422769 2492 len = 256;
2493 SvCUR_set(sv, len);
748a9306 2494 *SvEND(sv) ='\0';
760ac839 2495 fd = PerlIO_fileno(IoIFP(io));
a0d0e21e
LW		 2496 switch (optype) {
2497 case OP_GETSOCKNAME:
6ad3d225 2498 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
a0d0e21e
LW		 2499 goto nuts2;
2500 break;
2501 case OP_GETPEERNAME:
6ad3d225 2502 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
a0d0e21e 2503 goto nuts2;
490ab354
JH		 2504#if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2505 {
2506 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";
2507 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2508 if (((struct sockaddr *)SvPVX(sv))->sa_family == AF_INET &&
2509 !memcmp((char *)SvPVX(sv) + sizeof(u_short), nowhere,
2510 sizeof(u_short) + sizeof(struct in_addr))) {
301e8125 2511 goto nuts2;
490ab354
JH		 2512 }
2513 }
2514#endif
a0d0e21e
LW		 2515 break;
2516 }
13826f2c
CS		 2517#ifdef BOGUS_GETNAME_RETURN
2518 /* Interactive Unix, getpeername() and getsockname()
2519 does not return valid namelen */
1e422769 2520 if (len == BOGUS_GETNAME_RETURN)
2521 len = sizeof(struct sockaddr);
13826f2c 2522#endif
1e422769 2523 SvCUR_set(sv, len);
748a9306 2524 *SvEND(sv) ='\0';
a0d0e21e
LW		 2525 PUSHs(sv);
2526 RETURN;
2527
2528nuts:
599cee73 2529 if (ckWARN(WARN_CLOSED))
bc37a18f 2530 report_evil_fh(gv, io, optype);
748a9306 2531 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2532nuts2:
2533 RETPUSHUNDEF;
2534
2535#else
cea2e8a9 2536 DIE(aTHX_ PL_no_sock_func, "getpeername");
a0d0e21e
LW		 2537#endif
2538}
2539
2540/* Stat calls. */
2541
2542PP(pp_lstat)
2543{
cea2e8a9 2544 return pp_stat();
a0d0e21e
LW		 2545}
2546
2547PP(pp_stat)
2548{
4e35701f 2549 djSP;
2dd78f96 2550 GV *gv;
54310121 2551 I32 gimme;
a0d0e21e 2552 I32 max = 13;
2d8e6c8d 2553 STRLEN n_a;
a0d0e21e 2554
533c011a 2555 if (PL_op->op_flags & OPf_REF) {
2dd78f96 2556 gv = cGVOP_gv;
9d837945
TM		 2557 if (PL_op->op_type == OP_LSTAT && ckWARN(WARN_IO))
2558 Perl_warner(aTHX_ WARN_IO,
2dd78f96 2559 "lstat() on filehandle %s", GvENAME(gv));
748a9306 2560 do_fstat:
2dd78f96 2561 if (gv != PL_defgv) {
3280af22 2562 PL_laststype = OP_STAT;
2dd78f96 2563 PL_statgv = gv;
3280af22 2564 sv_setpv(PL_statname, "");
2dd78f96
JH		 2565 PL_laststatval = (GvIO(gv) && IoIFP(GvIOp(gv))
2566 ? PerlLIO_fstat(PerlIO_fileno(IoIFP(GvIOn(gv))), &PL_statcache) : -1);
a0d0e21e 2567 }
9ddeeac9 2568 if (PL_laststatval < 0) {
2dd78f96
JH		 2569 dTHR;
2570 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2571 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
a0d0e21e 2572 max = 0;
9ddeeac9 2573 }
a0d0e21e
LW		 2574 }
2575 else {
748a9306
LW		 2576 SV* sv = POPs;
2577 if (SvTYPE(sv) == SVt_PVGV) {
2dd78f96 2578 gv = (GV*)sv;
748a9306
LW		 2579 goto do_fstat;
2580 }
2581 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2dd78f96 2582 gv = (GV*)SvRV(sv);
748a9306
LW		 2583 goto do_fstat;
2584 }
2d8e6c8d 2585 sv_setpv(PL_statname, SvPV(sv,n_a));
3280af22 2586 PL_statgv = Nullgv;
a0d0e21e 2587#ifdef HAS_LSTAT
533c011a
NIS		 2588 PL_laststype = PL_op->op_type;
2589 if (PL_op->op_type == OP_LSTAT)
2d8e6c8d 2590 PL_laststatval = PerlLIO_lstat(SvPV(PL_statname, n_a), &PL_statcache);
a0d0e21e
LW		 2591 else
2592#endif
2d8e6c8d 2593 PL_laststatval = PerlLIO_stat(SvPV(PL_statname, n_a), &PL_statcache);
3280af22 2594 if (PL_laststatval < 0) {
2d8e6c8d 2595 if (ckWARN(WARN_NEWLINE) && strchr(SvPV(PL_statname, n_a), '\n'))
cea2e8a9 2596 Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "stat");
a0d0e21e
LW		 2597 max = 0;
2598 }
2599 }
2600
54310121 2601 gimme = GIMME_V;
2602 if (gimme != G_ARRAY) {
2603 if (gimme != G_VOID)
2604 XPUSHs(boolSV(max));
2605 RETURN;
a0d0e21e
LW		 2606 }
2607 if (max) {
36477c24 2608 EXTEND(SP, max);
2609 EXTEND_MORTAL(max);
1ff81528
PL		 2610 PUSHs(sv_2mortal(newSViv(PL_statcache.st_dev)));
2611 PUSHs(sv_2mortal(newSViv(PL_statcache.st_ino)));
b448e4fe
JH		 2612 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_mode)));
2613 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_nlink)));
146174a9
CB		 2614#if Uid_t_size > IVSIZE
2615 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_uid)));
2616#else
23dcd6c8 2617# if Uid_t_sign <= 0
1ff81528 2618 PUSHs(sv_2mortal(newSViv(PL_statcache.st_uid)));
23dcd6c8
JH		 2619# else
2620 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_uid)));
2621# endif
146174a9 2622#endif
301e8125 2623#if Gid_t_size > IVSIZE
146174a9
CB		 2624 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_gid)));
2625#else
23dcd6c8 2626# if Gid_t_sign <= 0
1ff81528 2627 PUSHs(sv_2mortal(newSViv(PL_statcache.st_gid)));
23dcd6c8
JH		 2628# else
2629 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_gid)));
2630# endif
146174a9 2631#endif
cbdc8872 2632#ifdef USE_STAT_RDEV
1ff81528 2633 PUSHs(sv_2mortal(newSViv(PL_statcache.st_rdev)));
cbdc8872 2634#else
79cb57f6 2635 PUSHs(sv_2mortal(newSVpvn("", 0)));
cbdc8872 2636#endif
146174a9
CB		 2637#if Off_t_size > IVSIZE
2638 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_size)));
2639#else
1ff81528 2640 PUSHs(sv_2mortal(newSViv(PL_statcache.st_size)));
146174a9 2641#endif
cbdc8872 2642#ifdef BIG_TIME
172ae379
JH		 2643 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_atime)));
2644 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_mtime)));
2645 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_ctime)));
cbdc8872 2646#else
1ff81528
PL		 2647 PUSHs(sv_2mortal(newSViv(PL_statcache.st_atime)));
2648 PUSHs(sv_2mortal(newSViv(PL_statcache.st_mtime)));
2649 PUSHs(sv_2mortal(newSViv(PL_statcache.st_ctime)));
cbdc8872 2650#endif
a0d0e21e 2651#ifdef USE_STAT_BLOCKS
b448e4fe
JH		 2652 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blksize)));
2653 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blocks)));
a0d0e21e 2654#else
79cb57f6
GS		 2655 PUSHs(sv_2mortal(newSVpvn("", 0)));
2656 PUSHs(sv_2mortal(newSVpvn("", 0)));
a0d0e21e
LW		 2657#endif
2658 }
2659 RETURN;
2660}
2661
2662PP(pp_ftrread)
2663{
5ff3f7a4 2664 I32 result;
4e35701f 2665 djSP;
5ff3f7a4 2666#if defined(HAS_ACCESS) && defined(R_OK)
2d8e6c8d 2667 STRLEN n_a;
5ff3f7a4 2668 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2669 result = access(TOPpx, R_OK);
5ff3f7a4
GS		 2670 if (result == 0)
2671 RETPUSHYES;
2672 if (result < 0)
2673 RETPUSHUNDEF;
2674 RETPUSHNO;
22865c03
GS		 2675 }
2676 else
cea2e8a9 2677 result = my_stat();
5ff3f7a4 2678#else
cea2e8a9 2679 result = my_stat();
5ff3f7a4 2680#endif
22865c03 2681 SPAGAIN;
a0d0e21e
LW		 2682 if (result < 0)
2683 RETPUSHUNDEF;
3280af22 2684 if (cando(S_IRUSR, 0, &PL_statcache))
a0d0e21e
LW		 2685 RETPUSHYES;
2686 RETPUSHNO;
2687}
2688
2689PP(pp_ftrwrite)
2690{
5ff3f7a4 2691 I32 result;
4e35701f 2692 djSP;
5ff3f7a4 2693#if defined(HAS_ACCESS) && defined(W_OK)
2d8e6c8d 2694 STRLEN n_a;
5ff3f7a4 2695 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2696 result = access(TOPpx, W_OK);
5ff3f7a4
GS		 2697 if (result == 0)
2698 RETPUSHYES;
2699 if (result < 0)
2700 RETPUSHUNDEF;
2701 RETPUSHNO;
22865c03
GS		 2702 }
2703 else
cea2e8a9 2704 result = my_stat();
5ff3f7a4 2705#else
cea2e8a9 2706 result = my_stat();
5ff3f7a4 2707#endif
22865c03 2708 SPAGAIN;
a0d0e21e
LW		 2709 if (result < 0)
2710 RETPUSHUNDEF;
3280af22 2711 if (cando(S_IWUSR, 0, &PL_statcache))
a0d0e21e
LW		 2712 RETPUSHYES;
2713 RETPUSHNO;
2714}
2715
2716PP(pp_ftrexec)
2717{
5ff3f7a4 2718 I32 result;
4e35701f 2719 djSP;
5ff3f7a4 2720#if defined(HAS_ACCESS) && defined(X_OK)
2d8e6c8d 2721 STRLEN n_a;
5ff3f7a4 2722 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2723 result = access(TOPpx, X_OK);
5ff3f7a4
GS		 2724 if (result == 0)
2725 RETPUSHYES;
2726 if (result < 0)
2727 RETPUSHUNDEF;
2728 RETPUSHNO;
22865c03
GS		 2729 }
2730 else
cea2e8a9 2731 result = my_stat();
5ff3f7a4 2732#else
cea2e8a9 2733 result = my_stat();
5ff3f7a4 2734#endif
22865c03 2735 SPAGAIN;
a0d0e21e
LW		 2736 if (result < 0)
2737 RETPUSHUNDEF;
3280af22 2738 if (cando(S_IXUSR, 0, &PL_statcache))
a0d0e21e
LW		 2739 RETPUSHYES;
2740 RETPUSHNO;
2741}
2742
2743PP(pp_fteread)
2744{
5ff3f7a4 2745 I32 result;
4e35701f 2746 djSP;
5ff3f7a4 2747#ifdef PERL_EFF_ACCESS_R_OK
2d8e6c8d 2748 STRLEN n_a;
5ff3f7a4 2749 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2750 result = PERL_EFF_ACCESS_R_OK(TOPpx);
5ff3f7a4
GS		 2751 if (result == 0)
2752 RETPUSHYES;
2753 if (result < 0)
2754 RETPUSHUNDEF;
2755 RETPUSHNO;
22865c03
GS		 2756 }
2757 else
cea2e8a9 2758 result = my_stat();
5ff3f7a4 2759#else
cea2e8a9 2760 result = my_stat();
5ff3f7a4 2761#endif
22865c03 2762 SPAGAIN;
a0d0e21e
LW		 2763 if (result < 0)
2764 RETPUSHUNDEF;
3280af22 2765 if (cando(S_IRUSR, 1, &PL_statcache))
a0d0e21e
LW		 2766 RETPUSHYES;
2767 RETPUSHNO;
2768}
2769
2770PP(pp_ftewrite)
2771{
5ff3f7a4 2772 I32 result;
4e35701f 2773 djSP;
5ff3f7a4 2774#ifdef PERL_EFF_ACCESS_W_OK
2d8e6c8d 2775 STRLEN n_a;
5ff3f7a4 2776 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2777 result = PERL_EFF_ACCESS_W_OK(TOPpx);
5ff3f7a4
GS		 2778 if (result == 0)
2779 RETPUSHYES;
2780 if (result < 0)
2781 RETPUSHUNDEF;
2782 RETPUSHNO;
22865c03
GS		 2783 }
2784 else
cea2e8a9 2785 result = my_stat();
5ff3f7a4 2786#else
cea2e8a9 2787 result = my_stat();
5ff3f7a4 2788#endif
22865c03 2789 SPAGAIN;
a0d0e21e
LW		 2790 if (result < 0)
2791 RETPUSHUNDEF;
3280af22 2792 if (cando(S_IWUSR, 1, &PL_statcache))
a0d0e21e
LW		 2793 RETPUSHYES;
2794 RETPUSHNO;
2795}
2796
2797PP(pp_fteexec)
2798{
5ff3f7a4 2799 I32 result;
4e35701f 2800 djSP;
5ff3f7a4 2801#ifdef PERL_EFF_ACCESS_X_OK
2d8e6c8d 2802 STRLEN n_a;
5ff3f7a4 2803 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2804 result = PERL_EFF_ACCESS_X_OK(TOPpx);
5ff3f7a4
GS		 2805 if (result == 0)
2806 RETPUSHYES;
2807 if (result < 0)
2808 RETPUSHUNDEF;
2809 RETPUSHNO;
22865c03
GS		 2810 }
2811 else
cea2e8a9 2812 result = my_stat();
5ff3f7a4 2813#else
cea2e8a9 2814 result = my_stat();
5ff3f7a4 2815#endif
22865c03 2816 SPAGAIN;
a0d0e21e
LW		 2817 if (result < 0)
2818 RETPUSHUNDEF;
3280af22 2819 if (cando(S_IXUSR, 1, &PL_statcache))
a0d0e21e
LW		 2820 RETPUSHYES;
2821 RETPUSHNO;
2822}
2823
2824PP(pp_ftis)
2825{
cea2e8a9 2826 I32 result = my_stat();
4e35701f 2827 djSP;
a0d0e21e
LW		 2828 if (result < 0)
2829 RETPUSHUNDEF;
2830 RETPUSHYES;
2831}
2832
2833PP(pp_fteowned)
2834{
cea2e8a9 2835 return pp_ftrowned();
a0d0e21e
LW		 2836}
2837
2838PP(pp_ftrowned)
2839{
cea2e8a9 2840 I32 result = my_stat();
4e35701f 2841 djSP;
a0d0e21e
LW		 2842 if (result < 0)
2843 RETPUSHUNDEF;
146174a9
CB		 2844 if (PL_statcache.st_uid == (PL_op->op_type == OP_FTEOWNED ?
2845 PL_euid : PL_uid) )
a0d0e21e
LW		 2846 RETPUSHYES;
2847 RETPUSHNO;
2848}
2849
2850PP(pp_ftzero)
2851{
cea2e8a9 2852 I32 result = my_stat();
4e35701f 2853 djSP;
a0d0e21e
LW		 2854 if (result < 0)
2855 RETPUSHUNDEF;
146174a9 2856 if (PL_statcache.st_size == 0)
a0d0e21e
LW		 2857 RETPUSHYES;
2858 RETPUSHNO;
2859}
2860
2861PP(pp_ftsize)
2862{
cea2e8a9 2863 I32 result = my_stat();
4e35701f 2864 djSP; dTARGET;
a0d0e21e
LW		 2865 if (result < 0)
2866 RETPUSHUNDEF;
146174a9
CB		 2867#if Off_t_size > IVSIZE
2868 PUSHn(PL_statcache.st_size);
2869#else
3280af22 2870 PUSHi(PL_statcache.st_size);
146174a9 2871#endif
a0d0e21e
LW		 2872 RETURN;
2873}
2874
2875PP(pp_ftmtime)
2876{
cea2e8a9 2877 I32 result = my_stat();
4e35701f 2878 djSP; dTARGET;
a0d0e21e
LW		 2879 if (result < 0)
2880 RETPUSHUNDEF;
c6419e06 2881 PUSHn( (PL_basetime - PL_statcache.st_mtime) / 86400.0 );
a0d0e21e
LW		 2882 RETURN;
2883}
2884
2885PP(pp_ftatime)
2886{
cea2e8a9 2887 I32 result = my_stat();
4e35701f 2888 djSP; dTARGET;
a0d0e21e
LW		 2889 if (result < 0)
2890 RETPUSHUNDEF;
c6419e06 2891 PUSHn( (PL_basetime - PL_statcache.st_atime) / 86400.0 );
a0d0e21e
LW		 2892 RETURN;
2893}
2894
2895PP(pp_ftctime)
2896{
cea2e8a9 2897 I32 result = my_stat();
4e35701f 2898 djSP; dTARGET;
a0d0e21e
LW		 2899 if (result < 0)
2900 RETPUSHUNDEF;
c6419e06 2901 PUSHn( (PL_basetime - PL_statcache.st_ctime) / 86400.0 );
a0d0e21e
LW		 2902 RETURN;
2903}
2904
2905PP(pp_ftsock)
2906{
cea2e8a9 2907 I32 result = my_stat();
4e35701f 2908 djSP;
a0d0e21e
LW		 2909 if (result < 0)
2910 RETPUSHUNDEF;
3280af22 2911 if (S_ISSOCK(PL_statcache.st_mode))
a0d0e21e
LW		 2912 RETPUSHYES;
2913 RETPUSHNO;
2914}
2915
2916PP(pp_ftchr)
2917{
cea2e8a9 2918 I32 result = my_stat();
4e35701f 2919 djSP;
a0d0e21e
LW		 2920 if (result < 0)
2921 RETPUSHUNDEF;
3280af22 2922 if (S_ISCHR(PL_statcache.st_mode))
a0d0e21e
LW		 2923 RETPUSHYES;
2924 RETPUSHNO;
2925}
2926
2927PP(pp_ftblk)
2928{
cea2e8a9 2929 I32 result = my_stat();
4e35701f 2930 djSP;
a0d0e21e
LW		 2931 if (result < 0)
2932 RETPUSHUNDEF;
3280af22 2933 if (S_ISBLK(PL_statcache.st_mode))
a0d0e21e
LW		 2934 RETPUSHYES;
2935 RETPUSHNO;
2936}
2937
2938PP(pp_ftfile)
2939{
cea2e8a9 2940 I32 result = my_stat();
4e35701f 2941 djSP;
a0d0e21e
LW		 2942 if (result < 0)
2943 RETPUSHUNDEF;
3280af22 2944 if (S_ISREG(PL_statcache.st_mode))
a0d0e21e
LW		 2945 RETPUSHYES;
2946 RETPUSHNO;
2947}
2948
2949PP(pp_ftdir)
2950{
cea2e8a9 2951 I32 result = my_stat();
4e35701f 2952 djSP;
a0d0e21e
LW		 2953 if (result < 0)
2954 RETPUSHUNDEF;
3280af22 2955 if (S_ISDIR(PL_statcache.st_mode))
a0d0e21e
LW		 2956 RETPUSHYES;
2957 RETPUSHNO;
2958}
2959
2960PP(pp_ftpipe)
2961{
cea2e8a9 2962 I32 result = my_stat();
4e35701f 2963 djSP;
a0d0e21e
LW		 2964 if (result < 0)
2965 RETPUSHUNDEF;
3280af22 2966 if (S_ISFIFO(PL_statcache.st_mode))
a0d0e21e
LW		 2967 RETPUSHYES;
2968 RETPUSHNO;
2969}
2970
2971PP(pp_ftlink)
2972{
cea2e8a9 2973 I32 result = my_lstat();
4e35701f 2974 djSP;
a0d0e21e
LW		 2975 if (result < 0)
2976 RETPUSHUNDEF;
3280af22 2977 if (S_ISLNK(PL_statcache.st_mode))
a0d0e21e
LW		 2978 RETPUSHYES;
2979 RETPUSHNO;
2980}
2981
2982PP(pp_ftsuid)
2983{
4e35701f 2984 djSP;
a0d0e21e 2985#ifdef S_ISUID
cea2e8a9 2986 I32 result = my_stat();
a0d0e21e
LW		 2987 SPAGAIN;
2988 if (result < 0)
2989 RETPUSHUNDEF;
3280af22 2990 if (PL_statcache.st_mode & S_ISUID)
a0d0e21e
LW		 2991 RETPUSHYES;
2992#endif
2993 RETPUSHNO;
2994}
2995
2996PP(pp_ftsgid)
2997{
4e35701f 2998 djSP;
a0d0e21e 2999#ifdef S_ISGID
cea2e8a9 3000 I32 result = my_stat();
a0d0e21e
LW		 3001 SPAGAIN;
3002 if (result < 0)
3003 RETPUSHUNDEF;
3280af22 3004 if (PL_statcache.st_mode & S_ISGID)
a0d0e21e
LW		 3005 RETPUSHYES;
3006#endif
3007 RETPUSHNO;
3008}
3009
3010PP(pp_ftsvtx)
3011{
4e35701f 3012 djSP;
a0d0e21e 3013#ifdef S_ISVTX
cea2e8a9 3014 I32 result = my_stat();
a0d0e21e
LW		 3015 SPAGAIN;
3016 if (result < 0)
3017 RETPUSHUNDEF;
3280af22 3018 if (PL_statcache.st_mode & S_ISVTX)
a0d0e21e
LW		 3019 RETPUSHYES;
3020#endif
3021 RETPUSHNO;
3022}
3023
3024PP(pp_fttty)
3025{
4e35701f 3026 djSP;
a0d0e21e
LW		 3027 int fd;
3028 GV *gv;
fb73857a 3029 char *tmps = Nullch;
2d8e6c8d 3030 STRLEN n_a;
fb73857a 3031
533c011a 3032 if (PL_op->op_flags & OPf_REF)
146174a9 3033 gv = cGVOP_gv;
fb73857a 3034 else if (isGV(TOPs))
3035 gv = (GV*)POPs;
3036 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3037 gv = (GV*)SvRV(POPs);
a0d0e21e 3038 else
2d8e6c8d 3039 gv = gv_fetchpv(tmps = POPpx, FALSE, SVt_PVIO);
fb73857a 3040
a0d0e21e 3041 if (GvIO(gv) && IoIFP(GvIOp(gv)))
760ac839 3042 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
fb73857a 3043 else if (tmps && isDIGIT(*tmps))
a0d0e21e
LW		 3044 fd = atoi(tmps);
3045 else
3046 RETPUSHUNDEF;
6ad3d225 3047 if (PerlLIO_isatty(fd))
a0d0e21e
LW		 3048 RETPUSHYES;
3049 RETPUSHNO;
3050}
3051
16d20bd9
AD		 3052#if defined(atarist) /* this will work with atariST. Configure will
3053 make guesses for other systems. */
3054# define FILE_base(f) ((f)->_base)
3055# define FILE_ptr(f) ((f)->_ptr)
3056# define FILE_cnt(f) ((f)->_cnt)
3057# define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
a0d0e21e
LW		 3058#endif
3059
3060PP(pp_fttext)
3061{
4e35701f 3062 djSP;
a0d0e21e
LW		 3063 I32 i;
3064 I32 len;
3065 I32 odd = 0;
3066 STDCHAR tbuf[512];
3067 register STDCHAR *s;
3068 register IO *io;
5f05dabc 3069 register SV *sv;
3070 GV *gv;
2d8e6c8d 3071 STRLEN n_a;
146174a9 3072 PerlIO *fp;
a0d0e21e 3073
533c011a 3074 if (PL_op->op_flags & OPf_REF)
146174a9 3075 gv = cGVOP_gv;
5f05dabc 3076 else if (isGV(TOPs))
3077 gv = (GV*)POPs;
3078 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3079 gv = (GV*)SvRV(POPs);
3080 else
3081 gv = Nullgv;
3082
3083 if (gv) {
a0d0e21e 3084 EXTEND(SP, 1);
3280af22
NIS		 3085 if (gv == PL_defgv) {
3086 if (PL_statgv)
3087 io = GvIO(PL_statgv);
a0d0e21e 3088 else {
3280af22 3089 sv = PL_statname;
a0d0e21e
LW		 3090 goto really_filename;
3091 }
3092 }
3093 else {
3280af22
NIS		 3094 PL_statgv = gv;
3095 PL_laststatval = -1;
3096 sv_setpv(PL_statname, "");
3097 io = GvIO(PL_statgv);
a0d0e21e
LW		 3098 }
3099 if (io && IoIFP(io)) {
5f05dabc 3100 if (! PerlIO_has_base(IoIFP(io)))
cea2e8a9 3101 DIE(aTHX_ "-T and -B not implemented on filehandles");
3280af22
NIS		 3102 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3103 if (PL_laststatval < 0)
5f05dabc 3104 RETPUSHUNDEF;
3280af22 3105 if (S_ISDIR(PL_statcache.st_mode)) /* handle NFS glitch */
533c011a 3106 if (PL_op->op_type == OP_FTTEXT)
a0d0e21e
LW		 3107 RETPUSHNO;
3108 else
3109 RETPUSHYES;
a20bf0c3 3110 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
760ac839 3111 i = PerlIO_getc(IoIFP(io));
a0d0e21e 3112 if (i != EOF)
760ac839 3113 (void)PerlIO_ungetc(IoIFP(io),i);
a0d0e21e 3114 }
a20bf0c3 3115 if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
a0d0e21e 3116 RETPUSHYES;
a20bf0c3
JH		 3117 len = PerlIO_get_bufsiz(IoIFP(io));
3118 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
760ac839
LW		 3119 /* sfio can have large buffers - limit to 512 */
3120 if (len > 512)
3121 len = 512;
a0d0e21e
LW		 3122 }
3123 else {
2dd78f96
JH		 3124 dTHR;
3125 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
146174a9 3126 gv = cGVOP_gv;
2dd78f96 3127 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
146174a9 3128 }
748a9306 3129 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW		 3130 RETPUSHUNDEF;
3131 }
3132 }
3133 else {
3134 sv = POPs;
5f05dabc 3135 really_filename:
3280af22
NIS		 3136 PL_statgv = Nullgv;
3137 PL_laststatval = -1;
2d8e6c8d 3138 sv_setpv(PL_statname, SvPV(sv, n_a));
146174a9 3139 if (!(fp = PerlIO_open(SvPVX(PL_statname), "r"))) {
2d8e6c8d 3140 if (ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, n_a), '\n'))
cea2e8a9 3141 Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "open");
a0d0e21e
LW		 3142 RETPUSHUNDEF;
3143 }
146174a9
CB		 3144 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3145 if (PL_laststatval < 0) {
3146 (void)PerlIO_close(fp);
5f05dabc 3147 RETPUSHUNDEF;
146174a9 3148 }
92d29cee 3149 do_binmode(fp, '<', O_BINARY);
146174a9
CB		 3150 len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3151 (void)PerlIO_close(fp);
a0d0e21e 3152 if (len <= 0) {
533c011a 3153 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
a0d0e21e
LW		 3154 RETPUSHNO; /* special case NFS directories */
3155 RETPUSHYES; /* null file is anything */
3156 }
3157 s = tbuf;
3158 }
3159
3160 /* now scan s to look for textiness */
4633a7c4 3161 /* XXX ASCII dependent code */
a0d0e21e 3162
146174a9
CB		 3163#if defined(DOSISH) || defined(USEMYBINMODE)
3164 /* ignore trailing ^Z on short files */
3165 if (len && len < sizeof(tbuf) && tbuf[len-1] == 26)
3166 --len;
3167#endif
3168
a0d0e21e
LW		 3169 for (i = 0; i < len; i++, s++) {
3170 if (!*s) { /* null never allowed in text */
3171 odd += len;
3172 break;
3173 }
9d116dd7 3174#ifdef EBCDIC
301e8125 3175 else if (!(isPRINT(*s) || isSPACE(*s)))
9d116dd7
JH		 3176 odd++;
3177#else
146174a9
CB		 3178 else if (*s & 128) {
3179#ifdef USE_LOCALE
b3f66c68
GS		 3180 if ((PL_op->op_private & OPpLOCALE) && isALPHA_LC(*s))
3181 continue;
3182#endif
3183 /* utf8 characters don't count as odd */
3184 if (*s & 0x40) {
3185 int ulen = UTF8SKIP(s);
3186 if (ulen < len - i) {
3187 int j;
3188 for (j = 1; j < ulen; j++) {
3189 if ((s[j] & 0xc0) != 0x80)
3190 goto not_utf8;
3191 }
3192 --ulen; /* loop does extra increment */
3193 s += ulen;
3194 i += ulen;
3195 continue;
3196 }
3197 }
3198 not_utf8:
3199 odd++;
146174a9 3200 }
a0d0e21e
LW		 3201 else if (*s < 32 &&
3202 *s != '\n' && *s != '\r' && *s != '\b' &&
3203 *s != '\t' && *s != '\f' && *s != 27)
3204 odd++;
9d116dd7 3205#endif
a0d0e21e
LW		 3206 }
3207
533c011a 3208 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
a0d0e21e
LW		 3209 RETPUSHNO;
3210 else
3211 RETPUSHYES;
3212}
3213
3214PP(pp_ftbinary)
3215{
cea2e8a9 3216 return pp_fttext();
a0d0e21e
LW		 3217}
3218
3219/* File calls. */
3220
3221PP(pp_chdir)
3222{
4e35701f 3223 djSP; dTARGET;
a0d0e21e
LW		 3224 char *tmps;
3225 SV **svp;
2d8e6c8d 3226 STRLEN n_a;
a0d0e21e
LW		 3227
3228 if (MAXARG < 1)
3229 tmps = Nullch;
3230 else
2d8e6c8d 3231 tmps = POPpx;
a0d0e21e 3232 if (!tmps || !*tmps) {
3280af22 3233 svp = hv_fetch(GvHVn(PL_envgv), "HOME", 4, FALSE);
a0d0e21e 3234 if (svp)
2d8e6c8d 3235 tmps = SvPV(*svp, n_a);
a0d0e21e
LW		 3236 }
3237 if (!tmps || !*tmps) {
3280af22 3238 svp = hv_fetch(GvHVn(PL_envgv), "LOGDIR", 6, FALSE);
a0d0e21e 3239 if (svp)
2d8e6c8d 3240 tmps = SvPV(*svp, n_a);
a0d0e21e 3241 }
491527d0
GS		 3242#ifdef VMS
3243 if (!tmps || !*tmps) {
6b88bc9c 3244 svp = hv_fetch(GvHVn(PL_envgv), "SYS$LOGIN", 9, FALSE);
491527d0 3245 if (svp)
2d8e6c8d 3246 tmps = SvPV(*svp, n_a);
491527d0
GS		 3247 }
3248#endif
a0d0e21e 3249 TAINT_PROPER("chdir");
6ad3d225 3250 PUSHi( PerlDir_chdir(tmps) >= 0 );
748a9306
LW		 3251#ifdef VMS
3252 /* Clear the DEFAULT element of ENV so we'll get the new value
3253 * in the future. */
6b88bc9c 3254 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
748a9306 3255#endif
a0d0e21e
LW		 3256 RETURN;
3257}
3258
3259PP(pp_chown)
3260{
4e35701f 3261 djSP; dMARK; dTARGET;
a0d0e21e
LW		 3262 I32 value;
3263#ifdef HAS_CHOWN
533c011a 3264 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 3265 SP = MARK;
3266 PUSHi(value);
3267 RETURN;
3268#else
cea2e8a9 3269 DIE(aTHX_ PL_no_func, "Unsupported function chown");
a0d0e21e
LW		 3270#endif
3271}
3272
3273PP(pp_chroot)
3274{
4e35701f 3275 djSP; dTARGET;
a0d0e21e
LW		 3276 char *tmps;
3277#ifdef HAS_CHROOT
2d8e6c8d
GS		 3278 STRLEN n_a;
3279 tmps = POPpx;
a0d0e21e
LW		 3280 TAINT_PROPER("chroot");
3281 PUSHi( chroot(tmps) >= 0 );
3282 RETURN;
3283#else
cea2e8a9 3284 DIE(aTHX_ PL_no_func, "chroot");
a0d0e21e
LW		 3285#endif
3286}
3287
3288PP(pp_unlink)
3289{
4e35701f 3290 djSP; dMARK; dTARGET;
a0d0e21e 3291 I32 value;
533c011a 3292 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 3293 SP = MARK;
3294 PUSHi(value);
3295 RETURN;
3296}
3297
3298PP(pp_chmod)
3299{
4e35701f 3300 djSP; dMARK; dTARGET;
a0d0e21e 3301 I32 value;
533c011a 3302 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 3303 SP = MARK;
3304 PUSHi(value);
3305 RETURN;
3306}
3307
3308PP(pp_utime)
3309{
4e35701f 3310 djSP; dMARK; dTARGET;
a0d0e21e 3311 I32 value;
533c011a 3312 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 3313 SP = MARK;
3314 PUSHi(value);
3315 RETURN;
3316}
3317
3318PP(pp_rename)
3319{
4e35701f 3320 djSP; dTARGET;
a0d0e21e 3321 int anum;
2d8e6c8d 3322 STRLEN n_a;
a0d0e21e 3323
2d8e6c8d
GS		 3324 char *tmps2 = POPpx;
3325 char *tmps = SvPV(TOPs, n_a);
a0d0e21e
LW		 3326 TAINT_PROPER("rename");
3327#ifdef HAS_RENAME
baed7233 3328 anum = PerlLIO_rename(tmps, tmps2);
a0d0e21e 3329#else
6b88bc9c 3330 if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
ed969818
W		 3331 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3332 anum = 1;
3333 else {
3654eb6c 3334 if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
ed969818
W		 3335 (void)UNLINK(tmps2);
3336 if (!(anum = link(tmps, tmps2)))
3337 anum = UNLINK(tmps);
3338 }
a0d0e21e
LW		 3339 }
3340#endif
3341 SETi( anum >= 0 );
3342 RETURN;
3343}
3344
3345PP(pp_link)
3346{
4e35701f 3347 djSP; dTARGET;
a0d0e21e 3348#ifdef HAS_LINK
2d8e6c8d
GS		 3349 STRLEN n_a;
3350 char *tmps2 = POPpx;
3351 char *tmps = SvPV(TOPs, n_a);
a0d0e21e 3352 TAINT_PROPER("link");
146174a9 3353 SETi( PerlLIO_link(tmps, tmps2) >= 0 );
a0d0e21e 3354#else
cea2e8a9 3355 DIE(aTHX_ PL_no_func, "Unsupported function link");
a0d0e21e
LW		 3356#endif
3357 RETURN;
3358}
3359
3360PP(pp_symlink)
3361{
4e35701f 3362 djSP; dTARGET;
a0d0e21e 3363#ifdef HAS_SYMLINK
2d8e6c8d
GS		 3364 STRLEN n_a;
3365 char *tmps2 = POPpx;
3366 char *tmps = SvPV(TOPs, n_a);
a0d0e21e
LW		 3367 TAINT_PROPER("symlink");
3368 SETi( symlink(tmps, tmps2) >= 0 );
3369 RETURN;
3370#else
cea2e8a9 3371 DIE(aTHX_ PL_no_func, "symlink");
a0d0e21e
LW		 3372#endif
3373}
3374
3375PP(pp_readlink)
3376{
4e35701f 3377 djSP; dTARGET;
a0d0e21e
LW		 3378#ifdef HAS_SYMLINK
3379 char *tmps;
46fc3d4c 3380 char buf[MAXPATHLEN];
a0d0e21e 3381 int len;
2d8e6c8d 3382 STRLEN n_a;
46fc3d4c 3383
fb73857a 3384#ifndef INCOMPLETE_TAINTS
3385 TAINT;
3386#endif
2d8e6c8d 3387 tmps = POPpx;
a0d0e21e
LW		 3388 len = readlink(tmps, buf, sizeof buf);
3389 EXTEND(SP, 1);
3390 if (len < 0)
3391 RETPUSHUNDEF;
3392 PUSHp(buf, len);
3393 RETURN;
3394#else
3395 EXTEND(SP, 1);
3396 RETSETUNDEF; /* just pretend it's a normal file */
3397#endif
3398}
3399
3400#if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
ba106d47 3401STATIC int
cea2e8a9 3402S_dooneliner(pTHX_ char *cmd, char *filename)
a0d0e21e 3403{
1e422769 3404 char *save_filename = filename;
3405 char *cmdline;
3406 char *s;
760ac839 3407 PerlIO *myfp;
1e422769 3408 int anum = 1;
a0d0e21e 3409
1e422769 3410 New(666, cmdline, strlen(cmd) + (strlen(filename) * 2) + 10, char);
3411 strcpy(cmdline, cmd);
3412 strcat(cmdline, " ");
3413 for (s = cmdline + strlen(cmdline); *filename; ) {
a0d0e21e
LW		 3414 *s++ = '\\';
3415 *s++ = *filename++;
3416 }
3417 strcpy(s, " 2>&1");
6ad3d225 3418 myfp = PerlProc_popen(cmdline, "r");
1e422769 3419 Safefree(cmdline);
3420
a0d0e21e 3421 if (myfp) {
1e422769 3422 SV *tmpsv = sv_newmortal();
6b88bc9c 3423 /* Need to save/restore 'PL_rs' ?? */
760ac839 3424 s = sv_gets(tmpsv, myfp, 0);
6ad3d225 3425 (void)PerlProc_pclose(myfp);
a0d0e21e 3426 if (s != Nullch) {
1e422769 3427 int e;
3428 for (e = 1;
a0d0e21e 3429#ifdef HAS_SYS_ERRLIST
1e422769 3430 e <= sys_nerr
3431#endif
3432 ; e++)
3433 {
3434 /* you don't see this */
3435 char *errmsg =
3436#ifdef HAS_SYS_ERRLIST
3437 sys_errlist[e]
a0d0e21e 3438#else
1e422769 3439 strerror(e)
a0d0e21e 3440#endif
1e422769 3441 ;
3442 if (!errmsg)
3443 break;
3444 if (instr(s, errmsg)) {
3445 SETERRNO(e,0);
3446 return 0;
3447 }
a0d0e21e 3448 }
748a9306 3449 SETERRNO(0,0);
a0d0e21e
LW		 3450#ifndef EACCES
3451#define EACCES EPERM
3452#endif
1e422769 3453 if (instr(s, "cannot make"))
748a9306 3454 SETERRNO(EEXIST,RMS$_FEX);
1e422769 3455 else if (instr(s, "existing file"))
748a9306 3456 SETERRNO(EEXIST,RMS$_FEX);
1e422769 3457 else if (instr(s, "ile exists"))
748a9306 3458 SETERRNO(EEXIST,RMS$_FEX);
1e422769 3459 else if (instr(s, "non-exist"))
748a9306 3460 SETERRNO(ENOENT,RMS$_FNF);
1e422769 3461 else if (instr(s, "does not exist"))
748a9306 3462 SETERRNO(ENOENT,RMS$_FNF);
1e422769 3463 else if (instr(s, "not empty"))
748a9306 3464 SETERRNO(EBUSY,SS$_DEVOFFLINE);
1e422769 3465 else if (instr(s, "cannot access"))
748a9306 3466 SETERRNO(EACCES,RMS$_PRV);
a0d0e21e 3467 else
748a9306 3468 SETERRNO(EPERM,RMS$_PRV);
a0d0e21e
LW		 3469 return 0;
3470 }
3471 else { /* some mkdirs return no failure indication */
6b88bc9c 3472 anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
911d147d 3473 if (PL_op->op_type == OP_RMDIR)
a0d0e21e
LW		 3474 anum = !anum;
3475 if (anum)
748a9306 3476 SETERRNO(0,0);
a0d0e21e 3477 else
748a9306 3478 SETERRNO(EACCES,RMS$_PRV); /* a guess */
a0d0e21e
LW		 3479 }
3480 return anum;
3481 }
3482 else
3483 return 0;
3484}
3485#endif
3486
3487PP(pp_mkdir)
3488{
4e35701f 3489 djSP; dTARGET;
5a211162 3490 int mode;
a0d0e21e
LW		 3491#ifndef HAS_MKDIR
3492 int oldumask;
3493#endif
2d8e6c8d 3494 STRLEN n_a;
5a211162
GS		 3495 char *tmps;
3496
3497 if (MAXARG > 1)
3498 mode = POPi;
3499 else
3500 mode = 0777;
3501
3502 tmps = SvPV(TOPs, n_a);
a0d0e21e
LW		 3503
3504 TAINT_PROPER("mkdir");
3505#ifdef HAS_MKDIR
6ad3d225 3506 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
a0d0e21e
LW		 3507#else
3508 SETi( dooneliner("mkdir", tmps) );
6ad3d225
GS		 3509 oldumask = PerlLIO_umask(0);
3510 PerlLIO_umask(oldumask);
3511 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
a0d0e21e
LW		 3512#endif
3513 RETURN;
3514}
3515
3516PP(pp_rmdir)
3517{
4e35701f 3518 djSP; dTARGET;
a0d0e21e 3519 char *tmps;
2d8e6c8d 3520 STRLEN n_a;
a0d0e21e 3521
2d8e6c8d 3522 tmps = POPpx;
a0d0e21e
LW		 3523 TAINT_PROPER("rmdir");
3524#ifdef HAS_RMDIR
6ad3d225 3525 XPUSHi( PerlDir_rmdir(tmps) >= 0 );
a0d0e21e
LW		 3526#else
3527 XPUSHi( dooneliner("rmdir", tmps) );
3528#endif
3529 RETURN;
3530}
3531
3532/* Directory calls. */
3533
3534PP(pp_open_dir)
3535{
4e35701f 3536 djSP;
a0d0e21e 3537#if defined(Direntry_t) && defined(HAS_READDIR)
2d8e6c8d
GS		 3538 STRLEN n_a;
3539 char *dirname = POPpx;
a0d0e21e
LW		 3540 GV *gv = (GV*)POPs;
3541 register IO *io = GvIOn(gv);
3542
3543 if (!io)
3544 goto nope;
3545
3546 if (IoDIRP(io))
6ad3d225
GS		 3547 PerlDir_close(IoDIRP(io));
3548 if (!(IoDIRP(io) = PerlDir_open(dirname)))
a0d0e21e
LW		 3549 goto nope;
3550
3551 RETPUSHYES;
3552nope:
3553 if (!errno)
748a9306 3554 SETERRNO(EBADF,RMS$_DIR);
a0d0e21e
LW		 3555 RETPUSHUNDEF;
3556#else
cea2e8a9 3557 DIE(aTHX_ PL_no_dir_func, "opendir");
a0d0e21e
LW		 3558#endif
3559}
3560
3561PP(pp_readdir)
3562{
4e35701f 3563 djSP;
a0d0e21e
LW		 3564#if defined(Direntry_t) && defined(HAS_READDIR)
3565#ifndef I_DIRENT
20ce7b12 3566 Direntry_t *readdir (DIR *);
a0d0e21e
LW		 3567#endif
3568 register Direntry_t *dp;
3569 GV *gv = (GV*)POPs;
3570 register IO *io = GvIOn(gv);
fb73857a 3571 SV *sv;
a0d0e21e
LW		 3572
3573 if (!io || !IoDIRP(io))
3574 goto nope;
3575
3576 if (GIMME == G_ARRAY) {
3577 /*SUPPRESS 560*/
155aba94 3578 while ((dp = (Direntry_t *)PerlDir_read(IoDIRP(io)))) {
a0d0e21e 3579#ifdef DIRNAMLEN
79cb57f6 3580 sv = newSVpvn(dp->d_name, dp->d_namlen);
a0d0e21e 3581#else
fb73857a 3582 sv = newSVpv(dp->d_name, 0);
3583#endif
3584#ifndef INCOMPLETE_TAINTS
26fb8f1f
GS		 3585 if (!(IoFLAGS(io) & IOf_UNTAINT))
3586 SvTAINTED_on(sv);
a0d0e21e 3587#endif
fb73857a 3588 XPUSHs(sv_2mortal(sv));
a0d0e21e
LW		 3589 }
3590 }
3591 else {
6ad3d225 3592 if (!(dp = (Direntry_t *)PerlDir_read(IoDIRP(io))))
a0d0e21e
LW		 3593 goto nope;
3594#ifdef DIRNAMLEN
79cb57f6 3595 sv = newSVpvn(dp->d_name, dp->d_namlen);
a0d0e21e 3596#else
fb73857a 3597 sv = newSVpv(dp->d_name, 0);
a0d0e21e 3598#endif
fb73857a 3599#ifndef INCOMPLETE_TAINTS
26fb8f1f
GS		 3600 if (!(IoFLAGS(io) & IOf_UNTAINT))
3601 SvTAINTED_on(sv);
fb73857a 3602#endif
3603 XPUSHs(sv_2mortal(sv));
a0d0e21e
LW		 3604 }
3605 RETURN;
3606
3607nope:
3608 if (!errno)
748a9306 3609 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 3610 if (GIMME == G_ARRAY)
3611 RETURN;
3612 else
3613 RETPUSHUNDEF;
3614#else
cea2e8a9 3615 DIE(aTHX_ PL_no_dir_func, "readdir");
a0d0e21e
LW		 3616#endif
3617}
3618
3619PP(pp_telldir)
3620{
4e35701f 3621 djSP; dTARGET;
a0d0e21e 3622#if defined(HAS_TELLDIR) || defined(telldir)
968dcd91
JH		 3623 /* XXX does _anyone_ need this? --AD 2/20/1998 */
3624 /* XXX netbsd still seemed to.
3625 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3626 --JHI 1999-Feb-02 */
3627# if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
20ce7b12 3628 long telldir (DIR *);
dfe9444c 3629# endif
a0d0e21e
LW		 3630 GV *gv = (GV*)POPs;
3631 register IO *io = GvIOn(gv);
3632
3633 if (!io || !IoDIRP(io))
3634 goto nope;
3635
6ad3d225 3636 PUSHi( PerlDir_tell(IoDIRP(io)) );
a0d0e21e
LW		 3637 RETURN;
3638nope:
3639 if (!errno)
748a9306 3640 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 3641 RETPUSHUNDEF;
3642#else
cea2e8a9 3643 DIE(aTHX_ PL_no_dir_func, "telldir");
a0d0e21e
LW		 3644#endif
3645}
3646
3647PP(pp_seekdir)
3648{
4e35701f 3649 djSP;
a0d0e21e
LW		 3650#if defined(HAS_SEEKDIR) || defined(seekdir)
3651 long along = POPl;
3652 GV *gv = (GV*)POPs;
3653 register IO *io = GvIOn(gv);
3654
3655 if (!io || !IoDIRP(io))
3656 goto nope;
3657
6ad3d225 3658 (void)PerlDir_seek(IoDIRP(io), along);
a0d0e21e
LW		 3659
3660 RETPUSHYES;
3661nope:
3662 if (!errno)
748a9306 3663 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 3664 RETPUSHUNDEF;
3665#else
cea2e8a9 3666 DIE(aTHX_ PL_no_dir_func, "seekdir");
a0d0e21e
LW		 3667#endif
3668}
3669
3670PP(pp_rewinddir)
3671{
4e35701f 3672 djSP;
a0d0e21e
LW		 3673#if defined(HAS_REWINDDIR) || defined(rewinddir)
3674 GV *gv = (GV*)POPs;
3675 register IO *io = GvIOn(gv);
3676
3677 if (!io || !IoDIRP(io))
3678 goto nope;
3679
6ad3d225 3680 (void)PerlDir_rewind(IoDIRP(io));
a0d0e21e
LW		 3681 RETPUSHYES;
3682nope:
3683 if (!errno)
748a9306 3684 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 3685 RETPUSHUNDEF;
3686#else
cea2e8a9 3687 DIE(aTHX_ PL_no_dir_func, "rewinddir");
a0d0e21e
LW		 3688#endif
3689}
3690
3691PP(pp_closedir)
3692{
4e35701f 3693 djSP;
a0d0e21e
LW		 3694#if defined(Direntry_t) && defined(HAS_READDIR)
3695 GV *gv = (GV*)POPs;
3696 register IO *io = GvIOn(gv);
3697
3698 if (!io || !IoDIRP(io))
3699 goto nope;
3700
3701#ifdef VOID_CLOSEDIR
6ad3d225 3702 PerlDir_close(IoDIRP(io));
a0d0e21e 3703#else
6ad3d225 3704 if (PerlDir_close(IoDIRP(io)) < 0) {
748a9306 3705 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
a0d0e21e 3706 goto nope;
748a9306 3707 }
a0d0e21e
LW		 3708#endif
3709 IoDIRP(io) = 0;
3710
3711 RETPUSHYES;
3712nope:
3713 if (!errno)
748a9306 3714 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW		 3715 RETPUSHUNDEF;
3716#else
cea2e8a9 3717 DIE(aTHX_ PL_no_dir_func, "closedir");
a0d0e21e
LW		 3718#endif
3719}
3720
3721/* Process control. */
3722
3723PP(pp_fork)
3724{
44a8e56a 3725#ifdef HAS_FORK
4e35701f 3726 djSP; dTARGET;
761237fe 3727 Pid_t childpid;
a0d0e21e
LW		 3728 GV *tmpgv;
3729
3730 EXTEND(SP, 1);
45bc9206 3731 PERL_FLUSHALL_FOR_CHILD;
a0d0e21e
LW		 3732 childpid = fork();
3733 if (childpid < 0)
3734 RETSETUNDEF;
3735 if (!childpid) {
3736 /*SUPPRESS 560*/
155aba94 3737 if ((tmpgv = gv_fetchpv("$", TRUE, SVt_PV)))
146174a9 3738 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3280af22 3739 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
a0d0e21e
LW		 3740 }
3741 PUSHi(childpid);
3742 RETURN;
3743#else
146174a9
CB		 3744# if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3745 djSP; dTARGET;
3746 Pid_t childpid;
3747
3748 EXTEND(SP, 1);
3749 PERL_FLUSHALL_FOR_CHILD;
3750 childpid = PerlProc_fork();
60fa28ff
GS		 3751 if (childpid == -1)
3752 RETSETUNDEF;
146174a9
CB		 3753 PUSHi(childpid);
3754 RETURN;
3755# else
cea2e8a9 3756 DIE(aTHX_ PL_no_func, "Unsupported function fork");
146174a9 3757# endif
a0d0e21e
LW		 3758#endif
3759}
3760
3761PP(pp_wait)
3762{
301e8125 3763#if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
4e35701f 3764 djSP; dTARGET;
761237fe 3765 Pid_t childpid;
a0d0e21e 3766 int argflags;
a0d0e21e 3767
44a8e56a 3768 childpid = wait4pid(-1, &argflags, 0);
68a29c53
GS		 3769# if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3770 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
3771 STATUS_NATIVE_SET((childpid && childpid != -1) ? argflags : -1);
3772# else
f86702cc 3773 STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
68a29c53 3774# endif
44a8e56a 3775 XPUSHi(childpid);
a0d0e21e
LW		 3776 RETURN;
3777#else
cea2e8a9 3778 DIE(aTHX_ PL_no_func, "Unsupported function wait");
a0d0e21e
LW		 3779#endif
3780}
3781
3782PP(pp_waitpid)
3783{
301e8125 3784#if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
4e35701f 3785 djSP; dTARGET;
761237fe 3786 Pid_t childpid;
a0d0e21e
LW		 3787 int optype;
3788 int argflags;
a0d0e21e 3789
a0d0e21e
LW		 3790 optype = POPi;
3791 childpid = TOPi;
3792 childpid = wait4pid(childpid, &argflags, optype);
68a29c53
GS		 3793# if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3794 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
3795 STATUS_NATIVE_SET((childpid && childpid != -1) ? argflags : -1);
3796# else
f86702cc 3797 STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
68a29c53 3798# endif
44a8e56a 3799 SETi(childpid);
a0d0e21e
LW		 3800 RETURN;
3801#else
cea2e8a9 3802 DIE(aTHX_ PL_no_func, "Unsupported function waitpid");
a0d0e21e
LW		 3803#endif
3804}
3805
3806PP(pp_system)
3807{
4e35701f 3808 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e 3809 I32 value;
761237fe 3810 Pid_t childpid;
a0d0e21e
LW		 3811 int result;
3812 int status;
ff68c719 3813 Sigsave_t ihand,qhand; /* place to save signals during system() */
2d8e6c8d 3814 STRLEN n_a;
d5a9bfb0
IZ		 3815 I32 did_pipes = 0;
3816 int pp[2];
a0d0e21e 3817
a0d0e21e 3818 if (SP - MARK == 1) {
3280af22 3819 if (PL_tainting) {
2d8e6c8d 3820 char *junk = SvPV(TOPs, n_a);
a0d0e21e
LW		 3821 TAINT_ENV();
3822 TAINT_PROPER("system");
3823 }
3824 }
45bc9206 3825 PERL_FLUSHALL_FOR_CHILD;
64ca3a65 3826#if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) && !defined(__CYGWIN__) || defined(PERL_MICRO)
d5a9bfb0
IZ		 3827 if (PerlProc_pipe(pp) >= 0)
3828 did_pipes = 1;
a0d0e21e
LW		 3829 while ((childpid = vfork()) == -1) {
3830 if (errno != EAGAIN) {
3831 value = -1;
3832 SP = ORIGMARK;
3833 PUSHi(value);
d5a9bfb0
IZ		 3834 if (did_pipes) {
3835 PerlLIO_close(pp[0]);
3836 PerlLIO_close(pp[1]);
3837 }
a0d0e21e
LW		 3838 RETURN;
3839 }
3840 sleep(5);
3841 }
3842 if (childpid > 0) {
d5a9bfb0
IZ		 3843 if (did_pipes)
3844 PerlLIO_close(pp[1]);
64ca3a65 3845#ifndef PERL_MICRO
ff68c719 3846 rsignal_save(SIGINT, SIG_IGN, &ihand);
3847 rsignal_save(SIGQUIT, SIG_IGN, &qhand);
64ca3a65 3848#endif
748a9306
LW		 3849 do {
3850 result = wait4pid(childpid, &status, 0);
3851 } while (result == -1 && errno == EINTR);
64ca3a65 3852#ifndef PERL_MICRO
ff68c719 3853 (void)rsignal_restore(SIGINT, &ihand);
3854 (void)rsignal_restore(SIGQUIT, &qhand);
64ca3a65 3855#endif
91e9c03f 3856 STATUS_NATIVE_SET(result == -1 ? -1 : status);
a0d0e21e
LW		 3857 do_execfree(); /* free any memory child malloced on vfork */
3858 SP = ORIGMARK;
d5a9bfb0
IZ		 3859 if (did_pipes) {
3860 int errkid;
3861 int n = 0, n1;
3862
3863 while (n < sizeof(int)) {
3864 n1 = PerlLIO_read(pp[0],
3865 (void*)(((char*)&errkid)+n),
3866 (sizeof(int)) - n);
3867 if (n1 <= 0)
3868 break;
3869 n += n1;
3870 }
3871 PerlLIO_close(pp[0]);
3872 if (n) { /* Error */
3873 if (n != sizeof(int))
c529f79d 3874 DIE(aTHX_ "panic: kid popen errno read");
d5a9bfb0
IZ		 3875 errno = errkid; /* Propagate errno from kid */
3876 STATUS_CURRENT = -1;
3877 }
3878 }
ff0cee69 3879 PUSHi(STATUS_CURRENT);
a0d0e21e
LW		 3880 RETURN;
3881 }
d5a9bfb0
IZ		 3882 if (did_pipes) {
3883 PerlLIO_close(pp[0]);
3884#if defined(HAS_FCNTL) && defined(F_SETFD)
3885 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
3886#endif
3887 }
533c011a 3888 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e 3889 SV *really = *++MARK;
d5a9bfb0 3890 value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
a0d0e21e
LW		 3891 }
3892 else if (SP - MARK != 1)
d5a9bfb0 3893 value = (I32)do_aexec5(Nullsv, MARK, SP, pp[1], did_pipes);
a0d0e21e 3894 else {
d5a9bfb0 3895 value = (I32)do_exec3(SvPVx(sv_mortalcopy(*SP), n_a), pp[1], did_pipes);
a0d0e21e 3896 }
6ad3d225 3897 PerlProc__exit(-1);
c3293030 3898#else /* ! FORK or VMS or OS/2 */
922b1888
GS		 3899 PL_statusvalue = 0;
3900 result = 0;
911d147d 3901 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e 3902 SV *really = *++MARK;
c5be433b 3903 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
a0d0e21e
LW		 3904 }
3905 else if (SP - MARK != 1)
c5be433b 3906 value = (I32)do_aspawn(Nullsv, (void **)MARK, (void **)SP);
a0d0e21e 3907 else {
c5be433b 3908 value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
a0d0e21e 3909 }
922b1888
GS		 3910 if (PL_statusvalue == -1) /* hint that value must be returned as is */
3911 result = 1;
f86702cc 3912 STATUS_NATIVE_SET(value);
a0d0e21e
LW		 3913 do_execfree();
3914 SP = ORIGMARK;
922b1888 3915 PUSHi(result ? value : STATUS_CURRENT);
a0d0e21e
LW		 3916#endif /* !FORK or VMS */
3917 RETURN;
3918}
3919
3920PP(pp_exec)
3921{
4e35701f 3922 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e 3923 I32 value;
2d8e6c8d 3924 STRLEN n_a;
a0d0e21e 3925
45bc9206 3926 PERL_FLUSHALL_FOR_CHILD;
533c011a 3927 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e
LW		 3928 SV *really = *++MARK;
3929 value = (I32)do_aexec(really, MARK, SP);
3930 }
3931 else if (SP - MARK != 1)
3932#ifdef VMS
3933 value = (I32)vms_do_aexec(Nullsv, MARK, SP);
3934#else
092bebab
JH		 3935# ifdef __OPEN_VM
3936 {
c5be433b 3937 (void ) do_aspawn(Nullsv, MARK, SP);
092bebab
JH		 3938 value = 0;
3939 }
3940# else
a0d0e21e 3941 value = (I32)do_aexec(Nullsv, MARK, SP);
092bebab 3942# endif
a0d0e21e
LW		 3943#endif
3944 else {
3280af22 3945 if (PL_tainting) {
2d8e6c8d 3946 char *junk = SvPV(*SP, n_a);
a0d0e21e
LW		 3947 TAINT_ENV();
3948 TAINT_PROPER("exec");
3949 }
3950#ifdef VMS
2d8e6c8d 3951 value = (I32)vms_do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
a0d0e21e 3952#else
092bebab 3953# ifdef __OPEN_VM
c5be433b 3954 (void) do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
092bebab
JH		 3955 value = 0;
3956# else
2d8e6c8d 3957 value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
092bebab 3958# endif
a0d0e21e
LW		 3959#endif
3960 }
146174a9
CB		 3961
3962#if !defined(HAS_FORK) && defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3963 if (value >= 0)
3964 my_exit(value);
3965#endif
3966
a0d0e21e
LW		 3967 SP = ORIGMARK;
3968 PUSHi(value);
3969 RETURN;
3970}
3971
3972PP(pp_kill)
3973{
4e35701f 3974 djSP; dMARK; dTARGET;
a0d0e21e
LW		 3975 I32 value;
3976#ifdef HAS_KILL
533c011a 3977 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 3978 SP = MARK;
3979 PUSHi(value);
3980 RETURN;
3981#else
cea2e8a9 3982 DIE(aTHX_ PL_no_func, "Unsupported function kill");
a0d0e21e
LW		 3983#endif
3984}
3985
3986PP(pp_getppid)
3987{
3988#ifdef HAS_GETPPID
4e35701f 3989 djSP; dTARGET;
a0d0e21e
LW		 3990 XPUSHi( getppid() );
3991 RETURN;
3992#else
cea2e8a9 3993 DIE(aTHX_ PL_no_func, "getppid");
a0d0e21e
LW		 3994#endif
3995}
3996
3997PP(pp_getpgrp)
3998{
3999#ifdef HAS_GETPGRP
4e35701f 4000 djSP; dTARGET;
d8a83dd3 4001 Pid_t pid;
9853a804 4002 Pid_t pgrp;
a0d0e21e
LW		 4003
4004 if (MAXARG < 1)
4005 pid = 0;
4006 else
4007 pid = SvIVx(POPs);
c3293030 4008#ifdef BSD_GETPGRP
9853a804 4009 pgrp = (I32)BSD_GETPGRP(pid);
a0d0e21e 4010#else
146174a9 4011 if (pid != 0 && pid != PerlProc_getpid())
cea2e8a9 4012 DIE(aTHX_ "POSIX getpgrp can't take an argument");
9853a804 4013 pgrp = getpgrp();
a0d0e21e 4014#endif
9853a804 4015 XPUSHi(pgrp);
a0d0e21e
LW		 4016 RETURN;
4017#else
cea2e8a9 4018 DIE(aTHX_ PL_no_func, "getpgrp()");
a0d0e21e
LW		 4019#endif
4020}
4021
4022PP(pp_setpgrp)
4023{
4024#ifdef HAS_SETPGRP
4e35701f 4025 djSP; dTARGET;
d8a83dd3
JH		 4026 Pid_t pgrp;
4027 Pid_t pid;
a0d0e21e
LW		 4028 if (MAXARG < 2) {
4029 pgrp = 0;
4030 pid = 0;
4031 }
4032 else {
4033 pgrp = POPi;
4034 pid = TOPi;
4035 }
4036
4037 TAINT_PROPER("setpgrp");
c3293030
IZ		 4038#ifdef BSD_SETPGRP
4039 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
a0d0e21e 4040#else
146174a9
CB		 4041 if ((pgrp != 0 && pgrp != PerlProc_getpid())
4042 || (pid != 0 && pid != PerlProc_getpid()))
4043 {
4044 DIE(aTHX_ "setpgrp can't take arguments");
4045 }
a0d0e21e
LW		 4046 SETi( setpgrp() >= 0 );
4047#endif /* USE_BSDPGRP */
4048 RETURN;
4049#else
cea2e8a9 4050 DIE(aTHX_ PL_no_func, "setpgrp()");
a0d0e21e
LW		 4051#endif
4052}
4053
4054PP(pp_getpriority)
4055{
4e35701f 4056 djSP; dTARGET;
a0d0e21e
LW		 4057 int which;
4058 int who;
4059#ifdef HAS_GETPRIORITY
4060 who = POPi;
4061 which = TOPi;
4062 SETi( getpriority(which, who) );
4063 RETURN;
4064#else
cea2e8a9 4065 DIE(aTHX_ PL_no_func, "getpriority()");
a0d0e21e
LW		 4066#endif
4067}
4068
4069PP(pp_setpriority)
4070{
4e35701f 4071 djSP; dTARGET;
a0d0e21e
LW		 4072 int which;
4073 int who;
4074 int niceval;
4075#ifdef HAS_SETPRIORITY
4076 niceval = POPi;
4077 who = POPi;
4078 which = TOPi;
4079 TAINT_PROPER("setpriority");
4080 SETi( setpriority(which, who, niceval) >= 0 );
4081 RETURN;
4082#else
cea2e8a9 4083 DIE(aTHX_ PL_no_func, "setpriority()");
a0d0e21e
LW		 4084#endif
4085}
4086
4087/* Time calls. */
4088
4089PP(pp_time)
4090{
4e35701f 4091 djSP; dTARGET;
cbdc8872 4092#ifdef BIG_TIME
4093 XPUSHn( time(Null(Time_t*)) );
4094#else
a0d0e21e 4095 XPUSHi( time(Null(Time_t*)) );
cbdc8872 4096#endif
a0d0e21e
LW		 4097 RETURN;
4098}
4099
cd52b7b2 4100/* XXX The POSIX name is CLK_TCK; it is to be preferred
4101 to HZ. Probably. For now, assume that if the system
4102 defines HZ, it does so correctly. (Will this break
4103 on VMS?)
4104 Probably we ought to use _sysconf(_SC_CLK_TCK), if
4105 it's supported. --AD 9/96.
4106*/
4107
a0d0e21e 4108#ifndef HZ
cd52b7b2 4109# ifdef CLK_TCK
4110# define HZ CLK_TCK
4111# else
4112# define HZ 60
4113# endif
a0d0e21e
LW		 4114#endif
4115
4116PP(pp_tms)
4117{
4e35701f 4118 djSP;
a0d0e21e 4119
55497cff 4120#ifndef HAS_TIMES
cea2e8a9 4121 DIE(aTHX_ "times not implemented");
a0d0e21e
LW		 4122#else
4123 EXTEND(SP, 4);
4124
4125#ifndef VMS
3280af22 4126 (void)PerlProc_times(&PL_timesbuf);
a0d0e21e 4127#else
6b88bc9c 4128 (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */
76e3520e
GS		 4129 /* struct tms, though same data */
4130 /* is returned. */
a0d0e21e
LW		 4131#endif
4132
65202027 4133 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_utime)/HZ)));
a0d0e21e 4134 if (GIMME == G_ARRAY) {
65202027
DS		 4135 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_stime)/HZ)));
4136 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cutime)/HZ)));
4137 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cstime)/HZ)));
a0d0e21e
LW		 4138 }
4139 RETURN;
55497cff 4140#endif /* HAS_TIMES */
a0d0e21e
LW		 4141}
4142
4143PP(pp_localtime)
4144{
cea2e8a9 4145 return pp_gmtime();
a0d0e21e
LW		 4146}
4147
4148PP(pp_gmtime)
4149{
4e35701f 4150 djSP;
a0d0e21e
LW		 4151 Time_t when;
4152 struct tm *tmbuf;
4153 static char *dayname[] = {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4154 static char *monname[] = {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4155 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4156
4157 if (MAXARG < 1)
4158 (void)time(&when);
4159 else
cbdc8872 4160#ifdef BIG_TIME
4161 when = (Time_t)SvNVx(POPs);
4162#else
a0d0e21e 4163 when = (Time_t)SvIVx(POPs);
cbdc8872 4164#endif
a0d0e21e 4165
533c011a 4166 if (PL_op->op_type == OP_LOCALTIME)
a0d0e21e
LW		 4167 tmbuf = localtime(&when);
4168 else
4169 tmbuf = gmtime(&when);
4170
4171 EXTEND(SP, 9);
bbce6d69 4172 EXTEND_MORTAL(9);
a0d0e21e 4173 if (GIMME != G_ARRAY) {
46fc3d4c 4174 SV *tsv;
a0d0e21e
LW		 4175 if (!tmbuf)
4176 RETPUSHUNDEF;
be28567c 4177 tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %d",
f5a29b03
RB		 4178 dayname[tmbuf->tm_wday],
4179 monname[tmbuf->tm_mon],
be28567c
GS		 4180 tmbuf->tm_mday,
4181 tmbuf->tm_hour,
4182 tmbuf->tm_min,
4183 tmbuf->tm_sec,
4184 tmbuf->tm_year + 1900);
46fc3d4c 4185 PUSHs(sv_2mortal(tsv));
a0d0e21e
LW		 4186 }
4187 else if (tmbuf) {
c6419e06
JH		 4188 PUSHs(sv_2mortal(newSViv(tmbuf->tm_sec)));
4189 PUSHs(sv_2mortal(newSViv(tmbuf->tm_min)));
4190 PUSHs(sv_2mortal(newSViv(tmbuf->tm_hour)));
4191 PUSHs(sv_2mortal(newSViv(tmbuf->tm_mday)));
4192 PUSHs(sv_2mortal(newSViv(tmbuf->tm_mon)));
4193 PUSHs(sv_2mortal(newSViv(tmbuf->tm_year)));
4194 PUSHs(sv_2mortal(newSViv(tmbuf->tm_wday)));
4195 PUSHs(sv_2mortal(newSViv(tmbuf->tm_yday)));
4196 PUSHs(sv_2mortal(newSViv(tmbuf->tm_isdst)));
a0d0e21e
LW		 4197 }
4198 RETURN;
4199}
4200
4201PP(pp_alarm)
4202{
4e35701f 4203 djSP; dTARGET;
a0d0e21e
LW		 4204 int anum;
4205#ifdef HAS_ALARM
4206 anum = POPi;
4207 anum = alarm((unsigned int)anum);
4208 EXTEND(SP, 1);
4209 if (anum < 0)
4210 RETPUSHUNDEF;
c6419e06 4211 PUSHi(anum);
a0d0e21e
LW		 4212 RETURN;
4213#else
cea2e8a9 4214 DIE(aTHX_ PL_no_func, "Unsupported function alarm");
a0d0e21e
LW		 4215#endif
4216}
4217
4218PP(pp_sleep)
4219{
4e35701f 4220 djSP; dTARGET;
a0d0e21e
LW		 4221 I32 duration;
4222 Time_t lasttime;
4223 Time_t when;
4224
4225 (void)time(&lasttime);
4226 if (MAXARG < 1)
76e3520e 4227 PerlProc_pause();
a0d0e21e
LW		 4228 else {
4229 duration = POPi;
76e3520e 4230 PerlProc_sleep((unsigned int)duration);
a0d0e21e
LW		 4231 }
4232 (void)time(&when);
4233 XPUSHi(when - lasttime);
4234 RETURN;
4235}
4236
4237/* Shared memory. */
4238
4239PP(pp_shmget)
4240{
cea2e8a9 4241 return pp_semget();
a0d0e21e
LW		 4242}
4243
4244PP(pp_shmctl)
4245{
cea2e8a9 4246 return pp_semctl();
a0d0e21e
LW		 4247}
4248
4249PP(pp_shmread)
4250{
cea2e8a9 4251 return pp_shmwrite();
a0d0e21e
LW		 4252}
4253
4254PP(pp_shmwrite)
4255{
4256#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 4257 djSP; dMARK; dTARGET;
533c011a 4258 I32 value = (I32)(do_shmio(PL_op->op_type, MARK, SP) >= 0);
a0d0e21e
LW		 4259 SP = MARK;
4260 PUSHi(value);
4261 RETURN;
4262#else
cea2e8a9 4263 return pp_semget();
a0d0e21e
LW		 4264#endif
4265}
4266
4267/* Message passing. */
4268
4269PP(pp_msgget)
4270{
cea2e8a9 4271 return pp_semget();
a0d0e21e
LW		 4272}
4273
4274PP(pp_msgctl)
4275{
cea2e8a9 4276 return pp_semctl();
a0d0e21e
LW		 4277}
4278
4279PP(pp_msgsnd)
4280{
4281#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 4282 djSP; dMARK; dTARGET;
a0d0e21e
LW		 4283 I32 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4284 SP = MARK;
4285 PUSHi(value);
4286 RETURN;
4287#else
cea2e8a9 4288 return pp_semget();
a0d0e21e
LW		 4289#endif
4290}
4291
4292PP(pp_msgrcv)
4293{
4294#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 4295 djSP; dMARK; dTARGET;
a0d0e21e
LW		 4296 I32 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4297 SP = MARK;
4298 PUSHi(value);
4299 RETURN;
4300#else
cea2e8a9 4301 return pp_semget();
a0d0e21e
LW		 4302#endif
4303}
4304
4305/* Semaphores. */
4306
4307PP(pp_semget)
4308{
4309#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 4310 djSP; dMARK; dTARGET;
533c011a 4311 int anum = do_ipcget(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 4312 SP = MARK;
4313 if (anum == -1)
4314 RETPUSHUNDEF;
4315 PUSHi(anum);
4316 RETURN;
4317#else
cea2e8a9 4318 DIE(aTHX_ "System V IPC is not implemented on this machine");
a0d0e21e
LW		 4319#endif
4320}
4321
4322PP(pp_semctl)
4323{
4324#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 4325 djSP; dMARK; dTARGET;
533c011a 4326 int anum = do_ipcctl(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 4327 SP = MARK;
4328 if (anum == -1)
4329 RETSETUNDEF;
4330 if (anum != 0) {
4331 PUSHi(anum);
4332 }
4333 else {
8903cb82 4334 PUSHp(zero_but_true, ZBTLEN);
a0d0e21e
LW		 4335 }
4336 RETURN;
4337#else
cea2e8a9 4338 return pp_semget();
a0d0e21e
LW		 4339#endif
4340}
4341
4342PP(pp_semop)
4343{
4344#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 4345 djSP; dMARK; dTARGET;
a0d0e21e
LW		 4346 I32 value = (I32)(do_semop(MARK, SP) >= 0);
4347 SP = MARK;
4348 PUSHi(value);
4349 RETURN;
4350#else
cea2e8a9 4351 return pp_semget();
a0d0e21e
LW		 4352#endif
4353}
4354
4355/* Get system info. */
4356
4357PP(pp_ghbyname)
4358{
693762b4 4359#ifdef HAS_GETHOSTBYNAME
cea2e8a9 4360 return pp_ghostent();
a0d0e21e 4361#else
cea2e8a9 4362 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
a0d0e21e
LW		 4363#endif
4364}
4365
4366PP(pp_ghbyaddr)
4367{
693762b4 4368#ifdef HAS_GETHOSTBYADDR
cea2e8a9 4369 return pp_ghostent();
a0d0e21e 4370#else
cea2e8a9 4371 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
a0d0e21e
LW		 4372#endif
4373}
4374
4375PP(pp_ghostent)
4376{
4e35701f 4377 djSP;
693762b4 4378#if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
533c011a 4379 I32 which = PL_op->op_type;
a0d0e21e
LW		 4380 register char **elem;
4381 register SV *sv;
dc45a647 4382#ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4599a1de
JH		 4383 struct hostent *PerlSock_gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4384 struct hostent *PerlSock_gethostbyname(Netdb_name_t);
6ad3d225 4385 struct hostent *PerlSock_gethostent(void);
a0d0e21e
LW		 4386#endif
4387 struct hostent *hent;
4388 unsigned long len;
2d8e6c8d 4389 STRLEN n_a;
a0d0e21e
LW		 4390
4391 EXTEND(SP, 10);
dc45a647
MB		 4392 if (which == OP_GHBYNAME)
4393#ifdef HAS_GETHOSTBYNAME
2d8e6c8d 4394 hent = PerlSock_gethostbyname(POPpx);
dc45a647 4395#else
cea2e8a9 4396 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
dc45a647 4397#endif
a0d0e21e 4398 else if (which == OP_GHBYADDR) {
dc45a647 4399#ifdef HAS_GETHOSTBYADDR
a0d0e21e 4400 int addrtype = POPi;
748a9306 4401 SV *addrsv = POPs;
a0d0e21e 4402 STRLEN addrlen;
4599a1de 4403 Netdb_host_t addr = (Netdb_host_t) SvPV(addrsv, addrlen);
a0d0e21e 4404
4599a1de 4405 hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
dc45a647 4406#else
cea2e8a9 4407 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
dc45a647 4408#endif
a0d0e21e
LW		 4409 }
4410 else
4411#ifdef HAS_GETHOSTENT
6ad3d225 4412 hent = PerlSock_gethostent();
a0d0e21e 4413#else
cea2e8a9 4414 DIE(aTHX_ PL_no_sock_func, "gethostent");
a0d0e21e
LW		 4415#endif
4416
4417#ifdef HOST_NOT_FOUND
4418 if (!hent)
f86702cc 4419 STATUS_NATIVE_SET(h_errno);
a0d0e21e
LW		 4420#endif
4421
4422 if (GIMME != G_ARRAY) {
4423 PUSHs(sv = sv_newmortal());
4424 if (hent) {
4425 if (which == OP_GHBYNAME) {
fd0af264 4426 if (hent->h_addr)
4427 sv_setpvn(sv, hent->h_addr, hent->h_length);
a0d0e21e
LW		 4428 }
4429 else
4430 sv_setpv(sv, (char*)hent->h_name);
4431 }
4432 RETURN;
4433 }
4434
4435 if (hent) {
3280af22 4436 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4437 sv_setpv(sv, (char*)hent->h_name);
3280af22 4438 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 4439 for (elem = hent->h_aliases; elem && *elem; elem++) {
4440 sv_catpv(sv, *elem);
4441 if (elem[1])
4442 sv_catpvn(sv, " ", 1);
4443 }
3280af22 4444 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4445 sv_setiv(sv, (IV)hent->h_addrtype);
3280af22 4446 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4447 len = hent->h_length;
1e422769 4448 sv_setiv(sv, (IV)len);
a0d0e21e
LW		 4449#ifdef h_addr
4450 for (elem = hent->h_addr_list; elem && *elem; elem++) {
3280af22 4451 XPUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 4452 sv_setpvn(sv, *elem, len);
4453 }
4454#else
6b88bc9c 4455 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
fd0af264 4456 if (hent->h_addr)
4457 sv_setpvn(sv, hent->h_addr, len);
a0d0e21e
LW		 4458#endif /* h_addr */
4459 }
4460 RETURN;
4461#else
cea2e8a9 4462 DIE(aTHX_ PL_no_sock_func, "gethostent");
a0d0e21e
LW		 4463#endif
4464}
4465
4466PP(pp_gnbyname)
4467{
693762b4 4468#ifdef HAS_GETNETBYNAME
cea2e8a9 4469 return pp_gnetent();
a0d0e21e 4470#else
cea2e8a9 4471 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
a0d0e21e
LW		 4472#endif
4473}
4474
4475PP(pp_gnbyaddr)
4476{
693762b4 4477#ifdef HAS_GETNETBYADDR
cea2e8a9 4478 return pp_gnetent();
a0d0e21e 4479#else
cea2e8a9 4480 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
a0d0e21e
LW		 4481#endif
4482}
4483
4484PP(pp_gnetent)
4485{
4e35701f 4486 djSP;
693762b4 4487#if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
533c011a 4488 I32 which = PL_op->op_type;
a0d0e21e
LW		 4489 register char **elem;
4490 register SV *sv;
dc45a647
MB		 4491#ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4492 struct netent *PerlSock_getnetbyaddr(Netdb_net_t, int);
4493 struct netent *PerlSock_getnetbyname(Netdb_name_t);
4494 struct netent *PerlSock_getnetent(void);
8ac85365 4495#endif
a0d0e21e 4496 struct netent *nent;
2d8e6c8d 4497 STRLEN n_a;
a0d0e21e
LW		 4498
4499 if (which == OP_GNBYNAME)
dc45a647 4500#ifdef HAS_GETNETBYNAME
2d8e6c8d 4501 nent = PerlSock_getnetbyname(POPpx);
dc45a647 4502#else
cea2e8a9 4503 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
dc45a647 4504#endif
a0d0e21e 4505 else if (which == OP_GNBYADDR) {
dc45a647 4506#ifdef HAS_GETNETBYADDR
a0d0e21e 4507 int addrtype = POPi;
4599a1de 4508 Netdb_net_t addr = (Netdb_net_t) U_L(POPn);
76e3520e 4509 nent = PerlSock_getnetbyaddr(addr, addrtype);
dc45a647 4510#else
cea2e8a9 4511 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
dc45a647 4512#endif
a0d0e21e
LW		 4513 }
4514 else
dc45a647 4515#ifdef HAS_GETNETENT
76e3520e 4516 nent = PerlSock_getnetent();
dc45a647 4517#else
cea2e8a9 4518 DIE(aTHX_ PL_no_sock_func, "getnetent");
dc45a647 4519#endif
a0d0e21e
LW		 4520
4521 EXTEND(SP, 4);
4522 if (GIMME != G_ARRAY) {
4523 PUSHs(sv = sv_newmortal());
4524 if (nent) {
4525 if (which == OP_GNBYNAME)
1e422769 4526 sv_setiv(sv, (IV)nent->n_net);
a0d0e21e
LW		 4527 else
4528 sv_setpv(sv, nent->n_name);
4529 }
4530 RETURN;
4531 }
4532
4533 if (nent) {
3280af22 4534 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4535 sv_setpv(sv, nent->n_name);
3280af22 4536 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 4537 for (elem = nent->n_aliases; elem && *elem; elem++) {
a0d0e21e
LW		 4538 sv_catpv(sv, *elem);
4539 if (elem[1])
4540 sv_catpvn(sv, " ", 1);
4541 }
3280af22 4542 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4543 sv_setiv(sv, (IV)nent->n_addrtype);
3280af22 4544 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4545 sv_setiv(sv, (IV)nent->n_net);
a0d0e21e
LW		 4546 }
4547
4548 RETURN;
4549#else
cea2e8a9 4550 DIE(aTHX_ PL_no_sock_func, "getnetent");
a0d0e21e
LW		 4551#endif
4552}
4553
4554PP(pp_gpbyname)
4555{
693762b4 4556#ifdef HAS_GETPROTOBYNAME
cea2e8a9 4557 return pp_gprotoent();
a0d0e21e 4558#else
cea2e8a9 4559 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
a0d0e21e
LW		 4560#endif
4561}
4562
4563PP(pp_gpbynumber)
4564{
693762b4 4565#ifdef HAS_GETPROTOBYNUMBER
cea2e8a9 4566 return pp_gprotoent();
a0d0e21e 4567#else
cea2e8a9 4568 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
a0d0e21e
LW		 4569#endif
4570}
4571
4572PP(pp_gprotoent)
4573{
4e35701f 4574 djSP;
693762b4 4575#if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
533c011a 4576 I32 which = PL_op->op_type;
a0d0e21e 4577 register char **elem;
301e8125 4578 register SV *sv;
dc45a647 4579#ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4599a1de 4580 struct protoent *PerlSock_getprotobyname(Netdb_name_t);
6ad3d225
GS		 4581 struct protoent *PerlSock_getprotobynumber(int);
4582 struct protoent *PerlSock_getprotoent(void);
8ac85365 4583#endif
a0d0e21e 4584 struct protoent *pent;
2d8e6c8d 4585 STRLEN n_a;
a0d0e21e
LW		 4586
4587 if (which == OP_GPBYNAME)
e5c9fcd0 4588#ifdef HAS_GETPROTOBYNAME
2d8e6c8d 4589 pent = PerlSock_getprotobyname(POPpx);
e5c9fcd0 4590#else
cea2e8a9 4591 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
e5c9fcd0 4592#endif
a0d0e21e 4593 else if (which == OP_GPBYNUMBER)
e5c9fcd0 4594#ifdef HAS_GETPROTOBYNUMBER
6ad3d225 4595 pent = PerlSock_getprotobynumber(POPi);
e5c9fcd0 4596#else
cea2e8a9 4597 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
e5c9fcd0 4598#endif
a0d0e21e 4599 else
e5c9fcd0 4600#ifdef HAS_GETPROTOENT
6ad3d225 4601 pent = PerlSock_getprotoent();
e5c9fcd0 4602#else
cea2e8a9 4603 DIE(aTHX_ PL_no_sock_func, "getprotoent");
e5c9fcd0 4604#endif
a0d0e21e
LW		 4605
4606 EXTEND(SP, 3);
4607 if (GIMME != G_ARRAY) {
4608 PUSHs(sv = sv_newmortal());
4609 if (pent) {
4610 if (which == OP_GPBYNAME)
1e422769 4611 sv_setiv(sv, (IV)pent->p_proto);
a0d0e21e
LW		 4612 else
4613 sv_setpv(sv, pent->p_name);
4614 }
4615 RETURN;
4616 }
4617
4618 if (pent) {
3280af22 4619 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4620 sv_setpv(sv, pent->p_name);
3280af22 4621 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 4622 for (elem = pent->p_aliases; elem && *elem; elem++) {
a0d0e21e
LW		 4623 sv_catpv(sv, *elem);
4624 if (elem[1])
4625 sv_catpvn(sv, " ", 1);
4626 }
3280af22 4627 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4628 sv_setiv(sv, (IV)pent->p_proto);
a0d0e21e
LW		 4629 }
4630
4631 RETURN;
4632#else
cea2e8a9 4633 DIE(aTHX_ PL_no_sock_func, "getprotoent");
a0d0e21e
LW		 4634#endif
4635}
4636
4637PP(pp_gsbyname)
4638{
9ec75305 4639#ifdef HAS_GETSERVBYNAME
cea2e8a9 4640 return pp_gservent();
a0d0e21e 4641#else
cea2e8a9 4642 DIE(aTHX_ PL_no_sock_func, "getservbyname");
a0d0e21e
LW		 4643#endif
4644}
4645
4646PP(pp_gsbyport)
4647{
9ec75305 4648#ifdef HAS_GETSERVBYPORT
cea2e8a9 4649 return pp_gservent();
a0d0e21e 4650#else
cea2e8a9 4651 DIE(aTHX_ PL_no_sock_func, "getservbyport");
a0d0e21e
LW		 4652#endif
4653}
4654
4655PP(pp_gservent)
4656{
4e35701f 4657 djSP;
693762b4 4658#if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
533c011a 4659 I32 which = PL_op->op_type;
a0d0e21e
LW		 4660 register char **elem;
4661 register SV *sv;
dc45a647 4662#ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4599a1de
JH		 4663 struct servent *PerlSock_getservbyname(Netdb_name_t, Netdb_name_t);
4664 struct servent *PerlSock_getservbyport(int, Netdb_name_t);
6ad3d225 4665 struct servent *PerlSock_getservent(void);
8ac85365 4666#endif
a0d0e21e 4667 struct servent *sent;
2d8e6c8d 4668 STRLEN n_a;
a0d0e21e
LW		 4669
4670 if (which == OP_GSBYNAME) {
dc45a647 4671#ifdef HAS_GETSERVBYNAME
2d8e6c8d
GS		 4672 char *proto = POPpx;
4673 char *name = POPpx;
a0d0e21e
LW		 4674
4675 if (proto && !*proto)
4676 proto = Nullch;
4677
6ad3d225 4678 sent = PerlSock_getservbyname(name, proto);
dc45a647 4679#else
cea2e8a9 4680 DIE(aTHX_ PL_no_sock_func, "getservbyname");
dc45a647 4681#endif
a0d0e21e
LW		 4682 }
4683 else if (which == OP_GSBYPORT) {
dc45a647 4684#ifdef HAS_GETSERVBYPORT
2d8e6c8d 4685 char *proto = POPpx;
36477c24 4686 unsigned short port = POPu;
a0d0e21e 4687
36477c24 4688#ifdef HAS_HTONS
6ad3d225 4689 port = PerlSock_htons(port);
36477c24 4690#endif
6ad3d225 4691 sent = PerlSock_getservbyport(port, proto);
dc45a647 4692#else
cea2e8a9 4693 DIE(aTHX_ PL_no_sock_func, "getservbyport");
dc45a647 4694#endif
a0d0e21e
LW		 4695 }
4696 else
e5c9fcd0 4697#ifdef HAS_GETSERVENT
6ad3d225 4698 sent = PerlSock_getservent();
e5c9fcd0 4699#else
cea2e8a9 4700 DIE(aTHX_ PL_no_sock_func, "getservent");
e5c9fcd0 4701#endif
a0d0e21e
LW		 4702
4703 EXTEND(SP, 4);
4704 if (GIMME != G_ARRAY) {
4705 PUSHs(sv = sv_newmortal());
4706 if (sent) {
4707 if (which == OP_GSBYNAME) {
4708#ifdef HAS_NTOHS
6ad3d225 4709 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
a0d0e21e 4710#else
1e422769 4711 sv_setiv(sv, (IV)(sent->s_port));
a0d0e21e
LW		 4712#endif
4713 }
4714 else
4715 sv_setpv(sv, sent->s_name);
4716 }
4717 RETURN;
4718 }
4719
4720 if (sent) {
3280af22 4721 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4722 sv_setpv(sv, sent->s_name);
3280af22 4723 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 4724 for (elem = sent->s_aliases; elem && *elem; elem++) {
a0d0e21e
LW		 4725 sv_catpv(sv, *elem);
4726 if (elem[1])
4727 sv_catpvn(sv, " ", 1);
4728 }
3280af22 4729 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4730#ifdef HAS_NTOHS
76e3520e 4731 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
a0d0e21e 4732#else
1e422769 4733 sv_setiv(sv, (IV)(sent->s_port));
a0d0e21e 4734#endif
3280af22 4735 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 4736 sv_setpv(sv, sent->s_proto);
4737 }
4738
4739 RETURN;
4740#else
cea2e8a9 4741 DIE(aTHX_ PL_no_sock_func, "getservent");
a0d0e21e
LW		 4742#endif
4743}
4744
4745PP(pp_shostent)
4746{
4e35701f 4747 djSP;
693762b4 4748#ifdef HAS_SETHOSTENT
76e3520e 4749 PerlSock_sethostent(TOPi);
a0d0e21e
LW		 4750 RETSETYES;
4751#else
cea2e8a9 4752 DIE(aTHX_ PL_no_sock_func, "sethostent");
a0d0e21e
LW		 4753#endif
4754}
4755
4756PP(pp_snetent)
4757{
4e35701f 4758 djSP;
693762b4 4759#ifdef HAS_SETNETENT
76e3520e 4760 PerlSock_setnetent(TOPi);
a0d0e21e
LW		 4761 RETSETYES;
4762#else
cea2e8a9 4763 DIE(aTHX_ PL_no_sock_func, "setnetent");
a0d0e21e
LW		 4764#endif
4765}
4766
4767PP(pp_sprotoent)
4768{
4e35701f 4769 djSP;
693762b4 4770#ifdef HAS_SETPROTOENT
76e3520e 4771 PerlSock_setprotoent(TOPi);
a0d0e21e
LW		 4772 RETSETYES;
4773#else
cea2e8a9 4774 DIE(aTHX_ PL_no_sock_func, "setprotoent");
a0d0e21e
LW		 4775#endif
4776}
4777
4778PP(pp_sservent)
4779{
4e35701f 4780 djSP;
693762b4 4781#ifdef HAS_SETSERVENT
76e3520e 4782 PerlSock_setservent(TOPi);
a0d0e21e
LW		 4783 RETSETYES;
4784#else
cea2e8a9 4785 DIE(aTHX_ PL_no_sock_func, "setservent");
a0d0e21e
LW		 4786#endif
4787}
4788
4789PP(pp_ehostent)
4790{
4e35701f 4791 djSP;
693762b4 4792#ifdef HAS_ENDHOSTENT
76e3520e 4793 PerlSock_endhostent();
924508f0 4794 EXTEND(SP,1);
a0d0e21e
LW		 4795 RETPUSHYES;
4796#else
cea2e8a9 4797 DIE(aTHX_ PL_no_sock_func, "endhostent");
a0d0e21e
LW		 4798#endif
4799}
4800
4801PP(pp_enetent)
4802{
4e35701f 4803 djSP;
693762b4 4804#ifdef HAS_ENDNETENT
76e3520e 4805 PerlSock_endnetent();
924508f0 4806 EXTEND(SP,1);
a0d0e21e
LW		 4807 RETPUSHYES;
4808#else
cea2e8a9 4809 DIE(aTHX_ PL_no_sock_func, "endnetent");
a0d0e21e
LW		 4810#endif
4811}
4812
4813PP(pp_eprotoent)
4814{
4e35701f 4815 djSP;
693762b4 4816#ifdef HAS_ENDPROTOENT
76e3520e 4817 PerlSock_endprotoent();
924508f0 4818 EXTEND(SP,1);
a0d0e21e
LW		 4819 RETPUSHYES;
4820#else
cea2e8a9 4821 DIE(aTHX_ PL_no_sock_func, "endprotoent");
a0d0e21e
LW		 4822#endif
4823}
4824
4825PP(pp_eservent)
4826{
4e35701f 4827 djSP;
693762b4 4828#ifdef HAS_ENDSERVENT
76e3520e 4829 PerlSock_endservent();
924508f0 4830 EXTEND(SP,1);
a0d0e21e
LW		 4831 RETPUSHYES;
4832#else
cea2e8a9 4833 DIE(aTHX_ PL_no_sock_func, "endservent");
a0d0e21e
LW		 4834#endif
4835}
4836
4837PP(pp_gpwnam)
4838{
4839#ifdef HAS_PASSWD
cea2e8a9 4840 return pp_gpwent();
a0d0e21e 4841#else
cea2e8a9 4842 DIE(aTHX_ PL_no_func, "getpwnam");
a0d0e21e
LW		 4843#endif
4844}
4845
4846PP(pp_gpwuid)
4847{
4848#ifdef HAS_PASSWD
cea2e8a9 4849 return pp_gpwent();
a0d0e21e 4850#else
cea2e8a9 4851 DIE(aTHX_ PL_no_func, "getpwuid");
a0d0e21e
LW		 4852#endif
4853}
4854
4855PP(pp_gpwent)
4856{
4e35701f 4857 djSP;
0994c4d0 4858#ifdef HAS_PASSWD
533c011a 4859 I32 which = PL_op->op_type;
a0d0e21e 4860 register SV *sv;
2d8e6c8d 4861 STRLEN n_a;
e3aefe8d 4862 struct passwd *pwent = NULL;
301e8125 4863 /*
bcf53261
JH		 4864 * We currently support only the SysV getsp* shadow password interface.
4865 * The interface is declared in <shadow.h> and often one needs to link
4866 * with -lsecurity or some such.
4867 * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
4868 * (and SCO?)
4869 *
4870 * AIX getpwnam() is clever enough to return the encrypted password
4871 * only if the caller (euid?) is root.
4872 *
4873 * There are at least two other shadow password APIs. Many platforms
4874 * seem to contain more than one interface for accessing the shadow
4875 * password databases, possibly for compatibility reasons.
3813c136 4876 * The getsp*() is by far he simplest one, the other two interfaces
bcf53261
JH		 4877 * are much more complicated, but also very similar to each other.
4878 *
4879 * <sys/types.h>
4880 * <sys/security.h>
4881 * <prot.h>
4882 * struct pr_passwd *getprpw*();
4883 * The password is in
3813c136
JH		 4884 * char getprpw*(...).ufld.fd_encrypt[]
4885 * Mention HAS_GETPRPWNAM here so that Configure probes for it.
bcf53261
JH		 4886 *
4887 * <sys/types.h>
4888 * <sys/security.h>
4889 * <prot.h>
4890 * struct es_passwd *getespw*();
4891 * The password is in
4892 * char *(getespw*(...).ufld.fd_encrypt)
3813c136 4893 * Mention HAS_GETESPWNAM here so that Configure probes for it.
bcf53261 4894 *
3813c136 4895 * Mention I_PROT here so that Configure probes for it.
bcf53261
JH		 4896 *
4897 * In HP-UX for getprpw*() the manual page claims that one should include
4898 * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
4899 * if one includes <shadow.h> as that includes <hpsecurity.h>,
4900 * and pp_sys.c already includes <shadow.h> if there is such.
3813c136
JH		 4901 *
4902 * Note that <sys/security.h> is already probed for, but currently
4903 * it is only included in special cases.
301e8125 4904 *
bcf53261
JH		 4905 * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
4906 * be preferred interface, even though also the getprpw*() interface
4907 * is available) one needs to link with -lsecurity -ldb -laud -lm.
3813c136
JH		 4908 * One also needs to call set_auth_parameters() in main() before
4909 * doing anything else, whether one is using getespw*() or getprpw*().
4910 *
4911 * Note that accessing the shadow databases can be magnitudes
4912 * slower than accessing the standard databases.
bcf53261
JH		 4913 *
4914 * --jhi
4915 */
a0d0e21e 4916
e3aefe8d
JH		 4917 switch (which) {
4918 case OP_GPWNAM:
4919 pwent = getpwnam(POPpx);
e3aefe8d
JH		 4920 break;
4921 case OP_GPWUID:
4922 pwent = getpwuid((Uid_t)POPi);
4923 break;
4924 case OP_GPWENT:
1883634f 4925# ifdef HAS_GETPWENT
e3aefe8d 4926 pwent = getpwent();
1883634f 4927# else
a45d1c96 4928 DIE(aTHX_ PL_no_func, "getpwent");
1883634f 4929# endif
e3aefe8d
JH		 4930 break;
4931 }
8c0bfa08 4932
a0d0e21e
LW		 4933 EXTEND(SP, 10);
4934 if (GIMME != G_ARRAY) {
4935 PUSHs(sv = sv_newmortal());
4936 if (pwent) {
4937 if (which == OP_GPWNAM)
1883634f 4938# if Uid_t_sign <= 0
1e422769 4939 sv_setiv(sv, (IV)pwent->pw_uid);
1883634f 4940# else
23dcd6c8 4941 sv_setuv(sv, (UV)pwent->pw_uid);
1883634f 4942# endif
a0d0e21e
LW		 4943 else
4944 sv_setpv(sv, pwent->pw_name);
4945 }
4946 RETURN;
4947 }
4948
4949 if (pwent) {
3280af22 4950 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4951 sv_setpv(sv, pwent->pw_name);
6ee623d5 4952
3280af22 4953 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
3813c136
JH		 4954 SvPOK_off(sv);
4955 /* If we have getspnam(), we try to dig up the shadow
4956 * password. If we are underprivileged, the shadow
4957 * interface will set the errno to EACCES or similar,
4958 * and return a null pointer. If this happens, we will
4959 * use the dummy password (usually "*" or "x") from the
4960 * standard password database.
4961 *
4962 * In theory we could skip the shadow call completely
4963 * if euid != 0 but in practice we cannot know which
4964 * security measures are guarding the shadow databases
4965 * on a random platform.
4966 *
4967 * Resist the urge to use additional shadow interfaces.
4968 * Divert the urge to writing an extension instead.
4969 *
4970 * --jhi */
e3aefe8d 4971# ifdef HAS_GETSPNAM
3813c136
JH		 4972 {
4973 struct spwd *spwent;
4974 int saverrno; /* Save and restore errno so that
4975 * underprivileged attempts seem
4976 * to have never made the unsccessful
4977 * attempt to retrieve the shadow password. */
4978
4979 saverrno = errno;
4980 spwent = getspnam(pwent->pw_name);
4981 errno = saverrno;
4982 if (spwent && spwent->sp_pwdp)
4983 sv_setpv(sv, spwent->sp_pwdp);
4984 }
f1066039 4985# endif
e020c87d 4986# ifdef PWPASSWD
3813c136
JH		 4987 if (!SvPOK(sv)) /* Use the standard password, then. */
4988 sv_setpv(sv, pwent->pw_passwd);
e020c87d 4989# endif
3813c136 4990
1883634f 4991# ifndef INCOMPLETE_TAINTS
3813c136
JH		 4992 /* passwd is tainted because user himself can diddle with it.
4993 * admittedly not much and in a very limited way, but nevertheless. */
2959b6e3 4994 SvTAINTED_on(sv);
1883634f 4995# endif
6ee623d5 4996
3280af22 4997 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1883634f 4998# if Uid_t_sign <= 0
1e422769 4999 sv_setiv(sv, (IV)pwent->pw_uid);
1883634f 5000# else
23dcd6c8 5001 sv_setuv(sv, (UV)pwent->pw_uid);
1883634f 5002# endif
6ee623d5 5003
3280af22 5004 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1883634f 5005# if Uid_t_sign <= 0
1e422769 5006 sv_setiv(sv, (IV)pwent->pw_gid);
1883634f 5007# else
23dcd6c8 5008 sv_setuv(sv, (UV)pwent->pw_gid);
1883634f 5009# endif
3813c136
JH		 5010 /* pw_change, pw_quota, and pw_age are mutually exclusive--
5011 * because of the poor interface of the Perl getpw*(),
5012 * not because there's some standard/convention saying so.
5013 * A better interface would have been to return a hash,
5014 * but we are accursed by our history, alas. --jhi. */
3280af22 5015 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1883634f 5016# ifdef PWCHANGE
1e422769 5017 sv_setiv(sv, (IV)pwent->pw_change);
6ee623d5 5018# else
1883634f
JH		 5019# ifdef PWQUOTA
5020 sv_setiv(sv, (IV)pwent->pw_quota);
5021# else
a1757be1 5022# ifdef PWAGE
a0d0e21e 5023 sv_setpv(sv, pwent->pw_age);
a1757be1 5024# endif
6ee623d5
GS		 5025# endif
5026# endif
6ee623d5 5027
3813c136
JH		 5028 /* pw_class and pw_comment are mutually exclusive--.
5029 * see the above note for pw_change, pw_quota, and pw_age. */
3280af22 5030 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1883634f 5031# ifdef PWCLASS
a0d0e21e 5032 sv_setpv(sv, pwent->pw_class);
1883634f
JH		 5033# else
5034# ifdef PWCOMMENT
a0d0e21e 5035 sv_setpv(sv, pwent->pw_comment);
1883634f 5036# endif
6ee623d5 5037# endif
6ee623d5 5038
3280af22 5039 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1883634f 5040# ifdef PWGECOS
a0d0e21e 5041 sv_setpv(sv, pwent->pw_gecos);
1883634f
JH		 5042# endif
5043# ifndef INCOMPLETE_TAINTS
d2719217 5044 /* pw_gecos is tainted because user himself can diddle with it. */
fb73857a 5045 SvTAINTED_on(sv);
1883634f 5046# endif
6ee623d5 5047
3280af22 5048 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 5049 sv_setpv(sv, pwent->pw_dir);
6ee623d5 5050
3280af22 5051 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 5052 sv_setpv(sv, pwent->pw_shell);
1883634f 5053# ifndef INCOMPLETE_TAINTS
4602f195
JH		 5054 /* pw_shell is tainted because user himself can diddle with it. */
5055 SvTAINTED_on(sv);
1883634f 5056# endif
6ee623d5 5057
1883634f 5058# ifdef PWEXPIRE
6b88bc9c 5059 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 5060 sv_setiv(sv, (IV)pwent->pw_expire);
1883634f 5061# endif
a0d0e21e
LW		 5062 }
5063 RETURN;
5064#else
cea2e8a9 5065 DIE(aTHX_ PL_no_func, "getpwent");
a0d0e21e
LW		 5066#endif
5067}
5068
5069PP(pp_spwent)
5070{
4e35701f 5071 djSP;
d493b042 5072#if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
a0d0e21e
LW		 5073 setpwent();
5074 RETPUSHYES;
5075#else
cea2e8a9 5076 DIE(aTHX_ PL_no_func, "setpwent");
a0d0e21e
LW		 5077#endif
5078}
5079
5080PP(pp_epwent)
5081{
4e35701f 5082 djSP;
28e8609d 5083#if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
a0d0e21e
LW		 5084 endpwent();
5085 RETPUSHYES;
5086#else
cea2e8a9 5087 DIE(aTHX_ PL_no_func, "endpwent");
a0d0e21e
LW		 5088#endif
5089}
5090
5091PP(pp_ggrnam)
5092{
5093#ifdef HAS_GROUP
cea2e8a9 5094 return pp_ggrent();
a0d0e21e 5095#else
cea2e8a9 5096 DIE(aTHX_ PL_no_func, "getgrnam");
a0d0e21e
LW		 5097#endif
5098}
5099
5100PP(pp_ggrgid)
5101{
5102#ifdef HAS_GROUP
cea2e8a9 5103 return pp_ggrent();
a0d0e21e 5104#else
cea2e8a9 5105 DIE(aTHX_ PL_no_func, "getgrgid");
a0d0e21e
LW		 5106#endif
5107}
5108
5109PP(pp_ggrent)
5110{
4e35701f 5111 djSP;
0994c4d0 5112#ifdef HAS_GROUP
533c011a 5113 I32 which = PL_op->op_type;
a0d0e21e
LW		 5114 register char **elem;
5115 register SV *sv;
5116 struct group *grent;
2d8e6c8d 5117 STRLEN n_a;
a0d0e21e
LW		 5118
5119 if (which == OP_GGRNAM)
2d8e6c8d 5120 grent = (struct group *)getgrnam(POPpx);
a0d0e21e
LW		 5121 else if (which == OP_GGRGID)
5122 grent = (struct group *)getgrgid(POPi);
5123 else
0994c4d0 5124#ifdef HAS_GETGRENT
a0d0e21e 5125 grent = (struct group *)getgrent();
0994c4d0
JH		 5126#else
5127 DIE(aTHX_ PL_no_func, "getgrent");
5128#endif
a0d0e21e
LW		 5129
5130 EXTEND(SP, 4);
5131 if (GIMME != G_ARRAY) {
5132 PUSHs(sv = sv_newmortal());
5133 if (grent) {
5134 if (which == OP_GGRNAM)
1e422769 5135 sv_setiv(sv, (IV)grent->gr_gid);
a0d0e21e
LW		 5136 else
5137 sv_setpv(sv, grent->gr_name);
5138 }
5139 RETURN;
5140 }
5141
5142 if (grent) {
3280af22 5143 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 5144 sv_setpv(sv, grent->gr_name);
28e8609d 5145
3280af22 5146 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
28e8609d 5147#ifdef GRPASSWD
a0d0e21e 5148 sv_setpv(sv, grent->gr_passwd);
28e8609d
JH		 5149#endif
5150
3280af22 5151 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 5152 sv_setiv(sv, (IV)grent->gr_gid);
28e8609d 5153
3280af22 5154 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 5155 for (elem = grent->gr_mem; elem && *elem; elem++) {
a0d0e21e
LW		 5156 sv_catpv(sv, *elem);
5157 if (elem[1])
5158 sv_catpvn(sv, " ", 1);
5159 }
5160 }
5161
5162 RETURN;
5163#else
cea2e8a9 5164 DIE(aTHX_ PL_no_func, "getgrent");
a0d0e21e
LW		 5165#endif
5166}
5167
5168PP(pp_sgrent)
5169{
4e35701f 5170 djSP;
28e8609d 5171#if defined(HAS_GROUP) && defined(HAS_SETGRENT)
a0d0e21e
LW		 5172 setgrent();
5173 RETPUSHYES;
5174#else
cea2e8a9 5175 DIE(aTHX_ PL_no_func, "setgrent");
a0d0e21e
LW		 5176#endif
5177}
5178
5179PP(pp_egrent)
5180{
4e35701f 5181 djSP;
28e8609d 5182#if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
a0d0e21e
LW		 5183 endgrent();
5184 RETPUSHYES;
5185#else
cea2e8a9 5186 DIE(aTHX_ PL_no_func, "endgrent");
a0d0e21e
LW		 5187#endif
5188}
5189
5190PP(pp_getlogin)
5191{
4e35701f 5192 djSP; dTARGET;
a0d0e21e
LW		 5193#ifdef HAS_GETLOGIN
5194 char *tmps;
5195 EXTEND(SP, 1);
76e3520e 5196 if (!(tmps = PerlProc_getlogin()))
a0d0e21e
LW		 5197 RETPUSHUNDEF;
5198 PUSHp(tmps, strlen(tmps));
5199 RETURN;
5200#else
cea2e8a9 5201 DIE(aTHX_ PL_no_func, "getlogin");
a0d0e21e
LW		 5202#endif
5203}
5204
5205/* Miscellaneous. */
5206
5207PP(pp_syscall)
5208{
d2719217 5209#ifdef HAS_SYSCALL
4e35701f 5210 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW		 5211 register I32 items = SP - MARK;
5212 unsigned long a[20];
5213 register I32 i = 0;
5214 I32 retval = -1;
2d8e6c8d 5215 STRLEN n_a;
a0d0e21e 5216
3280af22 5217 if (PL_tainting) {
a0d0e21e 5218 while (++MARK <= SP) {
bbce6d69 5219 if (SvTAINTED(*MARK)) {
5220 TAINT;
5221 break;
5222 }
a0d0e21e
LW		 5223 }
5224 MARK = ORIGMARK;
5225 TAINT_PROPER("syscall");
5226 }
5227
5228 /* This probably won't work on machines where sizeof(long) != sizeof(int)
5229 * or where sizeof(long) != sizeof(char*). But such machines will
5230 * not likely have syscall implemented either, so who cares?
5231 */
5232 while (++MARK <= SP) {
5233 if (SvNIOK(*MARK) || !i)
5234 a[i++] = SvIV(*MARK);
3280af22 5235 else if (*MARK == &PL_sv_undef)
748a9306 5236 a[i++] = 0;
301e8125 5237 else
2d8e6c8d 5238 a[i++] = (unsigned long)SvPV_force(*MARK, n_a);
a0d0e21e
LW		 5239 if (i > 15)
5240 break;
5241 }
5242 switch (items) {
5243 default:
cea2e8a9 5244 DIE(aTHX_ "Too many args to syscall");
a0d0e21e 5245 case 0:
cea2e8a9 5246 DIE(aTHX_ "Too few args to syscall");
a0d0e21e
LW		 5247 case 1:
5248 retval = syscall(a[0]);
5249 break;
5250 case 2:
5251 retval = syscall(a[0],a[1]);
5252 break;
5253 case 3:
5254 retval = syscall(a[0],a[1],a[2]);
5255 break;
5256 case 4:
5257 retval = syscall(a[0],a[1],a[2],a[3]);
5258 break;
5259 case 5:
5260 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5261 break;
5262 case 6:
5263 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5264 break;
5265 case 7:
5266 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5267 break;
5268 case 8:
5269 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5270 break;
5271#ifdef atarist
5272 case 9:
5273 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5274 break;
5275 case 10:
5276 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
5277 break;
5278 case 11:
5279 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5280 a[10]);
5281 break;
5282 case 12:
5283 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5284 a[10],a[11]);
5285 break;
5286 case 13:
5287 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5288 a[10],a[11],a[12]);
5289 break;
5290 case 14:
5291 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5292 a[10],a[11],a[12],a[13]);
5293 break;
5294#endif /* atarist */
5295 }
5296 SP = ORIGMARK;
5297 PUSHi(retval);
5298 RETURN;
5299#else
cea2e8a9 5300 DIE(aTHX_ PL_no_func, "syscall");
a0d0e21e
LW		 5301#endif
5302}
5303
ff68c719 5304#ifdef FCNTL_EMULATE_FLOCK
301e8125 5305
ff68c719 5306/* XXX Emulate flock() with fcntl().
5307 What's really needed is a good file locking module.
5308*/
5309
cea2e8a9
GS		 5310static int
5311fcntl_emulate_flock(int fd, int operation)
ff68c719 5312{
5313 struct flock flock;
301e8125 5314
ff68c719 5315 switch (operation & ~LOCK_NB) {
5316 case LOCK_SH:
5317 flock.l_type = F_RDLCK;
5318 break;
5319 case LOCK_EX:
5320 flock.l_type = F_WRLCK;
5321 break;
5322 case LOCK_UN:
5323 flock.l_type = F_UNLCK;
5324 break;
5325 default:
5326 errno = EINVAL;
5327 return -1;
5328 }
5329 flock.l_whence = SEEK_SET;
d9b3e12d 5330 flock.l_start = flock.l_len = (Off_t)0;
301e8125 5331
ff68c719 5332 return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5333}
5334
5335#endif /* FCNTL_EMULATE_FLOCK */
5336
5337#ifdef LOCKF_EMULATE_FLOCK
16d20bd9
AD		 5338
5339/* XXX Emulate flock() with lockf(). This is just to increase
5340 portability of scripts. The calls are not completely
5341 interchangeable. What's really needed is a good file
5342 locking module.
5343*/
5344
76c32331 5345/* The lockf() constants might have been defined in <unistd.h>.
5346 Unfortunately, <unistd.h> causes troubles on some mixed
5347 (BSD/POSIX) systems, such as SunOS 4.1.3.
16d20bd9
AD		 5348
5349 Further, the lockf() constants aren't POSIX, so they might not be
5350 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
5351 just stick in the SVID values and be done with it. Sigh.
5352*/
5353
5354# ifndef F_ULOCK
5355# define F_ULOCK 0 /* Unlock a previously locked region */
5356# endif
5357# ifndef F_LOCK
5358# define F_LOCK 1 /* Lock a region for exclusive use */
5359# endif
5360# ifndef F_TLOCK
5361# define F_TLOCK 2 /* Test and lock a region for exclusive use */
5362# endif
5363# ifndef F_TEST
5364# define F_TEST 3 /* Test a region for other processes locks */
5365# endif
5366
cea2e8a9
GS		 5367static int
5368lockf_emulate_flock(int fd, int operation)
16d20bd9
AD		 5369{
5370 int i;
84902520
TB		 5371 int save_errno;
5372 Off_t pos;
5373
5374 /* flock locks entire file so for lockf we need to do the same */
5375 save_errno = errno;
6ad3d225 5376 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
84902520 5377 if (pos > 0) /* is seekable and needs to be repositioned */
6ad3d225 5378 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
08b714dd 5379 pos = -1; /* seek failed, so don't seek back afterwards */
84902520
TB		 5380 errno = save_errno;
5381
16d20bd9
AD		 5382 switch (operation) {
5383
5384 /* LOCK_SH - get a shared lock */
5385 case LOCK_SH:
5386 /* LOCK_EX - get an exclusive lock */
5387 case LOCK_EX:
5388 i = lockf (fd, F_LOCK, 0);
5389 break;
5390
5391 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5392 case LOCK_SH|LOCK_NB:
5393 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5394 case LOCK_EX|LOCK_NB:
5395 i = lockf (fd, F_TLOCK, 0);
5396 if (i == -1)
5397 if ((errno == EAGAIN) || (errno == EACCES))
5398 errno = EWOULDBLOCK;
5399 break;
5400
ff68c719 5401 /* LOCK_UN - unlock (non-blocking is a no-op) */
16d20bd9 5402 case LOCK_UN:
ff68c719 5403 case LOCK_UN|LOCK_NB:
16d20bd9
AD		 5404 i = lockf (fd, F_ULOCK, 0);
5405 break;
5406
5407 /* Default - can't decipher operation */
5408 default:
5409 i = -1;
5410 errno = EINVAL;
5411 break;
5412 }
84902520
TB		 5413
5414 if (pos > 0) /* need to restore position of the handle */
6ad3d225 5415 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
84902520 5416
16d20bd9
AD		 5417 return (i);
5418}
ff68c719 5419
5420#endif /* LOCKF_EMULATE_FLOCK */
Unnamed repository; edit this file 'description' to name the repository.