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