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