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
some additions for makefiles for win32 (for perl@7674)
[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
9d9004a9 153# if defined(HAS_FCNTL) && defined(FCNTL_CAN_LOCK)
ff68c719 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;
8a4e5b40
DD		 2560 if (PL_op->op_type == OP_LSTAT) {
2561 if (PL_laststype != OP_LSTAT)
2562 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2563 if (ckWARN(WARN_IO) && gv != PL_defgv)
2564 Perl_warner(aTHX_ WARN_IO,
2dd78f96 2565 "lstat() on filehandle %s", GvENAME(gv));
8a4e5b40
DD		 2566 /* Perl_my_lstat (-l) croak's on filehandle, why warn here? */
2567 }
2568
748a9306 2569 do_fstat:
2dd78f96 2570 if (gv != PL_defgv) {
3280af22 2571 PL_laststype = OP_STAT;
2dd78f96 2572 PL_statgv = gv;
3280af22 2573 sv_setpv(PL_statname, "");
2dd78f96
JH		 2574 PL_laststatval = (GvIO(gv) && IoIFP(GvIOp(gv))
2575 ? PerlLIO_fstat(PerlIO_fileno(IoIFP(GvIOn(gv))), &PL_statcache) : -1);
a0d0e21e 2576 }
9ddeeac9 2577 if (PL_laststatval < 0) {
2dd78f96
JH		 2578 dTHR;
2579 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2580 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
a0d0e21e 2581 max = 0;
9ddeeac9 2582 }
a0d0e21e
LW		 2583 }
2584 else {
748a9306
LW		 2585 SV* sv = POPs;
2586 if (SvTYPE(sv) == SVt_PVGV) {
2dd78f96 2587 gv = (GV*)sv;
748a9306
LW		 2588 goto do_fstat;
2589 }
2590 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2dd78f96 2591 gv = (GV*)SvRV(sv);
748a9306
LW		 2592 goto do_fstat;
2593 }
2d8e6c8d 2594 sv_setpv(PL_statname, SvPV(sv,n_a));
3280af22 2595 PL_statgv = Nullgv;
a0d0e21e 2596#ifdef HAS_LSTAT
533c011a
NIS		 2597 PL_laststype = PL_op->op_type;
2598 if (PL_op->op_type == OP_LSTAT)
2d8e6c8d 2599 PL_laststatval = PerlLIO_lstat(SvPV(PL_statname, n_a), &PL_statcache);
a0d0e21e
LW		 2600 else
2601#endif
2d8e6c8d 2602 PL_laststatval = PerlLIO_stat(SvPV(PL_statname, n_a), &PL_statcache);
3280af22 2603 if (PL_laststatval < 0) {
2d8e6c8d 2604 if (ckWARN(WARN_NEWLINE) && strchr(SvPV(PL_statname, n_a), '\n'))
cea2e8a9 2605 Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "stat");
a0d0e21e
LW		 2606 max = 0;
2607 }
2608 }
2609
54310121 2610 gimme = GIMME_V;
2611 if (gimme != G_ARRAY) {
2612 if (gimme != G_VOID)
2613 XPUSHs(boolSV(max));
2614 RETURN;
a0d0e21e
LW		 2615 }
2616 if (max) {
36477c24 2617 EXTEND(SP, max);
2618 EXTEND_MORTAL(max);
1ff81528
PL		 2619 PUSHs(sv_2mortal(newSViv(PL_statcache.st_dev)));
2620 PUSHs(sv_2mortal(newSViv(PL_statcache.st_ino)));
b448e4fe
JH		 2621 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_mode)));
2622 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_nlink)));
146174a9
CB		 2623#if Uid_t_size > IVSIZE
2624 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_uid)));
2625#else
23dcd6c8 2626# if Uid_t_sign <= 0
1ff81528 2627 PUSHs(sv_2mortal(newSViv(PL_statcache.st_uid)));
23dcd6c8
JH		 2628# else
2629 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_uid)));
2630# endif
146174a9 2631#endif
301e8125 2632#if Gid_t_size > IVSIZE
146174a9
CB		 2633 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_gid)));
2634#else
23dcd6c8 2635# if Gid_t_sign <= 0
1ff81528 2636 PUSHs(sv_2mortal(newSViv(PL_statcache.st_gid)));
23dcd6c8
JH		 2637# else
2638 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_gid)));
2639# endif
146174a9 2640#endif
cbdc8872 2641#ifdef USE_STAT_RDEV
1ff81528 2642 PUSHs(sv_2mortal(newSViv(PL_statcache.st_rdev)));
cbdc8872 2643#else
79cb57f6 2644 PUSHs(sv_2mortal(newSVpvn("", 0)));
cbdc8872 2645#endif
146174a9
CB		 2646#if Off_t_size > IVSIZE
2647 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_size)));
2648#else
1ff81528 2649 PUSHs(sv_2mortal(newSViv(PL_statcache.st_size)));
146174a9 2650#endif
cbdc8872 2651#ifdef BIG_TIME
172ae379
JH		 2652 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_atime)));
2653 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_mtime)));
2654 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_ctime)));
cbdc8872 2655#else
1ff81528
PL		 2656 PUSHs(sv_2mortal(newSViv(PL_statcache.st_atime)));
2657 PUSHs(sv_2mortal(newSViv(PL_statcache.st_mtime)));
2658 PUSHs(sv_2mortal(newSViv(PL_statcache.st_ctime)));
cbdc8872 2659#endif
a0d0e21e 2660#ifdef USE_STAT_BLOCKS
b448e4fe
JH		 2661 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blksize)));
2662 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blocks)));
a0d0e21e 2663#else
79cb57f6
GS		 2664 PUSHs(sv_2mortal(newSVpvn("", 0)));
2665 PUSHs(sv_2mortal(newSVpvn("", 0)));
a0d0e21e
LW		 2666#endif
2667 }
2668 RETURN;
2669}
2670
2671PP(pp_ftrread)
2672{
5ff3f7a4 2673 I32 result;
4e35701f 2674 djSP;
5ff3f7a4 2675#if defined(HAS_ACCESS) && defined(R_OK)
2d8e6c8d 2676 STRLEN n_a;
5ff3f7a4 2677 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2678 result = access(TOPpx, R_OK);
5ff3f7a4
GS		 2679 if (result == 0)
2680 RETPUSHYES;
2681 if (result < 0)
2682 RETPUSHUNDEF;
2683 RETPUSHNO;
22865c03
GS		 2684 }
2685 else
cea2e8a9 2686 result = my_stat();
5ff3f7a4 2687#else
cea2e8a9 2688 result = my_stat();
5ff3f7a4 2689#endif
22865c03 2690 SPAGAIN;
a0d0e21e
LW		 2691 if (result < 0)
2692 RETPUSHUNDEF;
3280af22 2693 if (cando(S_IRUSR, 0, &PL_statcache))
a0d0e21e
LW		 2694 RETPUSHYES;
2695 RETPUSHNO;
2696}
2697
2698PP(pp_ftrwrite)
2699{
5ff3f7a4 2700 I32 result;
4e35701f 2701 djSP;
5ff3f7a4 2702#if defined(HAS_ACCESS) && defined(W_OK)
2d8e6c8d 2703 STRLEN n_a;
5ff3f7a4 2704 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2705 result = access(TOPpx, W_OK);
5ff3f7a4
GS		 2706 if (result == 0)
2707 RETPUSHYES;
2708 if (result < 0)
2709 RETPUSHUNDEF;
2710 RETPUSHNO;
22865c03
GS		 2711 }
2712 else
cea2e8a9 2713 result = my_stat();
5ff3f7a4 2714#else
cea2e8a9 2715 result = my_stat();
5ff3f7a4 2716#endif
22865c03 2717 SPAGAIN;
a0d0e21e
LW		 2718 if (result < 0)
2719 RETPUSHUNDEF;
3280af22 2720 if (cando(S_IWUSR, 0, &PL_statcache))
a0d0e21e
LW		 2721 RETPUSHYES;
2722 RETPUSHNO;
2723}
2724
2725PP(pp_ftrexec)
2726{
5ff3f7a4 2727 I32 result;
4e35701f 2728 djSP;
5ff3f7a4 2729#if defined(HAS_ACCESS) && defined(X_OK)
2d8e6c8d 2730 STRLEN n_a;
5ff3f7a4 2731 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2732 result = access(TOPpx, X_OK);
5ff3f7a4
GS		 2733 if (result == 0)
2734 RETPUSHYES;
2735 if (result < 0)
2736 RETPUSHUNDEF;
2737 RETPUSHNO;
22865c03
GS		 2738 }
2739 else
cea2e8a9 2740 result = my_stat();
5ff3f7a4 2741#else
cea2e8a9 2742 result = my_stat();
5ff3f7a4 2743#endif
22865c03 2744 SPAGAIN;
a0d0e21e
LW		 2745 if (result < 0)
2746 RETPUSHUNDEF;
3280af22 2747 if (cando(S_IXUSR, 0, &PL_statcache))
a0d0e21e
LW		 2748 RETPUSHYES;
2749 RETPUSHNO;
2750}
2751
2752PP(pp_fteread)
2753{
5ff3f7a4 2754 I32 result;
4e35701f 2755 djSP;
5ff3f7a4 2756#ifdef PERL_EFF_ACCESS_R_OK
2d8e6c8d 2757 STRLEN n_a;
5ff3f7a4 2758 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2759 result = PERL_EFF_ACCESS_R_OK(TOPpx);
5ff3f7a4
GS		 2760 if (result == 0)
2761 RETPUSHYES;
2762 if (result < 0)
2763 RETPUSHUNDEF;
2764 RETPUSHNO;
22865c03
GS		 2765 }
2766 else
cea2e8a9 2767 result = my_stat();
5ff3f7a4 2768#else
cea2e8a9 2769 result = my_stat();
5ff3f7a4 2770#endif
22865c03 2771 SPAGAIN;
a0d0e21e
LW		 2772 if (result < 0)
2773 RETPUSHUNDEF;
3280af22 2774 if (cando(S_IRUSR, 1, &PL_statcache))
a0d0e21e
LW		 2775 RETPUSHYES;
2776 RETPUSHNO;
2777}
2778
2779PP(pp_ftewrite)
2780{
5ff3f7a4 2781 I32 result;
4e35701f 2782 djSP;
5ff3f7a4 2783#ifdef PERL_EFF_ACCESS_W_OK
2d8e6c8d 2784 STRLEN n_a;
5ff3f7a4 2785 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2786 result = PERL_EFF_ACCESS_W_OK(TOPpx);
5ff3f7a4
GS		 2787 if (result == 0)
2788 RETPUSHYES;
2789 if (result < 0)
2790 RETPUSHUNDEF;
2791 RETPUSHNO;
22865c03
GS		 2792 }
2793 else
cea2e8a9 2794 result = my_stat();
5ff3f7a4 2795#else
cea2e8a9 2796 result = my_stat();
5ff3f7a4 2797#endif
22865c03 2798 SPAGAIN;
a0d0e21e
LW		 2799 if (result < 0)
2800 RETPUSHUNDEF;
3280af22 2801 if (cando(S_IWUSR, 1, &PL_statcache))
a0d0e21e
LW		 2802 RETPUSHYES;
2803 RETPUSHNO;
2804}
2805
2806PP(pp_fteexec)
2807{
5ff3f7a4 2808 I32 result;
4e35701f 2809 djSP;
5ff3f7a4 2810#ifdef PERL_EFF_ACCESS_X_OK
2d8e6c8d 2811 STRLEN n_a;
5ff3f7a4 2812 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2813 result = PERL_EFF_ACCESS_X_OK(TOPpx);
5ff3f7a4
GS		 2814 if (result == 0)
2815 RETPUSHYES;
2816 if (result < 0)
2817 RETPUSHUNDEF;
2818 RETPUSHNO;
22865c03
GS		 2819 }
2820 else
cea2e8a9 2821 result = my_stat();
5ff3f7a4 2822#else
cea2e8a9 2823 result = my_stat();
5ff3f7a4 2824#endif
22865c03 2825 SPAGAIN;
a0d0e21e
LW		 2826 if (result < 0)
2827 RETPUSHUNDEF;
3280af22 2828 if (cando(S_IXUSR, 1, &PL_statcache))
a0d0e21e
LW		 2829 RETPUSHYES;
2830 RETPUSHNO;
2831}
2832
2833PP(pp_ftis)
2834{
cea2e8a9 2835 I32 result = my_stat();
4e35701f 2836 djSP;
a0d0e21e
LW		 2837 if (result < 0)
2838 RETPUSHUNDEF;
2839 RETPUSHYES;
2840}
2841
2842PP(pp_fteowned)
2843{
cea2e8a9 2844 return pp_ftrowned();
a0d0e21e
LW		 2845}
2846
2847PP(pp_ftrowned)
2848{
cea2e8a9 2849 I32 result = my_stat();
4e35701f 2850 djSP;
a0d0e21e
LW		 2851 if (result < 0)
2852 RETPUSHUNDEF;
146174a9
CB		 2853 if (PL_statcache.st_uid == (PL_op->op_type == OP_FTEOWNED ?
2854 PL_euid : PL_uid) )
a0d0e21e
LW		 2855 RETPUSHYES;
2856 RETPUSHNO;
2857}
2858
2859PP(pp_ftzero)
2860{
cea2e8a9 2861 I32 result = my_stat();
4e35701f 2862 djSP;
a0d0e21e
LW		 2863 if (result < 0)
2864 RETPUSHUNDEF;
146174a9 2865 if (PL_statcache.st_size == 0)
a0d0e21e
LW		 2866 RETPUSHYES;
2867 RETPUSHNO;
2868}
2869
2870PP(pp_ftsize)
2871{
cea2e8a9 2872 I32 result = my_stat();
4e35701f 2873 djSP; dTARGET;
a0d0e21e
LW		 2874 if (result < 0)
2875 RETPUSHUNDEF;
146174a9
CB		 2876#if Off_t_size > IVSIZE
2877 PUSHn(PL_statcache.st_size);
2878#else
3280af22 2879 PUSHi(PL_statcache.st_size);
146174a9 2880#endif
a0d0e21e
LW		 2881 RETURN;
2882}
2883
2884PP(pp_ftmtime)
2885{
cea2e8a9 2886 I32 result = my_stat();
4e35701f 2887 djSP; dTARGET;
a0d0e21e
LW		 2888 if (result < 0)
2889 RETPUSHUNDEF;
c6419e06 2890 PUSHn( (PL_basetime - PL_statcache.st_mtime) / 86400.0 );
a0d0e21e
LW		 2891 RETURN;
2892}
2893
2894PP(pp_ftatime)
2895{
cea2e8a9 2896 I32 result = my_stat();
4e35701f 2897 djSP; dTARGET;
a0d0e21e
LW		 2898 if (result < 0)
2899 RETPUSHUNDEF;
c6419e06 2900 PUSHn( (PL_basetime - PL_statcache.st_atime) / 86400.0 );
a0d0e21e
LW		 2901 RETURN;
2902}
2903
2904PP(pp_ftctime)
2905{
cea2e8a9 2906 I32 result = my_stat();
4e35701f 2907 djSP; dTARGET;
a0d0e21e
LW		 2908 if (result < 0)
2909 RETPUSHUNDEF;
c6419e06 2910 PUSHn( (PL_basetime - PL_statcache.st_ctime) / 86400.0 );
a0d0e21e
LW		 2911 RETURN;
2912}
2913
2914PP(pp_ftsock)
2915{
cea2e8a9 2916 I32 result = my_stat();
4e35701f 2917 djSP;
a0d0e21e
LW		 2918 if (result < 0)
2919 RETPUSHUNDEF;
3280af22 2920 if (S_ISSOCK(PL_statcache.st_mode))
a0d0e21e
LW		 2921 RETPUSHYES;
2922 RETPUSHNO;
2923}
2924
2925PP(pp_ftchr)
2926{
cea2e8a9 2927 I32 result = my_stat();
4e35701f 2928 djSP;
a0d0e21e
LW		 2929 if (result < 0)
2930 RETPUSHUNDEF;
3280af22 2931 if (S_ISCHR(PL_statcache.st_mode))
a0d0e21e
LW		 2932 RETPUSHYES;
2933 RETPUSHNO;
2934}
2935
2936PP(pp_ftblk)
2937{
cea2e8a9 2938 I32 result = my_stat();
4e35701f 2939 djSP;
a0d0e21e
LW		 2940 if (result < 0)
2941 RETPUSHUNDEF;
3280af22 2942 if (S_ISBLK(PL_statcache.st_mode))
a0d0e21e
LW		 2943 RETPUSHYES;
2944 RETPUSHNO;
2945}
2946
2947PP(pp_ftfile)
2948{
cea2e8a9 2949 I32 result = my_stat();
4e35701f 2950 djSP;
a0d0e21e
LW		 2951 if (result < 0)
2952 RETPUSHUNDEF;
3280af22 2953 if (S_ISREG(PL_statcache.st_mode))
a0d0e21e
LW		 2954 RETPUSHYES;
2955 RETPUSHNO;
2956}
2957
2958PP(pp_ftdir)
2959{
cea2e8a9 2960 I32 result = my_stat();
4e35701f 2961 djSP;
a0d0e21e
LW		 2962 if (result < 0)
2963 RETPUSHUNDEF;
3280af22 2964 if (S_ISDIR(PL_statcache.st_mode))
a0d0e21e
LW		 2965 RETPUSHYES;
2966 RETPUSHNO;
2967}
2968
2969PP(pp_ftpipe)
2970{
cea2e8a9 2971 I32 result = my_stat();
4e35701f 2972 djSP;
a0d0e21e
LW		 2973 if (result < 0)
2974 RETPUSHUNDEF;
3280af22 2975 if (S_ISFIFO(PL_statcache.st_mode))
a0d0e21e
LW		 2976 RETPUSHYES;
2977 RETPUSHNO;
2978}
2979
2980PP(pp_ftlink)
2981{
cea2e8a9 2982 I32 result = my_lstat();
4e35701f 2983 djSP;
a0d0e21e
LW		 2984 if (result < 0)
2985 RETPUSHUNDEF;
3280af22 2986 if (S_ISLNK(PL_statcache.st_mode))
a0d0e21e
LW		 2987 RETPUSHYES;
2988 RETPUSHNO;
2989}
2990
2991PP(pp_ftsuid)
2992{
4e35701f 2993 djSP;
a0d0e21e 2994#ifdef S_ISUID
cea2e8a9 2995 I32 result = my_stat();
a0d0e21e
LW		 2996 SPAGAIN;
2997 if (result < 0)
2998 RETPUSHUNDEF;
3280af22 2999 if (PL_statcache.st_mode & S_ISUID)
a0d0e21e
LW		 3000 RETPUSHYES;
3001#endif
3002 RETPUSHNO;
3003}
3004
3005PP(pp_ftsgid)
3006{
4e35701f 3007 djSP;
a0d0e21e 3008#ifdef S_ISGID
cea2e8a9 3009 I32 result = my_stat();
a0d0e21e
LW		 3010 SPAGAIN;
3011 if (result < 0)
3012 RETPUSHUNDEF;
3280af22 3013 if (PL_statcache.st_mode & S_ISGID)
a0d0e21e
LW		 3014 RETPUSHYES;
3015#endif
3016 RETPUSHNO;
3017}
3018
3019PP(pp_ftsvtx)
3020{
4e35701f 3021 djSP;
a0d0e21e 3022#ifdef S_ISVTX
cea2e8a9 3023 I32 result = my_stat();
a0d0e21e
LW		 3024 SPAGAIN;
3025 if (result < 0)
3026 RETPUSHUNDEF;
3280af22 3027 if (PL_statcache.st_mode & S_ISVTX)
a0d0e21e
LW		 3028 RETPUSHYES;
3029#endif
3030 RETPUSHNO;
3031}
3032
3033PP(pp_fttty)
3034{
4e35701f 3035 djSP;
a0d0e21e
LW		 3036 int fd;
3037 GV *gv;
fb73857a 3038 char *tmps = Nullch;
2d8e6c8d 3039 STRLEN n_a;
fb73857a 3040
533c011a 3041 if (PL_op->op_flags & OPf_REF)
146174a9 3042 gv = cGVOP_gv;
fb73857a 3043 else if (isGV(TOPs))
3044 gv = (GV*)POPs;
3045 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3046 gv = (GV*)SvRV(POPs);
a0d0e21e 3047 else
2d8e6c8d 3048 gv = gv_fetchpv(tmps = POPpx, FALSE, SVt_PVIO);
fb73857a 3049
a0d0e21e 3050 if (GvIO(gv) && IoIFP(GvIOp(gv)))
760ac839 3051 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
fb73857a 3052 else if (tmps && isDIGIT(*tmps))
a0d0e21e
LW		 3053 fd = atoi(tmps);
3054 else
3055 RETPUSHUNDEF;
6ad3d225 3056 if (PerlLIO_isatty(fd))
a0d0e21e
LW		 3057 RETPUSHYES;
3058 RETPUSHNO;
3059}
3060
16d20bd9
AD		 3061#if defined(atarist) /* this will work with atariST. Configure will
3062 make guesses for other systems. */
3063# define FILE_base(f) ((f)->_base)
3064# define FILE_ptr(f) ((f)->_ptr)
3065# define FILE_cnt(f) ((f)->_cnt)
3066# define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
a0d0e21e
LW		 3067#endif
3068
3069PP(pp_fttext)
3070{
4e35701f 3071 djSP;
a0d0e21e
LW		 3072 I32 i;
3073 I32 len;
3074 I32 odd = 0;
3075 STDCHAR tbuf[512];
3076 register STDCHAR *s;
3077 register IO *io;
5f05dabc 3078 register SV *sv;
3079 GV *gv;
2d8e6c8d 3080 STRLEN n_a;
146174a9 3081 PerlIO *fp;
a0d0e21e 3082
533c011a 3083 if (PL_op->op_flags & OPf_REF)
146174a9 3084 gv = cGVOP_gv;
5f05dabc 3085 else if (isGV(TOPs))
3086 gv = (GV*)POPs;
3087 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3088 gv = (GV*)SvRV(POPs);
3089 else
3090 gv = Nullgv;
3091
3092 if (gv) {
a0d0e21e 3093 EXTEND(SP, 1);
3280af22
NIS		 3094 if (gv == PL_defgv) {
3095 if (PL_statgv)
3096 io = GvIO(PL_statgv);
a0d0e21e 3097 else {
3280af22 3098 sv = PL_statname;
a0d0e21e
LW		 3099 goto really_filename;
3100 }
3101 }
3102 else {
3280af22
NIS		 3103 PL_statgv = gv;
3104 PL_laststatval = -1;
3105 sv_setpv(PL_statname, "");
3106 io = GvIO(PL_statgv);
a0d0e21e
LW		 3107 }
3108 if (io && IoIFP(io)) {
5f05dabc 3109 if (! PerlIO_has_base(IoIFP(io)))
cea2e8a9 3110 DIE(aTHX_ "-T and -B not implemented on filehandles");
3280af22
NIS		 3111 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3112 if (PL_laststatval < 0)
5f05dabc 3113 RETPUSHUNDEF;
3280af22 3114 if (S_ISDIR(PL_statcache.st_mode)) /* handle NFS glitch */
533c011a 3115 if (PL_op->op_type == OP_FTTEXT)
a0d0e21e
LW		 3116 RETPUSHNO;
3117 else
3118 RETPUSHYES;
a20bf0c3 3119 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
760ac839 3120 i = PerlIO_getc(IoIFP(io));
a0d0e21e 3121 if (i != EOF)
760ac839 3122 (void)PerlIO_ungetc(IoIFP(io),i);
a0d0e21e 3123 }
a20bf0c3 3124 if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
a0d0e21e 3125 RETPUSHYES;
a20bf0c3
JH		 3126 len = PerlIO_get_bufsiz(IoIFP(io));
3127 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
760ac839
LW		 3128 /* sfio can have large buffers - limit to 512 */
3129 if (len > 512)
3130 len = 512;
a0d0e21e
LW		 3131 }
3132 else {
2dd78f96
JH		 3133 dTHR;
3134 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
146174a9 3135 gv = cGVOP_gv;
2dd78f96 3136 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
146174a9 3137 }
748a9306 3138 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW		 3139 RETPUSHUNDEF;
3140 }
3141 }
3142 else {
3143 sv = POPs;
5f05dabc 3144 really_filename:
3280af22
NIS		 3145 PL_statgv = Nullgv;
3146 PL_laststatval = -1;
2d8e6c8d 3147 sv_setpv(PL_statname, SvPV(sv, n_a));
146174a9 3148 if (!(fp = PerlIO_open(SvPVX(PL_statname), "r"))) {
2d8e6c8d 3149 if (ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, n_a), '\n'))
cea2e8a9 3150 Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "open");
a0d0e21e
LW		 3151 RETPUSHUNDEF;
3152 }
146174a9
CB		 3153 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3154 if (PL_laststatval < 0) {
3155 (void)PerlIO_close(fp);
5f05dabc 3156 RETPUSHUNDEF;
146174a9 3157 }
92d29cee 3158 do_binmode(fp, '<', O_BINARY);
146174a9
CB		 3159 len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3160 (void)PerlIO_close(fp);
a0d0e21e 3161 if (len <= 0) {
533c011a 3162 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
a0d0e21e
LW		 3163 RETPUSHNO; /* special case NFS directories */
3164 RETPUSHYES; /* null file is anything */
3165 }
3166 s = tbuf;
3167 }
3168
3169 /* now scan s to look for textiness */
4633a7c4 3170 /* XXX ASCII dependent code */
a0d0e21e 3171
146174a9
CB		 3172#if defined(DOSISH) || defined(USEMYBINMODE)
3173 /* ignore trailing ^Z on short files */
3174 if (len && len < sizeof(tbuf) && tbuf[len-1] == 26)
3175 --len;
3176#endif
3177
a0d0e21e
LW		 3178 for (i = 0; i < len; i++, s++) {
3179 if (!*s) { /* null never allowed in text */
3180 odd += len;
3181 break;
3182 }
9d116dd7 3183#ifdef EBCDIC
301e8125 3184 else if (!(isPRINT(*s) || isSPACE(*s)))
9d116dd7
JH		 3185 odd++;
3186#else
146174a9
CB		 3187 else if (*s & 128) {
3188#ifdef USE_LOCALE
b3f66c68
GS		 3189 if ((PL_op->op_private & OPpLOCALE) && isALPHA_LC(*s))
3190 continue;
3191#endif
3192 /* utf8 characters don't count as odd */
3193 if (*s & 0x40) {
3194 int ulen = UTF8SKIP(s);
3195 if (ulen < len - i) {
3196 int j;
3197 for (j = 1; j < ulen; j++) {
3198 if ((s[j] & 0xc0) != 0x80)
3199 goto not_utf8;
3200 }
3201 --ulen; /* loop does extra increment */
3202 s += ulen;
3203 i += ulen;
3204 continue;
3205 }
3206 }
3207 not_utf8:
3208 odd++;
146174a9 3209 }
a0d0e21e
LW		 3210 else if (*s < 32 &&
3211 *s != '\n' && *s != '\r' && *s != '\b' &&
3212 *s != '\t' && *s != '\f' && *s != 27)
3213 odd++;
9d116dd7 3214#endif
a0d0e21e
LW		 3215 }
3216
533c011a 3217 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
a0d0e21e
LW		 3218 RETPUSHNO;
3219 else
3220 RETPUSHYES;
3221}
3222
3223PP(pp_ftbinary)
3224{
cea2e8a9 3225 return pp_fttext();
a0d0e21e
LW		 3226}
3227
3228/* File calls. */
3229
3230PP(pp_chdir)
3231{
4e35701f 3232 djSP; dTARGET;
a0d0e21e
LW		 3233 char *tmps;
3234 SV **svp;
2d8e6c8d 3235 STRLEN n_a;
a0d0e21e
LW		 3236
3237 if (MAXARG < 1)
3238 tmps = Nullch;
3239 else
2d8e6c8d 3240 tmps = POPpx;
a0d0e21e 3241 if (!tmps || !*tmps) {
3280af22 3242 svp = hv_fetch(GvHVn(PL_envgv), "HOME", 4, FALSE);
a0d0e21e 3243 if (svp)
2d8e6c8d 3244 tmps = SvPV(*svp, n_a);
a0d0e21e
LW		 3245 }
3246 if (!tmps || !*tmps) {
3280af22 3247 svp = hv_fetch(GvHVn(PL_envgv), "LOGDIR", 6, FALSE);
a0d0e21e 3248 if (svp)
2d8e6c8d 3249 tmps = SvPV(*svp, n_a);
a0d0e21e 3250 }
491527d0
GS		 3251#ifdef VMS
3252 if (!tmps || !*tmps) {
6b88bc9c 3253 svp = hv_fetch(GvHVn(PL_envgv), "SYS$LOGIN", 9, FALSE);
491527d0 3254 if (svp)
2d8e6c8d 3255 tmps = SvPV(*svp, n_a);
491527d0
GS		 3256 }
3257#endif
a0d0e21e 3258 TAINT_PROPER("chdir");
6ad3d225 3259 PUSHi( PerlDir_chdir(tmps) >= 0 );
748a9306
LW		 3260#ifdef VMS
3261 /* Clear the DEFAULT element of ENV so we'll get the new value
3262 * in the future. */
6b88bc9c 3263 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
748a9306 3264#endif
a0d0e21e
LW		 3265 RETURN;
3266}
3267
3268PP(pp_chown)
3269{
4e35701f 3270 djSP; dMARK; dTARGET;
a0d0e21e
LW		 3271 I32 value;
3272#ifdef HAS_CHOWN
533c011a 3273 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 3274 SP = MARK;
3275 PUSHi(value);
3276 RETURN;
3277#else
cea2e8a9 3278 DIE(aTHX_ PL_no_func, "Unsupported function chown");
a0d0e21e
LW		 3279#endif
3280}
3281
3282PP(pp_chroot)
3283{
4e35701f 3284 djSP; dTARGET;
a0d0e21e
LW		 3285 char *tmps;
3286#ifdef HAS_CHROOT
2d8e6c8d
GS		 3287 STRLEN n_a;
3288 tmps = POPpx;
a0d0e21e
LW		 3289 TAINT_PROPER("chroot");
3290 PUSHi( chroot(tmps) >= 0 );
3291 RETURN;
3292#else
cea2e8a9 3293 DIE(aTHX_ PL_no_func, "chroot");
a0d0e21e
LW		 3294#endif
3295}
3296
3297PP(pp_unlink)
3298{
4e35701f 3299 djSP; dMARK; dTARGET;
a0d0e21e 3300 I32 value;
533c011a 3301 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 3302 SP = MARK;
3303 PUSHi(value);
3304 RETURN;
3305}
3306
3307PP(pp_chmod)
3308{
4e35701f 3309 djSP; dMARK; dTARGET;
a0d0e21e 3310 I32 value;
533c011a 3311 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 3312 SP = MARK;
3313 PUSHi(value);
3314 RETURN;
3315}
3316
3317PP(pp_utime)
3318{
4e35701f 3319 djSP; dMARK; dTARGET;
a0d0e21e 3320 I32 value;
533c011a 3321 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 3322 SP = MARK;
3323 PUSHi(value);
3324 RETURN;
3325}
3326
3327PP(pp_rename)
3328{
4e35701f 3329 djSP; dTARGET;
a0d0e21e 3330 int anum;
2d8e6c8d 3331 STRLEN n_a;
a0d0e21e 3332
2d8e6c8d
GS		 3333 char *tmps2 = POPpx;
3334 char *tmps = SvPV(TOPs, n_a);
a0d0e21e
LW		 3335 TAINT_PROPER("rename");
3336#ifdef HAS_RENAME
baed7233 3337 anum = PerlLIO_rename(tmps, tmps2);
a0d0e21e 3338#else
6b88bc9c 3339 if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
ed969818
W		 3340 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3341 anum = 1;
3342 else {
3654eb6c 3343 if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
ed969818
W		 3344 (void)UNLINK(tmps2);
3345 if (!(anum = link(tmps, tmps2)))
3346 anum = UNLINK(tmps);
3347 }
a0d0e21e
LW		 3348 }
3349#endif
3350 SETi( anum >= 0 );
3351 RETURN;
3352}
3353
3354PP(pp_link)
3355{
4e35701f 3356 djSP; dTARGET;
a0d0e21e 3357#ifdef HAS_LINK
2d8e6c8d
GS		 3358 STRLEN n_a;
3359 char *tmps2 = POPpx;
3360 char *tmps = SvPV(TOPs, n_a);
a0d0e21e 3361 TAINT_PROPER("link");
146174a9 3362 SETi( PerlLIO_link(tmps, tmps2) >= 0 );
a0d0e21e 3363#else
cea2e8a9 3364 DIE(aTHX_ PL_no_func, "Unsupported function link");
a0d0e21e
LW		 3365#endif
3366 RETURN;
3367}
3368
3369PP(pp_symlink)
3370{
4e35701f 3371 djSP; dTARGET;
a0d0e21e 3372#ifdef HAS_SYMLINK
2d8e6c8d
GS		 3373 STRLEN n_a;
3374 char *tmps2 = POPpx;
3375 char *tmps = SvPV(TOPs, n_a);
a0d0e21e
LW		 3376 TAINT_PROPER("symlink");
3377 SETi( symlink(tmps, tmps2) >= 0 );
3378 RETURN;
3379#else
cea2e8a9 3380 DIE(aTHX_ PL_no_func, "symlink");
a0d0e21e
LW		 3381#endif
3382}
3383
3384PP(pp_readlink)
3385{
4e35701f 3386 djSP; dTARGET;
a0d0e21e
LW		 3387#ifdef HAS_SYMLINK
3388 char *tmps;
46fc3d4c 3389 char buf[MAXPATHLEN];
a0d0e21e 3390 int len;
2d8e6c8d 3391 STRLEN n_a;
46fc3d4c 3392
fb73857a 3393#ifndef INCOMPLETE_TAINTS
3394 TAINT;
3395#endif
2d8e6c8d 3396 tmps = POPpx;
a0d0e21e
LW		 3397 len = readlink(tmps, buf, sizeof buf);
3398 EXTEND(SP, 1);
3399 if (len < 0)
3400 RETPUSHUNDEF;
3401 PUSHp(buf, len);
3402 RETURN;
3403#else
3404 EXTEND(SP, 1);
3405 RETSETUNDEF; /* just pretend it's a normal file */
3406#endif
3407}
3408
3409#if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
ba106d47 3410STATIC int
cea2e8a9 3411S_dooneliner(pTHX_ char *cmd, char *filename)
a0d0e21e 3412{
1e422769 3413 char *save_filename = filename;
3414 char *cmdline;
3415 char *s;
760ac839 3416 PerlIO *myfp;
1e422769 3417 int anum = 1;
a0d0e21e 3418
1e422769 3419 New(666, cmdline, strlen(cmd) + (strlen(filename) * 2) + 10, char);
3420 strcpy(cmdline, cmd);
3421 strcat(cmdline, " ");
3422 for (s = cmdline + strlen(cmdline); *filename; ) {
a0d0e21e
LW		 3423 *s++ = '\\';
3424 *s++ = *filename++;
3425 }
3426 strcpy(s, " 2>&1");
6ad3d225 3427 myfp = PerlProc_popen(cmdline, "r");
1e422769 3428 Safefree(cmdline);
3429
a0d0e21e 3430 if (myfp) {
1e422769 3431 SV *tmpsv = sv_newmortal();
6b88bc9c 3432 /* Need to save/restore 'PL_rs' ?? */
760ac839 3433 s = sv_gets(tmpsv, myfp, 0);
6ad3d225 3434 (void)PerlProc_pclose(myfp);
a0d0e21e 3435 if (s != Nullch) {
1e422769 3436 int e;
3437 for (e = 1;
a0d0e21e 3438#ifdef HAS_SYS_ERRLIST
1e422769 3439 e <= sys_nerr
3440#endif
3441 ; e++)
3442 {
3443 /* you don't see this */
3444 char *errmsg =
3445#ifdef HAS_SYS_ERRLIST
3446 sys_errlist[e]
a0d0e21e 3447#else
1e422769 3448 strerror(e)
a0d0e21e 3449#endif
1e422769 3450 ;
3451 if (!errmsg)
3452 break;
3453 if (instr(s, errmsg)) {
3454 SETERRNO(e,0);
3455 return 0;
3456 }
a0d0e21e 3457 }
748a9306 3458 SETERRNO(0,0);
a0d0e21e
LW		 3459#ifndef EACCES
3460#define EACCES EPERM
3461#endif
1e422769 3462 if (instr(s, "cannot make"))
748a9306 3463 SETERRNO(EEXIST,RMS$_FEX);
1e422769 3464 else if (instr(s, "existing file"))
748a9306 3465 SETERRNO(EEXIST,RMS$_FEX);
1e422769 3466 else if (instr(s, "ile exists"))
748a9306 3467 SETERRNO(EEXIST,RMS$_FEX);
1e422769 3468 else if (instr(s, "non-exist"))
748a9306 3469 SETERRNO(ENOENT,RMS$_FNF);
1e422769 3470 else if (instr(s, "does not exist"))
748a9306 3471 SETERRNO(ENOENT,RMS$_FNF);
1e422769 3472 else if (instr(s, "not empty"))
748a9306 3473 SETERRNO(EBUSY,SS$_DEVOFFLINE);
1e422769 3474 else if (instr(s, "cannot access"))
748a9306 3475 SETERRNO(EACCES,RMS$_PRV);
a0d0e21e 3476 else
748a9306 3477 SETERRNO(EPERM,RMS$_PRV);
a0d0e21e
LW		 3478 return 0;
3479 }
3480 else { /* some mkdirs return no failure indication */
6b88bc9c 3481 anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
911d147d 3482 if (PL_op->op_type == OP_RMDIR)
a0d0e21e
LW		 3483 anum = !anum;
3484 if (anum)
748a9306 3485 SETERRNO(0,0);
a0d0e21e 3486 else
748a9306 3487 SETERRNO(EACCES,RMS$_PRV); /* a guess */
a0d0e21e
LW		 3488 }
3489 return anum;
3490 }
3491 else
3492 return 0;
3493}
3494#endif
3495
3496PP(pp_mkdir)
3497{
4e35701f 3498 djSP; dTARGET;
5a211162 3499 int mode;
a0d0e21e
LW		 3500#ifndef HAS_MKDIR
3501 int oldumask;
3502#endif
2d8e6c8d 3503 STRLEN n_a;
5a211162
GS		 3504 char *tmps;
3505
3506 if (MAXARG > 1)
3507 mode = POPi;
3508 else
3509 mode = 0777;
3510
3511 tmps = SvPV(TOPs, n_a);
a0d0e21e
LW		 3512
3513 TAINT_PROPER("mkdir");
3514#ifdef HAS_MKDIR
6ad3d225 3515 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
a0d0e21e
LW		 3516#else
3517 SETi( dooneliner("mkdir", tmps) );
6ad3d225
GS		 3518 oldumask = PerlLIO_umask(0);
3519 PerlLIO_umask(oldumask);
3520 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
a0d0e21e
LW		 3521#endif
3522 RETURN;
3523}
3524
3525PP(pp_rmdir)
3526{
4e35701f 3527 djSP; dTARGET;
a0d0e21e 3528 char *tmps;
2d8e6c8d 3529 STRLEN n_a;
a0d0e21e 3530
2d8e6c8d 3531 tmps = POPpx;
a0d0e21e
LW		 3532 TAINT_PROPER("rmdir");
3533#ifdef HAS_RMDIR
6ad3d225 3534 XPUSHi( PerlDir_rmdir(tmps) >= 0 );
a0d0e21e
LW		 3535#else
3536 XPUSHi( dooneliner("rmdir", tmps) );
3537#endif
3538 RETURN;
3539}
3540
3541/* Directory calls. */
3542
3543PP(pp_open_dir)
3544{
4e35701f 3545 djSP;
a0d0e21e 3546#if defined(Direntry_t) && defined(HAS_READDIR)
2d8e6c8d
GS		 3547 STRLEN n_a;
3548 char *dirname = POPpx;
a0d0e21e
LW		 3549 GV *gv = (GV*)POPs;
3550 register IO *io = GvIOn(gv);
3551
3552 if (!io)
3553 goto nope;
3554
3555 if (IoDIRP(io))
6ad3d225
GS		 3556 PerlDir_close(IoDIRP(io));
3557 if (!(IoDIRP(io) = PerlDir_open(dirname)))
a0d0e21e
LW		 3558 goto nope;
3559
3560 RETPUSHYES;
3561nope:
3562 if (!errno)
748a9306 3563 SETERRNO(EBADF,RMS$_DIR);
a0d0e21e
LW		 3564 RETPUSHUNDEF;
3565#else
cea2e8a9 3566 DIE(aTHX_ PL_no_dir_func, "opendir");
a0d0e21e
LW		 3567#endif
3568}
3569
3570PP(pp_readdir)
3571{
4e35701f 3572 djSP;
a0d0e21e
LW		 3573#if defined(Direntry_t) && defined(HAS_READDIR)
3574#ifndef I_DIRENT
20ce7b12 3575 Direntry_t *readdir (DIR *);
a0d0e21e
LW		 3576#endif
3577 register Direntry_t *dp;
3578 GV *gv = (GV*)POPs;
3579 register IO *io = GvIOn(gv);
fb73857a 3580 SV *sv;
a0d0e21e
LW		 3581
3582 if (!io || !IoDIRP(io))
3583 goto nope;
3584
3585 if (GIMME == G_ARRAY) {
3586 /*SUPPRESS 560*/
155aba94 3587 while ((dp = (Direntry_t *)PerlDir_read(IoDIRP(io)))) {
a0d0e21e 3588#ifdef DIRNAMLEN
79cb57f6 3589 sv = newSVpvn(dp->d_name, dp->d_namlen);
a0d0e21e 3590#else
fb73857a 3591 sv = newSVpv(dp->d_name, 0);
3592#endif
3593#ifndef INCOMPLETE_TAINTS
26fb8f1f
GS		 3594 if (!(IoFLAGS(io) & IOf_UNTAINT))
3595 SvTAINTED_on(sv);
a0d0e21e 3596#endif
fb73857a 3597 XPUSHs(sv_2mortal(sv));
a0d0e21e
LW		 3598 }
3599 }
3600 else {
6ad3d225 3601 if (!(dp = (Direntry_t *)PerlDir_read(IoDIRP(io))))
a0d0e21e
LW		 3602 goto nope;
3603#ifdef DIRNAMLEN
79cb57f6 3604 sv = newSVpvn(dp->d_name, dp->d_namlen);
a0d0e21e 3605#else
fb73857a 3606 sv = newSVpv(dp->d_name, 0);
a0d0e21e 3607#endif
fb73857a 3608#ifndef INCOMPLETE_TAINTS
26fb8f1f
GS		 3609 if (!(IoFLAGS(io) & IOf_UNTAINT))
3610 SvTAINTED_on(sv);
fb73857a 3611#endif
3612 XPUSHs(sv_2mortal(sv));
a0d0e21e
LW		 3613 }
3614 RETURN;
3615
3616nope:
3617 if (!errno)
748a9306 3618 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 3619 if (GIMME == G_ARRAY)
3620 RETURN;
3621 else
3622 RETPUSHUNDEF;
3623#else
cea2e8a9 3624 DIE(aTHX_ PL_no_dir_func, "readdir");
a0d0e21e
LW		 3625#endif
3626}
3627
3628PP(pp_telldir)
3629{
4e35701f 3630 djSP; dTARGET;
a0d0e21e 3631#if defined(HAS_TELLDIR) || defined(telldir)
968dcd91
JH		 3632 /* XXX does _anyone_ need this? --AD 2/20/1998 */
3633 /* XXX netbsd still seemed to.
3634 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3635 --JHI 1999-Feb-02 */
3636# if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
20ce7b12 3637 long telldir (DIR *);
dfe9444c 3638# endif
a0d0e21e
LW		 3639 GV *gv = (GV*)POPs;
3640 register IO *io = GvIOn(gv);
3641
3642 if (!io || !IoDIRP(io))
3643 goto nope;
3644
6ad3d225 3645 PUSHi( PerlDir_tell(IoDIRP(io)) );
a0d0e21e
LW		 3646 RETURN;
3647nope:
3648 if (!errno)
748a9306 3649 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 3650 RETPUSHUNDEF;
3651#else
cea2e8a9 3652 DIE(aTHX_ PL_no_dir_func, "telldir");
a0d0e21e
LW		 3653#endif
3654}
3655
3656PP(pp_seekdir)
3657{
4e35701f 3658 djSP;
a0d0e21e
LW		 3659#if defined(HAS_SEEKDIR) || defined(seekdir)
3660 long along = POPl;
3661 GV *gv = (GV*)POPs;
3662 register IO *io = GvIOn(gv);
3663
3664 if (!io || !IoDIRP(io))
3665 goto nope;
3666
6ad3d225 3667 (void)PerlDir_seek(IoDIRP(io), along);
a0d0e21e
LW		 3668
3669 RETPUSHYES;
3670nope:
3671 if (!errno)
748a9306 3672 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 3673 RETPUSHUNDEF;
3674#else
cea2e8a9 3675 DIE(aTHX_ PL_no_dir_func, "seekdir");
a0d0e21e
LW		 3676#endif
3677}
3678
3679PP(pp_rewinddir)
3680{
4e35701f 3681 djSP;
a0d0e21e
LW		 3682#if defined(HAS_REWINDDIR) || defined(rewinddir)
3683 GV *gv = (GV*)POPs;
3684 register IO *io = GvIOn(gv);
3685
3686 if (!io || !IoDIRP(io))
3687 goto nope;
3688
6ad3d225 3689 (void)PerlDir_rewind(IoDIRP(io));
a0d0e21e
LW		 3690 RETPUSHYES;
3691nope:
3692 if (!errno)
748a9306 3693 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 3694 RETPUSHUNDEF;
3695#else
cea2e8a9 3696 DIE(aTHX_ PL_no_dir_func, "rewinddir");
a0d0e21e
LW		 3697#endif
3698}
3699
3700PP(pp_closedir)
3701{
4e35701f 3702 djSP;
a0d0e21e
LW		 3703#if defined(Direntry_t) && defined(HAS_READDIR)
3704 GV *gv = (GV*)POPs;
3705 register IO *io = GvIOn(gv);
3706
3707 if (!io || !IoDIRP(io))
3708 goto nope;
3709
3710#ifdef VOID_CLOSEDIR
6ad3d225 3711 PerlDir_close(IoDIRP(io));
a0d0e21e 3712#else
6ad3d225 3713 if (PerlDir_close(IoDIRP(io)) < 0) {
748a9306 3714 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
a0d0e21e 3715 goto nope;
748a9306 3716 }
a0d0e21e
LW		 3717#endif
3718 IoDIRP(io) = 0;
3719
3720 RETPUSHYES;
3721nope:
3722 if (!errno)
748a9306 3723 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW		 3724 RETPUSHUNDEF;
3725#else
cea2e8a9 3726 DIE(aTHX_ PL_no_dir_func, "closedir");
a0d0e21e
LW		 3727#endif
3728}
3729
3730/* Process control. */
3731
3732PP(pp_fork)
3733{
44a8e56a 3734#ifdef HAS_FORK
4e35701f 3735 djSP; dTARGET;
761237fe 3736 Pid_t childpid;
a0d0e21e
LW		 3737 GV *tmpgv;
3738
3739 EXTEND(SP, 1);
45bc9206 3740 PERL_FLUSHALL_FOR_CHILD;
a0d0e21e
LW		 3741 childpid = fork();
3742 if (childpid < 0)
3743 RETSETUNDEF;
3744 if (!childpid) {
3745 /*SUPPRESS 560*/
155aba94 3746 if ((tmpgv = gv_fetchpv("$", TRUE, SVt_PV)))
146174a9 3747 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3280af22 3748 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
a0d0e21e
LW		 3749 }
3750 PUSHi(childpid);
3751 RETURN;
3752#else
146174a9
CB		 3753# if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3754 djSP; dTARGET;
3755 Pid_t childpid;
3756
3757 EXTEND(SP, 1);
3758 PERL_FLUSHALL_FOR_CHILD;
3759 childpid = PerlProc_fork();
60fa28ff
GS		 3760 if (childpid == -1)
3761 RETSETUNDEF;
146174a9
CB		 3762 PUSHi(childpid);
3763 RETURN;
3764# else
cea2e8a9 3765 DIE(aTHX_ PL_no_func, "Unsupported function fork");
146174a9 3766# endif
a0d0e21e
LW		 3767#endif
3768}
3769
3770PP(pp_wait)
3771{
301e8125 3772#if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
4e35701f 3773 djSP; dTARGET;
761237fe 3774 Pid_t childpid;
a0d0e21e 3775 int argflags;
a0d0e21e 3776
44a8e56a 3777 childpid = wait4pid(-1, &argflags, 0);
68a29c53
GS		 3778# if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3779 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
3780 STATUS_NATIVE_SET((childpid && childpid != -1) ? argflags : -1);
3781# else
f86702cc 3782 STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
68a29c53 3783# endif
44a8e56a 3784 XPUSHi(childpid);
a0d0e21e
LW		 3785 RETURN;
3786#else
cea2e8a9 3787 DIE(aTHX_ PL_no_func, "Unsupported function wait");
a0d0e21e
LW		 3788#endif
3789}
3790
3791PP(pp_waitpid)
3792{
301e8125 3793#if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
4e35701f 3794 djSP; dTARGET;
761237fe 3795 Pid_t childpid;
a0d0e21e
LW		 3796 int optype;
3797 int argflags;
a0d0e21e 3798
a0d0e21e
LW		 3799 optype = POPi;
3800 childpid = TOPi;
3801 childpid = wait4pid(childpid, &argflags, optype);
68a29c53
GS		 3802# if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3803 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
3804 STATUS_NATIVE_SET((childpid && childpid != -1) ? argflags : -1);
3805# else
f86702cc 3806 STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
68a29c53 3807# endif
44a8e56a 3808 SETi(childpid);
a0d0e21e
LW		 3809 RETURN;
3810#else
cea2e8a9 3811 DIE(aTHX_ PL_no_func, "Unsupported function waitpid");
a0d0e21e
LW		 3812#endif
3813}
3814
3815PP(pp_system)
3816{
4e35701f 3817 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e 3818 I32 value;
761237fe 3819 Pid_t childpid;
a0d0e21e
LW		 3820 int result;
3821 int status;
ff68c719 3822 Sigsave_t ihand,qhand; /* place to save signals during system() */
2d8e6c8d 3823 STRLEN n_a;
d5a9bfb0
IZ		 3824 I32 did_pipes = 0;
3825 int pp[2];
a0d0e21e 3826
a0d0e21e 3827 if (SP - MARK == 1) {
3280af22 3828 if (PL_tainting) {
2d8e6c8d 3829 char *junk = SvPV(TOPs, n_a);
a0d0e21e
LW		 3830 TAINT_ENV();
3831 TAINT_PROPER("system");
3832 }
3833 }
45bc9206 3834 PERL_FLUSHALL_FOR_CHILD;
64ca3a65 3835#if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) && !defined(__CYGWIN__) || defined(PERL_MICRO)
d5a9bfb0
IZ		 3836 if (PerlProc_pipe(pp) >= 0)
3837 did_pipes = 1;
a0d0e21e
LW		 3838 while ((childpid = vfork()) == -1) {
3839 if (errno != EAGAIN) {
3840 value = -1;
3841 SP = ORIGMARK;
3842 PUSHi(value);
d5a9bfb0
IZ		 3843 if (did_pipes) {
3844 PerlLIO_close(pp[0]);
3845 PerlLIO_close(pp[1]);
3846 }
a0d0e21e
LW		 3847 RETURN;
3848 }
3849 sleep(5);
3850 }
3851 if (childpid > 0) {
d5a9bfb0
IZ		 3852 if (did_pipes)
3853 PerlLIO_close(pp[1]);
64ca3a65 3854#ifndef PERL_MICRO
ff68c719 3855 rsignal_save(SIGINT, SIG_IGN, &ihand);
3856 rsignal_save(SIGQUIT, SIG_IGN, &qhand);
64ca3a65 3857#endif
748a9306
LW		 3858 do {
3859 result = wait4pid(childpid, &status, 0);
3860 } while (result == -1 && errno == EINTR);
64ca3a65 3861#ifndef PERL_MICRO
ff68c719 3862 (void)rsignal_restore(SIGINT, &ihand);
3863 (void)rsignal_restore(SIGQUIT, &qhand);
64ca3a65 3864#endif
91e9c03f 3865 STATUS_NATIVE_SET(result == -1 ? -1 : status);
a0d0e21e
LW		 3866 do_execfree(); /* free any memory child malloced on vfork */
3867 SP = ORIGMARK;
d5a9bfb0
IZ		 3868 if (did_pipes) {
3869 int errkid;
3870 int n = 0, n1;
3871
3872 while (n < sizeof(int)) {
3873 n1 = PerlLIO_read(pp[0],
3874 (void*)(((char*)&errkid)+n),
3875 (sizeof(int)) - n);
3876 if (n1 <= 0)
3877 break;
3878 n += n1;
3879 }
3880 PerlLIO_close(pp[0]);
3881 if (n) { /* Error */
3882 if (n != sizeof(int))
c529f79d 3883 DIE(aTHX_ "panic: kid popen errno read");
d5a9bfb0
IZ		 3884 errno = errkid; /* Propagate errno from kid */
3885 STATUS_CURRENT = -1;
3886 }
3887 }
ff0cee69 3888 PUSHi(STATUS_CURRENT);
a0d0e21e
LW		 3889 RETURN;
3890 }
d5a9bfb0
IZ		 3891 if (did_pipes) {
3892 PerlLIO_close(pp[0]);
3893#if defined(HAS_FCNTL) && defined(F_SETFD)
3894 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
3895#endif
3896 }
533c011a 3897 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e 3898 SV *really = *++MARK;
d5a9bfb0 3899 value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
a0d0e21e
LW		 3900 }
3901 else if (SP - MARK != 1)
d5a9bfb0 3902 value = (I32)do_aexec5(Nullsv, MARK, SP, pp[1], did_pipes);
a0d0e21e 3903 else {
d5a9bfb0 3904 value = (I32)do_exec3(SvPVx(sv_mortalcopy(*SP), n_a), pp[1], did_pipes);
a0d0e21e 3905 }
6ad3d225 3906 PerlProc__exit(-1);
c3293030 3907#else /* ! FORK or VMS or OS/2 */
922b1888
GS		 3908 PL_statusvalue = 0;
3909 result = 0;
911d147d 3910 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e 3911 SV *really = *++MARK;
c5be433b 3912 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
a0d0e21e
LW		 3913 }
3914 else if (SP - MARK != 1)
c5be433b 3915 value = (I32)do_aspawn(Nullsv, (void **)MARK, (void **)SP);
a0d0e21e 3916 else {
c5be433b 3917 value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
a0d0e21e 3918 }
922b1888
GS		 3919 if (PL_statusvalue == -1) /* hint that value must be returned as is */
3920 result = 1;
f86702cc 3921 STATUS_NATIVE_SET(value);
a0d0e21e
LW		 3922 do_execfree();
3923 SP = ORIGMARK;
922b1888 3924 PUSHi(result ? value : STATUS_CURRENT);
a0d0e21e
LW		 3925#endif /* !FORK or VMS */
3926 RETURN;
3927}
3928
3929PP(pp_exec)
3930{
4e35701f 3931 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e 3932 I32 value;
2d8e6c8d 3933 STRLEN n_a;
a0d0e21e 3934
45bc9206 3935 PERL_FLUSHALL_FOR_CHILD;
533c011a 3936 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e
LW		 3937 SV *really = *++MARK;
3938 value = (I32)do_aexec(really, MARK, SP);
3939 }
3940 else if (SP - MARK != 1)
3941#ifdef VMS
3942 value = (I32)vms_do_aexec(Nullsv, MARK, SP);
3943#else
092bebab
JH		 3944# ifdef __OPEN_VM
3945 {
c5be433b 3946 (void ) do_aspawn(Nullsv, MARK, SP);
092bebab
JH		 3947 value = 0;
3948 }
3949# else
a0d0e21e 3950 value = (I32)do_aexec(Nullsv, MARK, SP);
092bebab 3951# endif
a0d0e21e
LW		 3952#endif
3953 else {
3280af22 3954 if (PL_tainting) {
2d8e6c8d 3955 char *junk = SvPV(*SP, n_a);
a0d0e21e
LW		 3956 TAINT_ENV();
3957 TAINT_PROPER("exec");
3958 }
3959#ifdef VMS
2d8e6c8d 3960 value = (I32)vms_do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
a0d0e21e 3961#else
092bebab 3962# ifdef __OPEN_VM
c5be433b 3963 (void) do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
092bebab
JH		 3964 value = 0;
3965# else
2d8e6c8d 3966 value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
092bebab 3967# endif
a0d0e21e
LW		 3968#endif
3969 }
146174a9
CB		 3970
3971#if !defined(HAS_FORK) && defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3972 if (value >= 0)
3973 my_exit(value);
3974#endif
3975
a0d0e21e
LW		 3976 SP = ORIGMARK;
3977 PUSHi(value);
3978 RETURN;
3979}
3980
3981PP(pp_kill)
3982{
4e35701f 3983 djSP; dMARK; dTARGET;
a0d0e21e
LW		 3984 I32 value;
3985#ifdef HAS_KILL
533c011a 3986 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 3987 SP = MARK;
3988 PUSHi(value);
3989 RETURN;
3990#else
cea2e8a9 3991 DIE(aTHX_ PL_no_func, "Unsupported function kill");
a0d0e21e
LW		 3992#endif
3993}
3994
3995PP(pp_getppid)
3996{
3997#ifdef HAS_GETPPID
4e35701f 3998 djSP; dTARGET;
a0d0e21e
LW		 3999 XPUSHi( getppid() );
4000 RETURN;
4001#else
cea2e8a9 4002 DIE(aTHX_ PL_no_func, "getppid");
a0d0e21e
LW		 4003#endif
4004}
4005
4006PP(pp_getpgrp)
4007{
4008#ifdef HAS_GETPGRP
4e35701f 4009 djSP; dTARGET;
d8a83dd3 4010 Pid_t pid;
9853a804 4011 Pid_t pgrp;
a0d0e21e
LW		 4012
4013 if (MAXARG < 1)
4014 pid = 0;
4015 else
4016 pid = SvIVx(POPs);
c3293030 4017#ifdef BSD_GETPGRP
9853a804 4018 pgrp = (I32)BSD_GETPGRP(pid);
a0d0e21e 4019#else
146174a9 4020 if (pid != 0 && pid != PerlProc_getpid())
cea2e8a9 4021 DIE(aTHX_ "POSIX getpgrp can't take an argument");
9853a804 4022 pgrp = getpgrp();
a0d0e21e 4023#endif
9853a804 4024 XPUSHi(pgrp);
a0d0e21e
LW		 4025 RETURN;
4026#else
cea2e8a9 4027 DIE(aTHX_ PL_no_func, "getpgrp()");
a0d0e21e
LW		 4028#endif
4029}
4030
4031PP(pp_setpgrp)
4032{
4033#ifdef HAS_SETPGRP
4e35701f 4034 djSP; dTARGET;
d8a83dd3
JH		 4035 Pid_t pgrp;
4036 Pid_t pid;
a0d0e21e
LW		 4037 if (MAXARG < 2) {
4038 pgrp = 0;
4039 pid = 0;
4040 }
4041 else {
4042 pgrp = POPi;
4043 pid = TOPi;
4044 }
4045
4046 TAINT_PROPER("setpgrp");
c3293030
IZ		 4047#ifdef BSD_SETPGRP
4048 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
a0d0e21e 4049#else
146174a9
CB		 4050 if ((pgrp != 0 && pgrp != PerlProc_getpid())
4051 || (pid != 0 && pid != PerlProc_getpid()))
4052 {
4053 DIE(aTHX_ "setpgrp can't take arguments");
4054 }
a0d0e21e
LW		 4055 SETi( setpgrp() >= 0 );
4056#endif /* USE_BSDPGRP */
4057 RETURN;
4058#else
cea2e8a9 4059 DIE(aTHX_ PL_no_func, "setpgrp()");
a0d0e21e
LW		 4060#endif
4061}
4062
4063PP(pp_getpriority)
4064{
4e35701f 4065 djSP; dTARGET;
a0d0e21e
LW		 4066 int which;
4067 int who;
4068#ifdef HAS_GETPRIORITY
4069 who = POPi;
4070 which = TOPi;
4071 SETi( getpriority(which, who) );
4072 RETURN;
4073#else
cea2e8a9 4074 DIE(aTHX_ PL_no_func, "getpriority()");
a0d0e21e
LW		 4075#endif
4076}
4077
4078PP(pp_setpriority)
4079{
4e35701f 4080 djSP; dTARGET;
a0d0e21e
LW		 4081 int which;
4082 int who;
4083 int niceval;
4084#ifdef HAS_SETPRIORITY
4085 niceval = POPi;
4086 who = POPi;
4087 which = TOPi;
4088 TAINT_PROPER("setpriority");
4089 SETi( setpriority(which, who, niceval) >= 0 );
4090 RETURN;
4091#else
cea2e8a9 4092 DIE(aTHX_ PL_no_func, "setpriority()");
a0d0e21e
LW		 4093#endif
4094}
4095
4096/* Time calls. */
4097
4098PP(pp_time)
4099{
4e35701f 4100 djSP; dTARGET;
cbdc8872 4101#ifdef BIG_TIME
4102 XPUSHn( time(Null(Time_t*)) );
4103#else
a0d0e21e 4104 XPUSHi( time(Null(Time_t*)) );
cbdc8872 4105#endif
a0d0e21e
LW		 4106 RETURN;
4107}
4108
cd52b7b2 4109/* XXX The POSIX name is CLK_TCK; it is to be preferred
4110 to HZ. Probably. For now, assume that if the system
4111 defines HZ, it does so correctly. (Will this break
4112 on VMS?)
4113 Probably we ought to use _sysconf(_SC_CLK_TCK), if
4114 it's supported. --AD 9/96.
4115*/
4116
a0d0e21e 4117#ifndef HZ
cd52b7b2 4118# ifdef CLK_TCK
4119# define HZ CLK_TCK
4120# else
4121# define HZ 60
4122# endif
a0d0e21e
LW		 4123#endif
4124
4125PP(pp_tms)
4126{
4e35701f 4127 djSP;
a0d0e21e 4128
55497cff 4129#ifndef HAS_TIMES
cea2e8a9 4130 DIE(aTHX_ "times not implemented");
a0d0e21e
LW		 4131#else
4132 EXTEND(SP, 4);
4133
4134#ifndef VMS
3280af22 4135 (void)PerlProc_times(&PL_timesbuf);
a0d0e21e 4136#else
6b88bc9c 4137 (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */
76e3520e
GS		 4138 /* struct tms, though same data */
4139 /* is returned. */
a0d0e21e
LW		 4140#endif
4141
65202027 4142 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_utime)/HZ)));
a0d0e21e 4143 if (GIMME == G_ARRAY) {
65202027
DS		 4144 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_stime)/HZ)));
4145 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cutime)/HZ)));
4146 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cstime)/HZ)));
a0d0e21e
LW		 4147 }
4148 RETURN;
55497cff 4149#endif /* HAS_TIMES */
a0d0e21e
LW		 4150}
4151
4152PP(pp_localtime)
4153{
cea2e8a9 4154 return pp_gmtime();
a0d0e21e
LW		 4155}
4156
4157PP(pp_gmtime)
4158{
4e35701f 4159 djSP;
a0d0e21e
LW		 4160 Time_t when;
4161 struct tm *tmbuf;
4162 static char *dayname[] = {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4163 static char *monname[] = {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4164 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4165
4166 if (MAXARG < 1)
4167 (void)time(&when);
4168 else
cbdc8872 4169#ifdef BIG_TIME
4170 when = (Time_t)SvNVx(POPs);
4171#else
a0d0e21e 4172 when = (Time_t)SvIVx(POPs);
cbdc8872 4173#endif
a0d0e21e 4174
533c011a 4175 if (PL_op->op_type == OP_LOCALTIME)
a0d0e21e
LW		 4176 tmbuf = localtime(&when);
4177 else
4178 tmbuf = gmtime(&when);
4179
4180 EXTEND(SP, 9);
bbce6d69 4181 EXTEND_MORTAL(9);
a0d0e21e 4182 if (GIMME != G_ARRAY) {
46fc3d4c 4183 SV *tsv;
a0d0e21e
LW		 4184 if (!tmbuf)
4185 RETPUSHUNDEF;
be28567c 4186 tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %d",
f5a29b03
RB		 4187 dayname[tmbuf->tm_wday],
4188 monname[tmbuf->tm_mon],
be28567c
GS		 4189 tmbuf->tm_mday,
4190 tmbuf->tm_hour,
4191 tmbuf->tm_min,
4192 tmbuf->tm_sec,
4193 tmbuf->tm_year + 1900);
46fc3d4c 4194 PUSHs(sv_2mortal(tsv));
a0d0e21e
LW		 4195 }
4196 else if (tmbuf) {
c6419e06
JH		 4197 PUSHs(sv_2mortal(newSViv(tmbuf->tm_sec)));
4198 PUSHs(sv_2mortal(newSViv(tmbuf->tm_min)));
4199 PUSHs(sv_2mortal(newSViv(tmbuf->tm_hour)));
4200 PUSHs(sv_2mortal(newSViv(tmbuf->tm_mday)));
4201 PUSHs(sv_2mortal(newSViv(tmbuf->tm_mon)));
4202 PUSHs(sv_2mortal(newSViv(tmbuf->tm_year)));
4203 PUSHs(sv_2mortal(newSViv(tmbuf->tm_wday)));
4204 PUSHs(sv_2mortal(newSViv(tmbuf->tm_yday)));
4205 PUSHs(sv_2mortal(newSViv(tmbuf->tm_isdst)));
a0d0e21e
LW		 4206 }
4207 RETURN;
4208}
4209
4210PP(pp_alarm)
4211{
4e35701f 4212 djSP; dTARGET;
a0d0e21e
LW		 4213 int anum;
4214#ifdef HAS_ALARM
4215 anum = POPi;
4216 anum = alarm((unsigned int)anum);
4217 EXTEND(SP, 1);
4218 if (anum < 0)
4219 RETPUSHUNDEF;
c6419e06 4220 PUSHi(anum);
a0d0e21e
LW		 4221 RETURN;
4222#else
cea2e8a9 4223 DIE(aTHX_ PL_no_func, "Unsupported function alarm");
a0d0e21e
LW		 4224#endif
4225}
4226
4227PP(pp_sleep)
4228{
4e35701f 4229 djSP; dTARGET;
a0d0e21e
LW		 4230 I32 duration;
4231 Time_t lasttime;
4232 Time_t when;
4233
4234 (void)time(&lasttime);
4235 if (MAXARG < 1)
76e3520e 4236 PerlProc_pause();
a0d0e21e
LW		 4237 else {
4238 duration = POPi;
76e3520e 4239 PerlProc_sleep((unsigned int)duration);
a0d0e21e
LW		 4240 }
4241 (void)time(&when);
4242 XPUSHi(when - lasttime);
4243 RETURN;
4244}
4245
4246/* Shared memory. */
4247
4248PP(pp_shmget)
4249{
cea2e8a9 4250 return pp_semget();
a0d0e21e
LW		 4251}
4252
4253PP(pp_shmctl)
4254{
cea2e8a9 4255 return pp_semctl();
a0d0e21e
LW		 4256}
4257
4258PP(pp_shmread)
4259{
cea2e8a9 4260 return pp_shmwrite();
a0d0e21e
LW		 4261}
4262
4263PP(pp_shmwrite)
4264{
4265#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 4266 djSP; dMARK; dTARGET;
533c011a 4267 I32 value = (I32)(do_shmio(PL_op->op_type, MARK, SP) >= 0);
a0d0e21e
LW		 4268 SP = MARK;
4269 PUSHi(value);
4270 RETURN;
4271#else
cea2e8a9 4272 return pp_semget();
a0d0e21e
LW		 4273#endif
4274}
4275
4276/* Message passing. */
4277
4278PP(pp_msgget)
4279{
cea2e8a9 4280 return pp_semget();
a0d0e21e
LW		 4281}
4282
4283PP(pp_msgctl)
4284{
cea2e8a9 4285 return pp_semctl();
a0d0e21e
LW		 4286}
4287
4288PP(pp_msgsnd)
4289{
4290#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 4291 djSP; dMARK; dTARGET;
a0d0e21e
LW		 4292 I32 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4293 SP = MARK;
4294 PUSHi(value);
4295 RETURN;
4296#else
cea2e8a9 4297 return pp_semget();
a0d0e21e
LW		 4298#endif
4299}
4300
4301PP(pp_msgrcv)
4302{
4303#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 4304 djSP; dMARK; dTARGET;
a0d0e21e
LW		 4305 I32 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4306 SP = MARK;
4307 PUSHi(value);
4308 RETURN;
4309#else
cea2e8a9 4310 return pp_semget();
a0d0e21e
LW		 4311#endif
4312}
4313
4314/* Semaphores. */
4315
4316PP(pp_semget)
4317{
4318#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 4319 djSP; dMARK; dTARGET;
533c011a 4320 int anum = do_ipcget(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 4321 SP = MARK;
4322 if (anum == -1)
4323 RETPUSHUNDEF;
4324 PUSHi(anum);
4325 RETURN;
4326#else
cea2e8a9 4327 DIE(aTHX_ "System V IPC is not implemented on this machine");
a0d0e21e
LW		 4328#endif
4329}
4330
4331PP(pp_semctl)
4332{
4333#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 4334 djSP; dMARK; dTARGET;
533c011a 4335 int anum = do_ipcctl(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 4336 SP = MARK;
4337 if (anum == -1)
4338 RETSETUNDEF;
4339 if (anum != 0) {
4340 PUSHi(anum);
4341 }
4342 else {
8903cb82 4343 PUSHp(zero_but_true, ZBTLEN);
a0d0e21e
LW		 4344 }
4345 RETURN;
4346#else
cea2e8a9 4347 return pp_semget();
a0d0e21e
LW		 4348#endif
4349}
4350
4351PP(pp_semop)
4352{
4353#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 4354 djSP; dMARK; dTARGET;
a0d0e21e
LW		 4355 I32 value = (I32)(do_semop(MARK, SP) >= 0);
4356 SP = MARK;
4357 PUSHi(value);
4358 RETURN;
4359#else
cea2e8a9 4360 return pp_semget();
a0d0e21e
LW		 4361#endif
4362}
4363
4364/* Get system info. */
4365
4366PP(pp_ghbyname)
4367{
693762b4 4368#ifdef HAS_GETHOSTBYNAME
cea2e8a9 4369 return pp_ghostent();
a0d0e21e 4370#else
cea2e8a9 4371 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
a0d0e21e
LW		 4372#endif
4373}
4374
4375PP(pp_ghbyaddr)
4376{
693762b4 4377#ifdef HAS_GETHOSTBYADDR
cea2e8a9 4378 return pp_ghostent();
a0d0e21e 4379#else
cea2e8a9 4380 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
a0d0e21e
LW		 4381#endif
4382}
4383
4384PP(pp_ghostent)
4385{
4e35701f 4386 djSP;
693762b4 4387#if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
533c011a 4388 I32 which = PL_op->op_type;
a0d0e21e
LW		 4389 register char **elem;
4390 register SV *sv;
dc45a647 4391#ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4599a1de
JH		 4392 struct hostent *PerlSock_gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4393 struct hostent *PerlSock_gethostbyname(Netdb_name_t);
6ad3d225 4394 struct hostent *PerlSock_gethostent(void);
a0d0e21e
LW		 4395#endif
4396 struct hostent *hent;
4397 unsigned long len;
2d8e6c8d 4398 STRLEN n_a;
a0d0e21e
LW		 4399
4400 EXTEND(SP, 10);
dc45a647
MB		 4401 if (which == OP_GHBYNAME)
4402#ifdef HAS_GETHOSTBYNAME
2d8e6c8d 4403 hent = PerlSock_gethostbyname(POPpx);
dc45a647 4404#else
cea2e8a9 4405 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
dc45a647 4406#endif
a0d0e21e 4407 else if (which == OP_GHBYADDR) {
dc45a647 4408#ifdef HAS_GETHOSTBYADDR
a0d0e21e 4409 int addrtype = POPi;
748a9306 4410 SV *addrsv = POPs;
a0d0e21e 4411 STRLEN addrlen;
4599a1de 4412 Netdb_host_t addr = (Netdb_host_t) SvPV(addrsv, addrlen);
a0d0e21e 4413
4599a1de 4414 hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
dc45a647 4415#else
cea2e8a9 4416 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
dc45a647 4417#endif
a0d0e21e
LW		 4418 }
4419 else
4420#ifdef HAS_GETHOSTENT
6ad3d225 4421 hent = PerlSock_gethostent();
a0d0e21e 4422#else
cea2e8a9 4423 DIE(aTHX_ PL_no_sock_func, "gethostent");
a0d0e21e
LW		 4424#endif
4425
4426#ifdef HOST_NOT_FOUND
4427 if (!hent)
f86702cc 4428 STATUS_NATIVE_SET(h_errno);
a0d0e21e
LW		 4429#endif
4430
4431 if (GIMME != G_ARRAY) {
4432 PUSHs(sv = sv_newmortal());
4433 if (hent) {
4434 if (which == OP_GHBYNAME) {
fd0af264 4435 if (hent->h_addr)
4436 sv_setpvn(sv, hent->h_addr, hent->h_length);
a0d0e21e
LW		 4437 }
4438 else
4439 sv_setpv(sv, (char*)hent->h_name);
4440 }
4441 RETURN;
4442 }
4443
4444 if (hent) {
3280af22 4445 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4446 sv_setpv(sv, (char*)hent->h_name);
3280af22 4447 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 4448 for (elem = hent->h_aliases; elem && *elem; elem++) {
4449 sv_catpv(sv, *elem);
4450 if (elem[1])
4451 sv_catpvn(sv, " ", 1);
4452 }
3280af22 4453 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4454 sv_setiv(sv, (IV)hent->h_addrtype);
3280af22 4455 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4456 len = hent->h_length;
1e422769 4457 sv_setiv(sv, (IV)len);
a0d0e21e
LW		 4458#ifdef h_addr
4459 for (elem = hent->h_addr_list; elem && *elem; elem++) {
3280af22 4460 XPUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 4461 sv_setpvn(sv, *elem, len);
4462 }
4463#else
6b88bc9c 4464 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
fd0af264 4465 if (hent->h_addr)
4466 sv_setpvn(sv, hent->h_addr, len);
a0d0e21e
LW		 4467#endif /* h_addr */
4468 }
4469 RETURN;
4470#else
cea2e8a9 4471 DIE(aTHX_ PL_no_sock_func, "gethostent");
a0d0e21e
LW		 4472#endif
4473}
4474
4475PP(pp_gnbyname)
4476{
693762b4 4477#ifdef HAS_GETNETBYNAME
cea2e8a9 4478 return pp_gnetent();
a0d0e21e 4479#else
cea2e8a9 4480 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
a0d0e21e
LW		 4481#endif
4482}
4483
4484PP(pp_gnbyaddr)
4485{
693762b4 4486#ifdef HAS_GETNETBYADDR
cea2e8a9 4487 return pp_gnetent();
a0d0e21e 4488#else
cea2e8a9 4489 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
a0d0e21e
LW		 4490#endif
4491}
4492
4493PP(pp_gnetent)
4494{
4e35701f 4495 djSP;
693762b4 4496#if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
533c011a 4497 I32 which = PL_op->op_type;
a0d0e21e
LW		 4498 register char **elem;
4499 register SV *sv;
dc45a647
MB		 4500#ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4501 struct netent *PerlSock_getnetbyaddr(Netdb_net_t, int);
4502 struct netent *PerlSock_getnetbyname(Netdb_name_t);
4503 struct netent *PerlSock_getnetent(void);
8ac85365 4504#endif
a0d0e21e 4505 struct netent *nent;
2d8e6c8d 4506 STRLEN n_a;
a0d0e21e
LW		 4507
4508 if (which == OP_GNBYNAME)
dc45a647 4509#ifdef HAS_GETNETBYNAME
2d8e6c8d 4510 nent = PerlSock_getnetbyname(POPpx);
dc45a647 4511#else
cea2e8a9 4512 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
dc45a647 4513#endif
a0d0e21e 4514 else if (which == OP_GNBYADDR) {
dc45a647 4515#ifdef HAS_GETNETBYADDR
a0d0e21e 4516 int addrtype = POPi;
4599a1de 4517 Netdb_net_t addr = (Netdb_net_t) U_L(POPn);
76e3520e 4518 nent = PerlSock_getnetbyaddr(addr, addrtype);
dc45a647 4519#else
cea2e8a9 4520 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
dc45a647 4521#endif
a0d0e21e
LW		 4522 }
4523 else
dc45a647 4524#ifdef HAS_GETNETENT
76e3520e 4525 nent = PerlSock_getnetent();
dc45a647 4526#else
cea2e8a9 4527 DIE(aTHX_ PL_no_sock_func, "getnetent");
dc45a647 4528#endif
a0d0e21e
LW		 4529
4530 EXTEND(SP, 4);
4531 if (GIMME != G_ARRAY) {
4532 PUSHs(sv = sv_newmortal());
4533 if (nent) {
4534 if (which == OP_GNBYNAME)
1e422769 4535 sv_setiv(sv, (IV)nent->n_net);
a0d0e21e
LW		 4536 else
4537 sv_setpv(sv, nent->n_name);
4538 }
4539 RETURN;
4540 }
4541
4542 if (nent) {
3280af22 4543 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4544 sv_setpv(sv, nent->n_name);
3280af22 4545 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 4546 for (elem = nent->n_aliases; elem && *elem; elem++) {
a0d0e21e
LW		 4547 sv_catpv(sv, *elem);
4548 if (elem[1])
4549 sv_catpvn(sv, " ", 1);
4550 }
3280af22 4551 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4552 sv_setiv(sv, (IV)nent->n_addrtype);
3280af22 4553 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4554 sv_setiv(sv, (IV)nent->n_net);
a0d0e21e
LW		 4555 }
4556
4557 RETURN;
4558#else
cea2e8a9 4559 DIE(aTHX_ PL_no_sock_func, "getnetent");
a0d0e21e
LW		 4560#endif
4561}
4562
4563PP(pp_gpbyname)
4564{
693762b4 4565#ifdef HAS_GETPROTOBYNAME
cea2e8a9 4566 return pp_gprotoent();
a0d0e21e 4567#else
cea2e8a9 4568 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
a0d0e21e
LW		 4569#endif
4570}
4571
4572PP(pp_gpbynumber)
4573{
693762b4 4574#ifdef HAS_GETPROTOBYNUMBER
cea2e8a9 4575 return pp_gprotoent();
a0d0e21e 4576#else
cea2e8a9 4577 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
a0d0e21e
LW		 4578#endif
4579}
4580
4581PP(pp_gprotoent)
4582{
4e35701f 4583 djSP;
693762b4 4584#if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
533c011a 4585 I32 which = PL_op->op_type;
a0d0e21e 4586 register char **elem;
301e8125 4587 register SV *sv;
dc45a647 4588#ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4599a1de 4589 struct protoent *PerlSock_getprotobyname(Netdb_name_t);
6ad3d225
GS		 4590 struct protoent *PerlSock_getprotobynumber(int);
4591 struct protoent *PerlSock_getprotoent(void);
8ac85365 4592#endif
a0d0e21e 4593 struct protoent *pent;
2d8e6c8d 4594 STRLEN n_a;
a0d0e21e
LW		 4595
4596 if (which == OP_GPBYNAME)
e5c9fcd0 4597#ifdef HAS_GETPROTOBYNAME
2d8e6c8d 4598 pent = PerlSock_getprotobyname(POPpx);
e5c9fcd0 4599#else
cea2e8a9 4600 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
e5c9fcd0 4601#endif
a0d0e21e 4602 else if (which == OP_GPBYNUMBER)
e5c9fcd0 4603#ifdef HAS_GETPROTOBYNUMBER
6ad3d225 4604 pent = PerlSock_getprotobynumber(POPi);
e5c9fcd0 4605#else
cea2e8a9 4606 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
e5c9fcd0 4607#endif
a0d0e21e 4608 else
e5c9fcd0 4609#ifdef HAS_GETPROTOENT
6ad3d225 4610 pent = PerlSock_getprotoent();
e5c9fcd0 4611#else
cea2e8a9 4612 DIE(aTHX_ PL_no_sock_func, "getprotoent");
e5c9fcd0 4613#endif
a0d0e21e
LW		 4614
4615 EXTEND(SP, 3);
4616 if (GIMME != G_ARRAY) {
4617 PUSHs(sv = sv_newmortal());
4618 if (pent) {
4619 if (which == OP_GPBYNAME)
1e422769 4620 sv_setiv(sv, (IV)pent->p_proto);
a0d0e21e
LW		 4621 else
4622 sv_setpv(sv, pent->p_name);
4623 }
4624 RETURN;
4625 }
4626
4627 if (pent) {
3280af22 4628 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4629 sv_setpv(sv, pent->p_name);
3280af22 4630 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 4631 for (elem = pent->p_aliases; elem && *elem; elem++) {
a0d0e21e
LW		 4632 sv_catpv(sv, *elem);
4633 if (elem[1])
4634 sv_catpvn(sv, " ", 1);
4635 }
3280af22 4636 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4637 sv_setiv(sv, (IV)pent->p_proto);
a0d0e21e
LW		 4638 }
4639
4640 RETURN;
4641#else
cea2e8a9 4642 DIE(aTHX_ PL_no_sock_func, "getprotoent");
a0d0e21e
LW		 4643#endif
4644}
4645
4646PP(pp_gsbyname)
4647{
9ec75305 4648#ifdef HAS_GETSERVBYNAME
cea2e8a9 4649 return pp_gservent();
a0d0e21e 4650#else
cea2e8a9 4651 DIE(aTHX_ PL_no_sock_func, "getservbyname");
a0d0e21e
LW		 4652#endif
4653}
4654
4655PP(pp_gsbyport)
4656{
9ec75305 4657#ifdef HAS_GETSERVBYPORT
cea2e8a9 4658 return pp_gservent();
a0d0e21e 4659#else
cea2e8a9 4660 DIE(aTHX_ PL_no_sock_func, "getservbyport");
a0d0e21e
LW		 4661#endif
4662}
4663
4664PP(pp_gservent)
4665{
4e35701f 4666 djSP;
693762b4 4667#if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
533c011a 4668 I32 which = PL_op->op_type;
a0d0e21e
LW		 4669 register char **elem;
4670 register SV *sv;
dc45a647 4671#ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4599a1de
JH		 4672 struct servent *PerlSock_getservbyname(Netdb_name_t, Netdb_name_t);
4673 struct servent *PerlSock_getservbyport(int, Netdb_name_t);
6ad3d225 4674 struct servent *PerlSock_getservent(void);
8ac85365 4675#endif
a0d0e21e 4676 struct servent *sent;
2d8e6c8d 4677 STRLEN n_a;
a0d0e21e
LW		 4678
4679 if (which == OP_GSBYNAME) {
dc45a647 4680#ifdef HAS_GETSERVBYNAME
2d8e6c8d
GS		 4681 char *proto = POPpx;
4682 char *name = POPpx;
a0d0e21e
LW		 4683
4684 if (proto && !*proto)
4685 proto = Nullch;
4686
6ad3d225 4687 sent = PerlSock_getservbyname(name, proto);
dc45a647 4688#else
cea2e8a9 4689 DIE(aTHX_ PL_no_sock_func, "getservbyname");
dc45a647 4690#endif
a0d0e21e
LW		 4691 }
4692 else if (which == OP_GSBYPORT) {
dc45a647 4693#ifdef HAS_GETSERVBYPORT
2d8e6c8d 4694 char *proto = POPpx;
36477c24 4695 unsigned short port = POPu;
a0d0e21e 4696
36477c24 4697#ifdef HAS_HTONS
6ad3d225 4698 port = PerlSock_htons(port);
36477c24 4699#endif
6ad3d225 4700 sent = PerlSock_getservbyport(port, proto);
dc45a647 4701#else
cea2e8a9 4702 DIE(aTHX_ PL_no_sock_func, "getservbyport");
dc45a647 4703#endif
a0d0e21e
LW		 4704 }
4705 else
e5c9fcd0 4706#ifdef HAS_GETSERVENT
6ad3d225 4707 sent = PerlSock_getservent();
e5c9fcd0 4708#else
cea2e8a9 4709 DIE(aTHX_ PL_no_sock_func, "getservent");
e5c9fcd0 4710#endif
a0d0e21e
LW		 4711
4712 EXTEND(SP, 4);
4713 if (GIMME != G_ARRAY) {
4714 PUSHs(sv = sv_newmortal());
4715 if (sent) {
4716 if (which == OP_GSBYNAME) {
4717#ifdef HAS_NTOHS
6ad3d225 4718 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
a0d0e21e 4719#else
1e422769 4720 sv_setiv(sv, (IV)(sent->s_port));
a0d0e21e
LW		 4721#endif
4722 }
4723 else
4724 sv_setpv(sv, sent->s_name);
4725 }
4726 RETURN;
4727 }
4728
4729 if (sent) {
3280af22 4730 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4731 sv_setpv(sv, sent->s_name);
3280af22 4732 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 4733 for (elem = sent->s_aliases; elem && *elem; elem++) {
a0d0e21e
LW		 4734 sv_catpv(sv, *elem);
4735 if (elem[1])
4736 sv_catpvn(sv, " ", 1);
4737 }
3280af22 4738 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4739#ifdef HAS_NTOHS
76e3520e 4740 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
a0d0e21e 4741#else
1e422769 4742 sv_setiv(sv, (IV)(sent->s_port));
a0d0e21e 4743#endif
3280af22 4744 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 4745 sv_setpv(sv, sent->s_proto);
4746 }
4747
4748 RETURN;
4749#else
cea2e8a9 4750 DIE(aTHX_ PL_no_sock_func, "getservent");
a0d0e21e
LW		 4751#endif
4752}
4753
4754PP(pp_shostent)
4755{
4e35701f 4756 djSP;
693762b4 4757#ifdef HAS_SETHOSTENT
76e3520e 4758 PerlSock_sethostent(TOPi);
a0d0e21e
LW		 4759 RETSETYES;
4760#else
cea2e8a9 4761 DIE(aTHX_ PL_no_sock_func, "sethostent");
a0d0e21e
LW		 4762#endif
4763}
4764
4765PP(pp_snetent)
4766{
4e35701f 4767 djSP;
693762b4 4768#ifdef HAS_SETNETENT
76e3520e 4769 PerlSock_setnetent(TOPi);
a0d0e21e
LW		 4770 RETSETYES;
4771#else
cea2e8a9 4772 DIE(aTHX_ PL_no_sock_func, "setnetent");
a0d0e21e
LW		 4773#endif
4774}
4775
4776PP(pp_sprotoent)
4777{
4e35701f 4778 djSP;
693762b4 4779#ifdef HAS_SETPROTOENT
76e3520e 4780 PerlSock_setprotoent(TOPi);
a0d0e21e
LW		 4781 RETSETYES;
4782#else
cea2e8a9 4783 DIE(aTHX_ PL_no_sock_func, "setprotoent");
a0d0e21e
LW		 4784#endif
4785}
4786
4787PP(pp_sservent)
4788{
4e35701f 4789 djSP;
693762b4 4790#ifdef HAS_SETSERVENT
76e3520e 4791 PerlSock_setservent(TOPi);
a0d0e21e
LW		 4792 RETSETYES;
4793#else
cea2e8a9 4794 DIE(aTHX_ PL_no_sock_func, "setservent");
a0d0e21e
LW		 4795#endif
4796}
4797
4798PP(pp_ehostent)
4799{
4e35701f 4800 djSP;
693762b4 4801#ifdef HAS_ENDHOSTENT
76e3520e 4802 PerlSock_endhostent();
924508f0 4803 EXTEND(SP,1);
a0d0e21e
LW		 4804 RETPUSHYES;
4805#else
cea2e8a9 4806 DIE(aTHX_ PL_no_sock_func, "endhostent");
a0d0e21e
LW		 4807#endif
4808}
4809
4810PP(pp_enetent)
4811{
4e35701f 4812 djSP;
693762b4 4813#ifdef HAS_ENDNETENT
76e3520e 4814 PerlSock_endnetent();
924508f0 4815 EXTEND(SP,1);
a0d0e21e
LW		 4816 RETPUSHYES;
4817#else
cea2e8a9 4818 DIE(aTHX_ PL_no_sock_func, "endnetent");
a0d0e21e
LW		 4819#endif
4820}
4821
4822PP(pp_eprotoent)
4823{
4e35701f 4824 djSP;
693762b4 4825#ifdef HAS_ENDPROTOENT
76e3520e 4826 PerlSock_endprotoent();
924508f0 4827 EXTEND(SP,1);
a0d0e21e
LW		 4828 RETPUSHYES;
4829#else
cea2e8a9 4830 DIE(aTHX_ PL_no_sock_func, "endprotoent");
a0d0e21e
LW		 4831#endif
4832}
4833
4834PP(pp_eservent)
4835{
4e35701f 4836 djSP;
693762b4 4837#ifdef HAS_ENDSERVENT
76e3520e 4838 PerlSock_endservent();
924508f0 4839 EXTEND(SP,1);
a0d0e21e
LW		 4840 RETPUSHYES;
4841#else
cea2e8a9 4842 DIE(aTHX_ PL_no_sock_func, "endservent");
a0d0e21e
LW		 4843#endif
4844}
4845
4846PP(pp_gpwnam)
4847{
4848#ifdef HAS_PASSWD
cea2e8a9 4849 return pp_gpwent();
a0d0e21e 4850#else
cea2e8a9 4851 DIE(aTHX_ PL_no_func, "getpwnam");
a0d0e21e
LW		 4852#endif
4853}
4854
4855PP(pp_gpwuid)
4856{
4857#ifdef HAS_PASSWD
cea2e8a9 4858 return pp_gpwent();
a0d0e21e 4859#else
cea2e8a9 4860 DIE(aTHX_ PL_no_func, "getpwuid");
a0d0e21e
LW		 4861#endif
4862}
4863
4864PP(pp_gpwent)
4865{
4e35701f 4866 djSP;
0994c4d0 4867#ifdef HAS_PASSWD
533c011a 4868 I32 which = PL_op->op_type;
a0d0e21e 4869 register SV *sv;
2d8e6c8d 4870 STRLEN n_a;
e3aefe8d 4871 struct passwd *pwent = NULL;
301e8125 4872 /*
bcf53261
JH		 4873 * We currently support only the SysV getsp* shadow password interface.
4874 * The interface is declared in <shadow.h> and often one needs to link
4875 * with -lsecurity or some such.
4876 * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
4877 * (and SCO?)
4878 *
4879 * AIX getpwnam() is clever enough to return the encrypted password
4880 * only if the caller (euid?) is root.
4881 *
4882 * There are at least two other shadow password APIs. Many platforms
4883 * seem to contain more than one interface for accessing the shadow
4884 * password databases, possibly for compatibility reasons.
3813c136 4885 * The getsp*() is by far he simplest one, the other two interfaces
bcf53261
JH		 4886 * are much more complicated, but also very similar to each other.
4887 *
4888 * <sys/types.h>
4889 * <sys/security.h>
4890 * <prot.h>
4891 * struct pr_passwd *getprpw*();
4892 * The password is in
3813c136
JH		 4893 * char getprpw*(...).ufld.fd_encrypt[]
4894 * Mention HAS_GETPRPWNAM here so that Configure probes for it.
bcf53261
JH		 4895 *
4896 * <sys/types.h>
4897 * <sys/security.h>
4898 * <prot.h>
4899 * struct es_passwd *getespw*();
4900 * The password is in
4901 * char *(getespw*(...).ufld.fd_encrypt)
3813c136 4902 * Mention HAS_GETESPWNAM here so that Configure probes for it.
bcf53261 4903 *
3813c136 4904 * Mention I_PROT here so that Configure probes for it.
bcf53261
JH		 4905 *
4906 * In HP-UX for getprpw*() the manual page claims that one should include
4907 * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
4908 * if one includes <shadow.h> as that includes <hpsecurity.h>,
4909 * and pp_sys.c already includes <shadow.h> if there is such.
3813c136
JH		 4910 *
4911 * Note that <sys/security.h> is already probed for, but currently
4912 * it is only included in special cases.
301e8125 4913 *
bcf53261
JH		 4914 * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
4915 * be preferred interface, even though also the getprpw*() interface
4916 * is available) one needs to link with -lsecurity -ldb -laud -lm.
3813c136
JH		 4917 * One also needs to call set_auth_parameters() in main() before
4918 * doing anything else, whether one is using getespw*() or getprpw*().
4919 *
4920 * Note that accessing the shadow databases can be magnitudes
4921 * slower than accessing the standard databases.
bcf53261
JH		 4922 *
4923 * --jhi
4924 */
a0d0e21e 4925
e3aefe8d
JH		 4926 switch (which) {
4927 case OP_GPWNAM:
4928 pwent = getpwnam(POPpx);
e3aefe8d
JH		 4929 break;
4930 case OP_GPWUID:
4931 pwent = getpwuid((Uid_t)POPi);
4932 break;
4933 case OP_GPWENT:
1883634f 4934# ifdef HAS_GETPWENT
e3aefe8d 4935 pwent = getpwent();
1883634f 4936# else
a45d1c96 4937 DIE(aTHX_ PL_no_func, "getpwent");
1883634f 4938# endif
e3aefe8d
JH		 4939 break;
4940 }
8c0bfa08 4941
a0d0e21e
LW		 4942 EXTEND(SP, 10);
4943 if (GIMME != G_ARRAY) {
4944 PUSHs(sv = sv_newmortal());
4945 if (pwent) {
4946 if (which == OP_GPWNAM)
1883634f 4947# if Uid_t_sign <= 0
1e422769 4948 sv_setiv(sv, (IV)pwent->pw_uid);
1883634f 4949# else
23dcd6c8 4950 sv_setuv(sv, (UV)pwent->pw_uid);
1883634f 4951# endif
a0d0e21e
LW		 4952 else
4953 sv_setpv(sv, pwent->pw_name);
4954 }
4955 RETURN;
4956 }
4957
4958 if (pwent) {
3280af22 4959 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4960 sv_setpv(sv, pwent->pw_name);
6ee623d5 4961
3280af22 4962 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
3813c136
JH		 4963 SvPOK_off(sv);
4964 /* If we have getspnam(), we try to dig up the shadow
4965 * password. If we are underprivileged, the shadow
4966 * interface will set the errno to EACCES or similar,
4967 * and return a null pointer. If this happens, we will
4968 * use the dummy password (usually "*" or "x") from the
4969 * standard password database.
4970 *
4971 * In theory we could skip the shadow call completely
4972 * if euid != 0 but in practice we cannot know which
4973 * security measures are guarding the shadow databases
4974 * on a random platform.
4975 *
4976 * Resist the urge to use additional shadow interfaces.
4977 * Divert the urge to writing an extension instead.
4978 *
4979 * --jhi */
e3aefe8d 4980# ifdef HAS_GETSPNAM
3813c136
JH		 4981 {
4982 struct spwd *spwent;
4983 int saverrno; /* Save and restore errno so that
4984 * underprivileged attempts seem
4985 * to have never made the unsccessful
4986 * attempt to retrieve the shadow password. */
4987
4988 saverrno = errno;
4989 spwent = getspnam(pwent->pw_name);
4990 errno = saverrno;
4991 if (spwent && spwent->sp_pwdp)
4992 sv_setpv(sv, spwent->sp_pwdp);
4993 }
f1066039 4994# endif
e020c87d 4995# ifdef PWPASSWD
3813c136
JH		 4996 if (!SvPOK(sv)) /* Use the standard password, then. */
4997 sv_setpv(sv, pwent->pw_passwd);
e020c87d 4998# endif
3813c136 4999
1883634f 5000# ifndef INCOMPLETE_TAINTS
3813c136
JH		 5001 /* passwd is tainted because user himself can diddle with it.
5002 * admittedly not much and in a very limited way, but nevertheless. */
2959b6e3 5003 SvTAINTED_on(sv);
1883634f 5004# endif
6ee623d5 5005
3280af22 5006 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1883634f 5007# if Uid_t_sign <= 0
1e422769 5008 sv_setiv(sv, (IV)pwent->pw_uid);
1883634f 5009# else
23dcd6c8 5010 sv_setuv(sv, (UV)pwent->pw_uid);
1883634f 5011# endif
6ee623d5 5012
3280af22 5013 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1883634f 5014# if Uid_t_sign <= 0
1e422769 5015 sv_setiv(sv, (IV)pwent->pw_gid);
1883634f 5016# else
23dcd6c8 5017 sv_setuv(sv, (UV)pwent->pw_gid);
1883634f 5018# endif
3813c136
JH		 5019 /* pw_change, pw_quota, and pw_age are mutually exclusive--
5020 * because of the poor interface of the Perl getpw*(),
5021 * not because there's some standard/convention saying so.
5022 * A better interface would have been to return a hash,
5023 * but we are accursed by our history, alas. --jhi. */
3280af22 5024 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1883634f 5025# ifdef PWCHANGE
1e422769 5026 sv_setiv(sv, (IV)pwent->pw_change);
6ee623d5 5027# else
1883634f
JH		 5028# ifdef PWQUOTA
5029 sv_setiv(sv, (IV)pwent->pw_quota);
5030# else
a1757be1 5031# ifdef PWAGE
a0d0e21e 5032 sv_setpv(sv, pwent->pw_age);
a1757be1 5033# endif
6ee623d5
GS		 5034# endif
5035# endif
6ee623d5 5036
3813c136
JH		 5037 /* pw_class and pw_comment are mutually exclusive--.
5038 * see the above note for pw_change, pw_quota, and pw_age. */
3280af22 5039 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1883634f 5040# ifdef PWCLASS
a0d0e21e 5041 sv_setpv(sv, pwent->pw_class);
1883634f
JH		 5042# else
5043# ifdef PWCOMMENT
a0d0e21e 5044 sv_setpv(sv, pwent->pw_comment);
1883634f 5045# endif
6ee623d5 5046# endif
6ee623d5 5047
3280af22 5048 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1883634f 5049# ifdef PWGECOS
a0d0e21e 5050 sv_setpv(sv, pwent->pw_gecos);
1883634f
JH		 5051# endif
5052# ifndef INCOMPLETE_TAINTS
d2719217 5053 /* pw_gecos is tainted because user himself can diddle with it. */
fb73857a 5054 SvTAINTED_on(sv);
1883634f 5055# endif
6ee623d5 5056
3280af22 5057 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 5058 sv_setpv(sv, pwent->pw_dir);
6ee623d5 5059
3280af22 5060 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 5061 sv_setpv(sv, pwent->pw_shell);
1883634f 5062# ifndef INCOMPLETE_TAINTS
4602f195
JH		 5063 /* pw_shell is tainted because user himself can diddle with it. */
5064 SvTAINTED_on(sv);
1883634f 5065# endif
6ee623d5 5066
1883634f 5067# ifdef PWEXPIRE
6b88bc9c 5068 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 5069 sv_setiv(sv, (IV)pwent->pw_expire);
1883634f 5070# endif
a0d0e21e
LW		 5071 }
5072 RETURN;
5073#else
cea2e8a9 5074 DIE(aTHX_ PL_no_func, "getpwent");
a0d0e21e
LW		 5075#endif
5076}
5077
5078PP(pp_spwent)
5079{
4e35701f 5080 djSP;
d493b042 5081#if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
a0d0e21e
LW		 5082 setpwent();
5083 RETPUSHYES;
5084#else
cea2e8a9 5085 DIE(aTHX_ PL_no_func, "setpwent");
a0d0e21e
LW		 5086#endif
5087}
5088
5089PP(pp_epwent)
5090{
4e35701f 5091 djSP;
28e8609d 5092#if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
a0d0e21e
LW		 5093 endpwent();
5094 RETPUSHYES;
5095#else
cea2e8a9 5096 DIE(aTHX_ PL_no_func, "endpwent");
a0d0e21e
LW		 5097#endif
5098}
5099
5100PP(pp_ggrnam)
5101{
5102#ifdef HAS_GROUP
cea2e8a9 5103 return pp_ggrent();
a0d0e21e 5104#else
cea2e8a9 5105 DIE(aTHX_ PL_no_func, "getgrnam");
a0d0e21e
LW		 5106#endif
5107}
5108
5109PP(pp_ggrgid)
5110{
5111#ifdef HAS_GROUP
cea2e8a9 5112 return pp_ggrent();
a0d0e21e 5113#else
cea2e8a9 5114 DIE(aTHX_ PL_no_func, "getgrgid");
a0d0e21e
LW		 5115#endif
5116}
5117
5118PP(pp_ggrent)
5119{
4e35701f 5120 djSP;
0994c4d0 5121#ifdef HAS_GROUP
533c011a 5122 I32 which = PL_op->op_type;
a0d0e21e
LW		 5123 register char **elem;
5124 register SV *sv;
5125 struct group *grent;
2d8e6c8d 5126 STRLEN n_a;
a0d0e21e
LW		 5127
5128 if (which == OP_GGRNAM)
2d8e6c8d 5129 grent = (struct group *)getgrnam(POPpx);
a0d0e21e
LW		 5130 else if (which == OP_GGRGID)
5131 grent = (struct group *)getgrgid(POPi);
5132 else
0994c4d0 5133#ifdef HAS_GETGRENT
a0d0e21e 5134 grent = (struct group *)getgrent();
0994c4d0
JH		 5135#else
5136 DIE(aTHX_ PL_no_func, "getgrent");
5137#endif
a0d0e21e
LW		 5138
5139 EXTEND(SP, 4);
5140 if (GIMME != G_ARRAY) {
5141 PUSHs(sv = sv_newmortal());
5142 if (grent) {
5143 if (which == OP_GGRNAM)
1e422769 5144 sv_setiv(sv, (IV)grent->gr_gid);
a0d0e21e
LW		 5145 else
5146 sv_setpv(sv, grent->gr_name);
5147 }
5148 RETURN;
5149 }
5150
5151 if (grent) {
3280af22 5152 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 5153 sv_setpv(sv, grent->gr_name);
28e8609d 5154
3280af22 5155 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
28e8609d 5156#ifdef GRPASSWD
a0d0e21e 5157 sv_setpv(sv, grent->gr_passwd);
28e8609d
JH		 5158#endif
5159
3280af22 5160 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 5161 sv_setiv(sv, (IV)grent->gr_gid);
28e8609d 5162
3280af22 5163 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 5164 for (elem = grent->gr_mem; elem && *elem; elem++) {
a0d0e21e
LW		 5165 sv_catpv(sv, *elem);
5166 if (elem[1])
5167 sv_catpvn(sv, " ", 1);
5168 }
5169 }
5170
5171 RETURN;
5172#else
cea2e8a9 5173 DIE(aTHX_ PL_no_func, "getgrent");
a0d0e21e
LW		 5174#endif
5175}
5176
5177PP(pp_sgrent)
5178{
4e35701f 5179 djSP;
28e8609d 5180#if defined(HAS_GROUP) && defined(HAS_SETGRENT)
a0d0e21e
LW		 5181 setgrent();
5182 RETPUSHYES;
5183#else
cea2e8a9 5184 DIE(aTHX_ PL_no_func, "setgrent");
a0d0e21e
LW		 5185#endif
5186}
5187
5188PP(pp_egrent)
5189{
4e35701f 5190 djSP;
28e8609d 5191#if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
a0d0e21e
LW		 5192 endgrent();
5193 RETPUSHYES;
5194#else
cea2e8a9 5195 DIE(aTHX_ PL_no_func, "endgrent");
a0d0e21e
LW		 5196#endif
5197}
5198
5199PP(pp_getlogin)
5200{
4e35701f 5201 djSP; dTARGET;
a0d0e21e
LW		 5202#ifdef HAS_GETLOGIN
5203 char *tmps;
5204 EXTEND(SP, 1);
76e3520e 5205 if (!(tmps = PerlProc_getlogin()))
a0d0e21e
LW		 5206 RETPUSHUNDEF;
5207 PUSHp(tmps, strlen(tmps));
5208 RETURN;
5209#else
cea2e8a9 5210 DIE(aTHX_ PL_no_func, "getlogin");
a0d0e21e
LW		 5211#endif
5212}
5213
5214/* Miscellaneous. */
5215
5216PP(pp_syscall)
5217{
d2719217 5218#ifdef HAS_SYSCALL
4e35701f 5219 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW		 5220 register I32 items = SP - MARK;
5221 unsigned long a[20];
5222 register I32 i = 0;
5223 I32 retval = -1;
2d8e6c8d 5224 STRLEN n_a;
a0d0e21e 5225
3280af22 5226 if (PL_tainting) {
a0d0e21e 5227 while (++MARK <= SP) {
bbce6d69 5228 if (SvTAINTED(*MARK)) {
5229 TAINT;
5230 break;
5231 }
a0d0e21e
LW		 5232 }
5233 MARK = ORIGMARK;
5234 TAINT_PROPER("syscall");
5235 }
5236
5237 /* This probably won't work on machines where sizeof(long) != sizeof(int)
5238 * or where sizeof(long) != sizeof(char*). But such machines will
5239 * not likely have syscall implemented either, so who cares?
5240 */
5241 while (++MARK <= SP) {
5242 if (SvNIOK(*MARK) || !i)
5243 a[i++] = SvIV(*MARK);
3280af22 5244 else if (*MARK == &PL_sv_undef)
748a9306 5245 a[i++] = 0;
301e8125 5246 else
2d8e6c8d 5247 a[i++] = (unsigned long)SvPV_force(*MARK, n_a);
a0d0e21e
LW		 5248 if (i > 15)
5249 break;
5250 }
5251 switch (items) {
5252 default:
cea2e8a9 5253 DIE(aTHX_ "Too many args to syscall");
a0d0e21e 5254 case 0:
cea2e8a9 5255 DIE(aTHX_ "Too few args to syscall");
a0d0e21e
LW		 5256 case 1:
5257 retval = syscall(a[0]);
5258 break;
5259 case 2:
5260 retval = syscall(a[0],a[1]);
5261 break;
5262 case 3:
5263 retval = syscall(a[0],a[1],a[2]);
5264 break;
5265 case 4:
5266 retval = syscall(a[0],a[1],a[2],a[3]);
5267 break;
5268 case 5:
5269 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5270 break;
5271 case 6:
5272 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5273 break;
5274 case 7:
5275 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5276 break;
5277 case 8:
5278 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5279 break;
5280#ifdef atarist
5281 case 9:
5282 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5283 break;
5284 case 10:
5285 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
5286 break;
5287 case 11:
5288 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5289 a[10]);
5290 break;
5291 case 12:
5292 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5293 a[10],a[11]);
5294 break;
5295 case 13:
5296 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5297 a[10],a[11],a[12]);
5298 break;
5299 case 14:
5300 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5301 a[10],a[11],a[12],a[13]);
5302 break;
5303#endif /* atarist */
5304 }
5305 SP = ORIGMARK;
5306 PUSHi(retval);
5307 RETURN;
5308#else
cea2e8a9 5309 DIE(aTHX_ PL_no_func, "syscall");
a0d0e21e
LW		 5310#endif
5311}
5312
ff68c719 5313#ifdef FCNTL_EMULATE_FLOCK
301e8125 5314
ff68c719 5315/* XXX Emulate flock() with fcntl().
5316 What's really needed is a good file locking module.
5317*/
5318
cea2e8a9
GS		 5319static int
5320fcntl_emulate_flock(int fd, int operation)
ff68c719 5321{
5322 struct flock flock;
301e8125 5323
ff68c719 5324 switch (operation & ~LOCK_NB) {
5325 case LOCK_SH:
5326 flock.l_type = F_RDLCK;
5327 break;
5328 case LOCK_EX:
5329 flock.l_type = F_WRLCK;
5330 break;
5331 case LOCK_UN:
5332 flock.l_type = F_UNLCK;
5333 break;
5334 default:
5335 errno = EINVAL;
5336 return -1;
5337 }
5338 flock.l_whence = SEEK_SET;
d9b3e12d 5339 flock.l_start = flock.l_len = (Off_t)0;
301e8125 5340
ff68c719 5341 return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5342}
5343
5344#endif /* FCNTL_EMULATE_FLOCK */
5345
5346#ifdef LOCKF_EMULATE_FLOCK
16d20bd9
AD		 5347
5348/* XXX Emulate flock() with lockf(). This is just to increase
5349 portability of scripts. The calls are not completely
5350 interchangeable. What's really needed is a good file
5351 locking module.
5352*/
5353
76c32331 5354/* The lockf() constants might have been defined in <unistd.h>.
5355 Unfortunately, <unistd.h> causes troubles on some mixed
5356 (BSD/POSIX) systems, such as SunOS 4.1.3.
16d20bd9
AD		 5357
5358 Further, the lockf() constants aren't POSIX, so they might not be
5359 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
5360 just stick in the SVID values and be done with it. Sigh.
5361*/
5362
5363# ifndef F_ULOCK
5364# define F_ULOCK 0 /* Unlock a previously locked region */
5365# endif
5366# ifndef F_LOCK
5367# define F_LOCK 1 /* Lock a region for exclusive use */
5368# endif
5369# ifndef F_TLOCK
5370# define F_TLOCK 2 /* Test and lock a region for exclusive use */
5371# endif
5372# ifndef F_TEST
5373# define F_TEST 3 /* Test a region for other processes locks */
5374# endif
5375
cea2e8a9
GS		 5376static int
5377lockf_emulate_flock(int fd, int operation)
16d20bd9
AD		 5378{
5379 int i;
84902520
TB		 5380 int save_errno;
5381 Off_t pos;
5382
5383 /* flock locks entire file so for lockf we need to do the same */
5384 save_errno = errno;
6ad3d225 5385 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
84902520 5386 if (pos > 0) /* is seekable and needs to be repositioned */
6ad3d225 5387 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
08b714dd 5388 pos = -1; /* seek failed, so don't seek back afterwards */
84902520
TB		 5389 errno = save_errno;
5390
16d20bd9
AD		 5391 switch (operation) {
5392
5393 /* LOCK_SH - get a shared lock */
5394 case LOCK_SH:
5395 /* LOCK_EX - get an exclusive lock */
5396 case LOCK_EX:
5397 i = lockf (fd, F_LOCK, 0);
5398 break;
5399
5400 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5401 case LOCK_SH|LOCK_NB:
5402 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5403 case LOCK_EX|LOCK_NB:
5404 i = lockf (fd, F_TLOCK, 0);
5405 if (i == -1)
5406 if ((errno == EAGAIN) || (errno == EACCES))
5407 errno = EWOULDBLOCK;
5408 break;
5409
ff68c719 5410 /* LOCK_UN - unlock (non-blocking is a no-op) */
16d20bd9 5411 case LOCK_UN:
ff68c719 5412 case LOCK_UN|LOCK_NB:
16d20bd9
AD		 5413 i = lockf (fd, F_ULOCK, 0);
5414 break;
5415
5416 /* Default - can't decipher operation */
5417 default:
5418 i = -1;
5419 errno = EINVAL;
5420 break;
5421 }
84902520
TB		 5422
5423 if (pos > 0) /* need to restore position of the handle */
6ad3d225 5424 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
84902520 5425
16d20bd9
AD		 5426 return (i);
5427}
ff68c719 5428
5429#endif /* LOCKF_EMULATE_FLOCK */
Unnamed repository; edit this file 'description' to name the repository.