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
More bytecompiler.
[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;
6aa016ca 511 SV *name = Nullsv;
6170680b 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 */
922b1888
GS		 3871 PL_statusvalue = 0;
3872 result = 0;
911d147d 3873 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e 3874 SV *really = *++MARK;
c5be433b 3875 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
a0d0e21e
LW		 3876 }
3877 else if (SP - MARK != 1)
c5be433b 3878 value = (I32)do_aspawn(Nullsv, (void **)MARK, (void **)SP);
a0d0e21e 3879 else {
c5be433b 3880 value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
a0d0e21e 3881 }
922b1888
GS		 3882 if (PL_statusvalue == -1) /* hint that value must be returned as is */
3883 result = 1;
f86702cc 3884 STATUS_NATIVE_SET(value);
a0d0e21e
LW		 3885 do_execfree();
3886 SP = ORIGMARK;
922b1888 3887 PUSHi(result ? value : STATUS_CURRENT);
a0d0e21e
LW		 3888#endif /* !FORK or VMS */
3889 RETURN;
3890}
3891
3892PP(pp_exec)
3893{
4e35701f 3894 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e 3895 I32 value;
2d8e6c8d 3896 STRLEN n_a;
a0d0e21e 3897
45bc9206 3898 PERL_FLUSHALL_FOR_CHILD;
533c011a 3899 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e
LW		 3900 SV *really = *++MARK;
3901 value = (I32)do_aexec(really, MARK, SP);
3902 }
3903 else if (SP - MARK != 1)
3904#ifdef VMS
3905 value = (I32)vms_do_aexec(Nullsv, MARK, SP);
3906#else
092bebab
JH		 3907# ifdef __OPEN_VM
3908 {
c5be433b 3909 (void ) do_aspawn(Nullsv, MARK, SP);
092bebab
JH		 3910 value = 0;
3911 }
3912# else
a0d0e21e 3913 value = (I32)do_aexec(Nullsv, MARK, SP);
092bebab 3914# endif
a0d0e21e
LW		 3915#endif
3916 else {
3280af22 3917 if (PL_tainting) {
2d8e6c8d 3918 char *junk = SvPV(*SP, n_a);
a0d0e21e
LW		 3919 TAINT_ENV();
3920 TAINT_PROPER("exec");
3921 }
3922#ifdef VMS
2d8e6c8d 3923 value = (I32)vms_do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
a0d0e21e 3924#else
092bebab 3925# ifdef __OPEN_VM
c5be433b 3926 (void) do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
092bebab
JH		 3927 value = 0;
3928# else
2d8e6c8d 3929 value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
092bebab 3930# endif
a0d0e21e
LW		 3931#endif
3932 }
146174a9
CB		 3933
3934#if !defined(HAS_FORK) && defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3935 if (value >= 0)
3936 my_exit(value);
3937#endif
3938
a0d0e21e
LW		 3939 SP = ORIGMARK;
3940 PUSHi(value);
3941 RETURN;
3942}
3943
3944PP(pp_kill)
3945{
4e35701f 3946 djSP; dMARK; dTARGET;
a0d0e21e
LW		 3947 I32 value;
3948#ifdef HAS_KILL
533c011a 3949 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 3950 SP = MARK;
3951 PUSHi(value);
3952 RETURN;
3953#else
cea2e8a9 3954 DIE(aTHX_ PL_no_func, "Unsupported function kill");
a0d0e21e
LW		 3955#endif
3956}
3957
3958PP(pp_getppid)
3959{
3960#ifdef HAS_GETPPID
4e35701f 3961 djSP; dTARGET;
a0d0e21e
LW		 3962 XPUSHi( getppid() );
3963 RETURN;
3964#else
cea2e8a9 3965 DIE(aTHX_ PL_no_func, "getppid");
a0d0e21e
LW		 3966#endif
3967}
3968
3969PP(pp_getpgrp)
3970{
3971#ifdef HAS_GETPGRP
4e35701f 3972 djSP; dTARGET;
d8a83dd3 3973 Pid_t pid;
9853a804 3974 Pid_t pgrp;
a0d0e21e
LW		 3975
3976 if (MAXARG < 1)
3977 pid = 0;
3978 else
3979 pid = SvIVx(POPs);
c3293030 3980#ifdef BSD_GETPGRP
9853a804 3981 pgrp = (I32)BSD_GETPGRP(pid);
a0d0e21e 3982#else
146174a9 3983 if (pid != 0 && pid != PerlProc_getpid())
cea2e8a9 3984 DIE(aTHX_ "POSIX getpgrp can't take an argument");
9853a804 3985 pgrp = getpgrp();
a0d0e21e 3986#endif
9853a804 3987 XPUSHi(pgrp);
a0d0e21e
LW		 3988 RETURN;
3989#else
cea2e8a9 3990 DIE(aTHX_ PL_no_func, "getpgrp()");
a0d0e21e
LW		 3991#endif
3992}
3993
3994PP(pp_setpgrp)
3995{
3996#ifdef HAS_SETPGRP
4e35701f 3997 djSP; dTARGET;
d8a83dd3
JH		 3998 Pid_t pgrp;
3999 Pid_t pid;
a0d0e21e
LW		 4000 if (MAXARG < 2) {
4001 pgrp = 0;
4002 pid = 0;
4003 }
4004 else {
4005 pgrp = POPi;
4006 pid = TOPi;
4007 }
4008
4009 TAINT_PROPER("setpgrp");
c3293030
IZ		 4010#ifdef BSD_SETPGRP
4011 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
a0d0e21e 4012#else
146174a9
CB		 4013 if ((pgrp != 0 && pgrp != PerlProc_getpid())
4014 || (pid != 0 && pid != PerlProc_getpid()))
4015 {
4016 DIE(aTHX_ "setpgrp can't take arguments");
4017 }
a0d0e21e
LW		 4018 SETi( setpgrp() >= 0 );
4019#endif /* USE_BSDPGRP */
4020 RETURN;
4021#else
cea2e8a9 4022 DIE(aTHX_ PL_no_func, "setpgrp()");
a0d0e21e
LW		 4023#endif
4024}
4025
4026PP(pp_getpriority)
4027{
4e35701f 4028 djSP; dTARGET;
a0d0e21e
LW		 4029 int which;
4030 int who;
4031#ifdef HAS_GETPRIORITY
4032 who = POPi;
4033 which = TOPi;
4034 SETi( getpriority(which, who) );
4035 RETURN;
4036#else
cea2e8a9 4037 DIE(aTHX_ PL_no_func, "getpriority()");
a0d0e21e
LW		 4038#endif
4039}
4040
4041PP(pp_setpriority)
4042{
4e35701f 4043 djSP; dTARGET;
a0d0e21e
LW		 4044 int which;
4045 int who;
4046 int niceval;
4047#ifdef HAS_SETPRIORITY
4048 niceval = POPi;
4049 who = POPi;
4050 which = TOPi;
4051 TAINT_PROPER("setpriority");
4052 SETi( setpriority(which, who, niceval) >= 0 );
4053 RETURN;
4054#else
cea2e8a9 4055 DIE(aTHX_ PL_no_func, "setpriority()");
a0d0e21e
LW		 4056#endif
4057}
4058
4059/* Time calls. */
4060
4061PP(pp_time)
4062{
4e35701f 4063 djSP; dTARGET;
cbdc8872 4064#ifdef BIG_TIME
4065 XPUSHn( time(Null(Time_t*)) );
4066#else
a0d0e21e 4067 XPUSHi( time(Null(Time_t*)) );
cbdc8872 4068#endif
a0d0e21e
LW		 4069 RETURN;
4070}
4071
cd52b7b2 4072/* XXX The POSIX name is CLK_TCK; it is to be preferred
4073 to HZ. Probably. For now, assume that if the system
4074 defines HZ, it does so correctly. (Will this break
4075 on VMS?)
4076 Probably we ought to use _sysconf(_SC_CLK_TCK), if
4077 it's supported. --AD 9/96.
4078*/
4079
a0d0e21e 4080#ifndef HZ
cd52b7b2 4081# ifdef CLK_TCK
4082# define HZ CLK_TCK
4083# else
4084# define HZ 60
4085# endif
a0d0e21e
LW		 4086#endif
4087
4088PP(pp_tms)
4089{
4e35701f 4090 djSP;
a0d0e21e 4091
55497cff 4092#ifndef HAS_TIMES
cea2e8a9 4093 DIE(aTHX_ "times not implemented");
a0d0e21e
LW		 4094#else
4095 EXTEND(SP, 4);
4096
4097#ifndef VMS
3280af22 4098 (void)PerlProc_times(&PL_timesbuf);
a0d0e21e 4099#else
6b88bc9c 4100 (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */
76e3520e
GS		 4101 /* struct tms, though same data */
4102 /* is returned. */
a0d0e21e
LW		 4103#endif
4104
65202027 4105 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_utime)/HZ)));
a0d0e21e 4106 if (GIMME == G_ARRAY) {
65202027
DS		 4107 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_stime)/HZ)));
4108 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cutime)/HZ)));
4109 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cstime)/HZ)));
a0d0e21e
LW		 4110 }
4111 RETURN;
55497cff 4112#endif /* HAS_TIMES */
a0d0e21e
LW		 4113}
4114
4115PP(pp_localtime)
4116{
cea2e8a9 4117 return pp_gmtime();
a0d0e21e
LW		 4118}
4119
4120PP(pp_gmtime)
4121{
4e35701f 4122 djSP;
a0d0e21e
LW		 4123 Time_t when;
4124 struct tm *tmbuf;
4125 static char *dayname[] = {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4126 static char *monname[] = {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4127 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4128
4129 if (MAXARG < 1)
4130 (void)time(&when);
4131 else
cbdc8872 4132#ifdef BIG_TIME
4133 when = (Time_t)SvNVx(POPs);
4134#else
a0d0e21e 4135 when = (Time_t)SvIVx(POPs);
cbdc8872 4136#endif
a0d0e21e 4137
533c011a 4138 if (PL_op->op_type == OP_LOCALTIME)
a0d0e21e
LW		 4139 tmbuf = localtime(&when);
4140 else
4141 tmbuf = gmtime(&when);
4142
4143 EXTEND(SP, 9);
bbce6d69 4144 EXTEND_MORTAL(9);
a0d0e21e 4145 if (GIMME != G_ARRAY) {
46fc3d4c 4146 SV *tsv;
a0d0e21e
LW		 4147 if (!tmbuf)
4148 RETPUSHUNDEF;
be28567c 4149 tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %d",
f5a29b03
RB		 4150 dayname[tmbuf->tm_wday],
4151 monname[tmbuf->tm_mon],
be28567c
GS		 4152 tmbuf->tm_mday,
4153 tmbuf->tm_hour,
4154 tmbuf->tm_min,
4155 tmbuf->tm_sec,
4156 tmbuf->tm_year + 1900);
46fc3d4c 4157 PUSHs(sv_2mortal(tsv));
a0d0e21e
LW		 4158 }
4159 else if (tmbuf) {
c6419e06
JH		 4160 PUSHs(sv_2mortal(newSViv(tmbuf->tm_sec)));
4161 PUSHs(sv_2mortal(newSViv(tmbuf->tm_min)));
4162 PUSHs(sv_2mortal(newSViv(tmbuf->tm_hour)));
4163 PUSHs(sv_2mortal(newSViv(tmbuf->tm_mday)));
4164 PUSHs(sv_2mortal(newSViv(tmbuf->tm_mon)));
4165 PUSHs(sv_2mortal(newSViv(tmbuf->tm_year)));
4166 PUSHs(sv_2mortal(newSViv(tmbuf->tm_wday)));
4167 PUSHs(sv_2mortal(newSViv(tmbuf->tm_yday)));
4168 PUSHs(sv_2mortal(newSViv(tmbuf->tm_isdst)));
a0d0e21e
LW		 4169 }
4170 RETURN;
4171}
4172
4173PP(pp_alarm)
4174{
4e35701f 4175 djSP; dTARGET;
a0d0e21e
LW		 4176 int anum;
4177#ifdef HAS_ALARM
4178 anum = POPi;
4179 anum = alarm((unsigned int)anum);
4180 EXTEND(SP, 1);
4181 if (anum < 0)
4182 RETPUSHUNDEF;
c6419e06 4183 PUSHi(anum);
a0d0e21e
LW		 4184 RETURN;
4185#else
cea2e8a9 4186 DIE(aTHX_ PL_no_func, "Unsupported function alarm");
a0d0e21e
LW		 4187#endif
4188}
4189
4190PP(pp_sleep)
4191{
4e35701f 4192 djSP; dTARGET;
a0d0e21e
LW		 4193 I32 duration;
4194 Time_t lasttime;
4195 Time_t when;
4196
4197 (void)time(&lasttime);
4198 if (MAXARG < 1)
76e3520e 4199 PerlProc_pause();
a0d0e21e
LW		 4200 else {
4201 duration = POPi;
76e3520e 4202 PerlProc_sleep((unsigned int)duration);
a0d0e21e
LW		 4203 }
4204 (void)time(&when);
4205 XPUSHi(when - lasttime);
4206 RETURN;
4207}
4208
4209/* Shared memory. */
4210
4211PP(pp_shmget)
4212{
cea2e8a9 4213 return pp_semget();
a0d0e21e
LW		 4214}
4215
4216PP(pp_shmctl)
4217{
cea2e8a9 4218 return pp_semctl();
a0d0e21e
LW		 4219}
4220
4221PP(pp_shmread)
4222{
cea2e8a9 4223 return pp_shmwrite();
a0d0e21e
LW		 4224}
4225
4226PP(pp_shmwrite)
4227{
4228#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 4229 djSP; dMARK; dTARGET;
533c011a 4230 I32 value = (I32)(do_shmio(PL_op->op_type, MARK, SP) >= 0);
a0d0e21e
LW		 4231 SP = MARK;
4232 PUSHi(value);
4233 RETURN;
4234#else
cea2e8a9 4235 return pp_semget();
a0d0e21e
LW		 4236#endif
4237}
4238
4239/* Message passing. */
4240
4241PP(pp_msgget)
4242{
cea2e8a9 4243 return pp_semget();
a0d0e21e
LW		 4244}
4245
4246PP(pp_msgctl)
4247{
cea2e8a9 4248 return pp_semctl();
a0d0e21e
LW		 4249}
4250
4251PP(pp_msgsnd)
4252{
4253#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 4254 djSP; dMARK; dTARGET;
a0d0e21e
LW		 4255 I32 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4256 SP = MARK;
4257 PUSHi(value);
4258 RETURN;
4259#else
cea2e8a9 4260 return pp_semget();
a0d0e21e
LW		 4261#endif
4262}
4263
4264PP(pp_msgrcv)
4265{
4266#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 4267 djSP; dMARK; dTARGET;
a0d0e21e
LW		 4268 I32 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4269 SP = MARK;
4270 PUSHi(value);
4271 RETURN;
4272#else
cea2e8a9 4273 return pp_semget();
a0d0e21e
LW		 4274#endif
4275}
4276
4277/* Semaphores. */
4278
4279PP(pp_semget)
4280{
4281#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 4282 djSP; dMARK; dTARGET;
533c011a 4283 int anum = do_ipcget(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 4284 SP = MARK;
4285 if (anum == -1)
4286 RETPUSHUNDEF;
4287 PUSHi(anum);
4288 RETURN;
4289#else
cea2e8a9 4290 DIE(aTHX_ "System V IPC is not implemented on this machine");
a0d0e21e
LW		 4291#endif
4292}
4293
4294PP(pp_semctl)
4295{
4296#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 4297 djSP; dMARK; dTARGET;
533c011a 4298 int anum = do_ipcctl(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 4299 SP = MARK;
4300 if (anum == -1)
4301 RETSETUNDEF;
4302 if (anum != 0) {
4303 PUSHi(anum);
4304 }
4305 else {
8903cb82 4306 PUSHp(zero_but_true, ZBTLEN);
a0d0e21e
LW		 4307 }
4308 RETURN;
4309#else
cea2e8a9 4310 return pp_semget();
a0d0e21e
LW		 4311#endif
4312}
4313
4314PP(pp_semop)
4315{
4316#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 4317 djSP; dMARK; dTARGET;
a0d0e21e
LW		 4318 I32 value = (I32)(do_semop(MARK, SP) >= 0);
4319 SP = MARK;
4320 PUSHi(value);
4321 RETURN;
4322#else
cea2e8a9 4323 return pp_semget();
a0d0e21e
LW		 4324#endif
4325}
4326
4327/* Get system info. */
4328
4329PP(pp_ghbyname)
4330{
693762b4 4331#ifdef HAS_GETHOSTBYNAME
cea2e8a9 4332 return pp_ghostent();
a0d0e21e 4333#else
cea2e8a9 4334 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
a0d0e21e
LW		 4335#endif
4336}
4337
4338PP(pp_ghbyaddr)
4339{
693762b4 4340#ifdef HAS_GETHOSTBYADDR
cea2e8a9 4341 return pp_ghostent();
a0d0e21e 4342#else
cea2e8a9 4343 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
a0d0e21e
LW		 4344#endif
4345}
4346
4347PP(pp_ghostent)
4348{
4e35701f 4349 djSP;
693762b4 4350#if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
533c011a 4351 I32 which = PL_op->op_type;
a0d0e21e
LW		 4352 register char **elem;
4353 register SV *sv;
dc45a647 4354#ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4599a1de
JH		 4355 struct hostent *PerlSock_gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4356 struct hostent *PerlSock_gethostbyname(Netdb_name_t);
6ad3d225 4357 struct hostent *PerlSock_gethostent(void);
a0d0e21e
LW		 4358#endif
4359 struct hostent *hent;
4360 unsigned long len;
2d8e6c8d 4361 STRLEN n_a;
a0d0e21e
LW		 4362
4363 EXTEND(SP, 10);
dc45a647
MB		 4364 if (which == OP_GHBYNAME)
4365#ifdef HAS_GETHOSTBYNAME
2d8e6c8d 4366 hent = PerlSock_gethostbyname(POPpx);
dc45a647 4367#else
cea2e8a9 4368 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
dc45a647 4369#endif
a0d0e21e 4370 else if (which == OP_GHBYADDR) {
dc45a647 4371#ifdef HAS_GETHOSTBYADDR
a0d0e21e 4372 int addrtype = POPi;
748a9306 4373 SV *addrsv = POPs;
a0d0e21e 4374 STRLEN addrlen;
4599a1de 4375 Netdb_host_t addr = (Netdb_host_t) SvPV(addrsv, addrlen);
a0d0e21e 4376
4599a1de 4377 hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
dc45a647 4378#else
cea2e8a9 4379 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
dc45a647 4380#endif
a0d0e21e
LW		 4381 }
4382 else
4383#ifdef HAS_GETHOSTENT
6ad3d225 4384 hent = PerlSock_gethostent();
a0d0e21e 4385#else
cea2e8a9 4386 DIE(aTHX_ PL_no_sock_func, "gethostent");
a0d0e21e
LW		 4387#endif
4388
4389#ifdef HOST_NOT_FOUND
4390 if (!hent)
f86702cc 4391 STATUS_NATIVE_SET(h_errno);
a0d0e21e
LW		 4392#endif
4393
4394 if (GIMME != G_ARRAY) {
4395 PUSHs(sv = sv_newmortal());
4396 if (hent) {
4397 if (which == OP_GHBYNAME) {
fd0af264 4398 if (hent->h_addr)
4399 sv_setpvn(sv, hent->h_addr, hent->h_length);
a0d0e21e
LW		 4400 }
4401 else
4402 sv_setpv(sv, (char*)hent->h_name);
4403 }
4404 RETURN;
4405 }
4406
4407 if (hent) {
3280af22 4408 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4409 sv_setpv(sv, (char*)hent->h_name);
3280af22 4410 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 4411 for (elem = hent->h_aliases; elem && *elem; elem++) {
4412 sv_catpv(sv, *elem);
4413 if (elem[1])
4414 sv_catpvn(sv, " ", 1);
4415 }
3280af22 4416 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4417 sv_setiv(sv, (IV)hent->h_addrtype);
3280af22 4418 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4419 len = hent->h_length;
1e422769 4420 sv_setiv(sv, (IV)len);
a0d0e21e
LW		 4421#ifdef h_addr
4422 for (elem = hent->h_addr_list; elem && *elem; elem++) {
3280af22 4423 XPUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 4424 sv_setpvn(sv, *elem, len);
4425 }
4426#else
6b88bc9c 4427 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
fd0af264 4428 if (hent->h_addr)
4429 sv_setpvn(sv, hent->h_addr, len);
a0d0e21e
LW		 4430#endif /* h_addr */
4431 }
4432 RETURN;
4433#else
cea2e8a9 4434 DIE(aTHX_ PL_no_sock_func, "gethostent");
a0d0e21e
LW		 4435#endif
4436}
4437
4438PP(pp_gnbyname)
4439{
693762b4 4440#ifdef HAS_GETNETBYNAME
cea2e8a9 4441 return pp_gnetent();
a0d0e21e 4442#else
cea2e8a9 4443 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
a0d0e21e
LW		 4444#endif
4445}
4446
4447PP(pp_gnbyaddr)
4448{
693762b4 4449#ifdef HAS_GETNETBYADDR
cea2e8a9 4450 return pp_gnetent();
a0d0e21e 4451#else
cea2e8a9 4452 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
a0d0e21e
LW		 4453#endif
4454}
4455
4456PP(pp_gnetent)
4457{
4e35701f 4458 djSP;
693762b4 4459#if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
533c011a 4460 I32 which = PL_op->op_type;
a0d0e21e
LW		 4461 register char **elem;
4462 register SV *sv;
dc45a647
MB		 4463#ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4464 struct netent *PerlSock_getnetbyaddr(Netdb_net_t, int);
4465 struct netent *PerlSock_getnetbyname(Netdb_name_t);
4466 struct netent *PerlSock_getnetent(void);
8ac85365 4467#endif
a0d0e21e 4468 struct netent *nent;
2d8e6c8d 4469 STRLEN n_a;
a0d0e21e
LW		 4470
4471 if (which == OP_GNBYNAME)
dc45a647 4472#ifdef HAS_GETNETBYNAME
2d8e6c8d 4473 nent = PerlSock_getnetbyname(POPpx);
dc45a647 4474#else
cea2e8a9 4475 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
dc45a647 4476#endif
a0d0e21e 4477 else if (which == OP_GNBYADDR) {
dc45a647 4478#ifdef HAS_GETNETBYADDR
a0d0e21e 4479 int addrtype = POPi;
4599a1de 4480 Netdb_net_t addr = (Netdb_net_t) U_L(POPn);
76e3520e 4481 nent = PerlSock_getnetbyaddr(addr, addrtype);
dc45a647 4482#else
cea2e8a9 4483 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
dc45a647 4484#endif
a0d0e21e
LW		 4485 }
4486 else
dc45a647 4487#ifdef HAS_GETNETENT
76e3520e 4488 nent = PerlSock_getnetent();
dc45a647 4489#else
cea2e8a9 4490 DIE(aTHX_ PL_no_sock_func, "getnetent");
dc45a647 4491#endif
a0d0e21e
LW		 4492
4493 EXTEND(SP, 4);
4494 if (GIMME != G_ARRAY) {
4495 PUSHs(sv = sv_newmortal());
4496 if (nent) {
4497 if (which == OP_GNBYNAME)
1e422769 4498 sv_setiv(sv, (IV)nent->n_net);
a0d0e21e
LW		 4499 else
4500 sv_setpv(sv, nent->n_name);
4501 }
4502 RETURN;
4503 }
4504
4505 if (nent) {
3280af22 4506 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4507 sv_setpv(sv, nent->n_name);
3280af22 4508 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 4509 for (elem = nent->n_aliases; elem && *elem; elem++) {
a0d0e21e
LW		 4510 sv_catpv(sv, *elem);
4511 if (elem[1])
4512 sv_catpvn(sv, " ", 1);
4513 }
3280af22 4514 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4515 sv_setiv(sv, (IV)nent->n_addrtype);
3280af22 4516 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4517 sv_setiv(sv, (IV)nent->n_net);
a0d0e21e
LW		 4518 }
4519
4520 RETURN;
4521#else
cea2e8a9 4522 DIE(aTHX_ PL_no_sock_func, "getnetent");
a0d0e21e
LW		 4523#endif
4524}
4525
4526PP(pp_gpbyname)
4527{
693762b4 4528#ifdef HAS_GETPROTOBYNAME
cea2e8a9 4529 return pp_gprotoent();
a0d0e21e 4530#else
cea2e8a9 4531 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
a0d0e21e
LW		 4532#endif
4533}
4534
4535PP(pp_gpbynumber)
4536{
693762b4 4537#ifdef HAS_GETPROTOBYNUMBER
cea2e8a9 4538 return pp_gprotoent();
a0d0e21e 4539#else
cea2e8a9 4540 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
a0d0e21e
LW		 4541#endif
4542}
4543
4544PP(pp_gprotoent)
4545{
4e35701f 4546 djSP;
693762b4 4547#if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
533c011a 4548 I32 which = PL_op->op_type;
a0d0e21e 4549 register char **elem;
8ac85365 4550 register SV *sv;
dc45a647 4551#ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4599a1de 4552 struct protoent *PerlSock_getprotobyname(Netdb_name_t);
6ad3d225
GS		 4553 struct protoent *PerlSock_getprotobynumber(int);
4554 struct protoent *PerlSock_getprotoent(void);
8ac85365 4555#endif
a0d0e21e 4556 struct protoent *pent;
2d8e6c8d 4557 STRLEN n_a;
a0d0e21e
LW		 4558
4559 if (which == OP_GPBYNAME)
e5c9fcd0 4560#ifdef HAS_GETPROTOBYNAME
2d8e6c8d 4561 pent = PerlSock_getprotobyname(POPpx);
e5c9fcd0 4562#else
cea2e8a9 4563 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
e5c9fcd0 4564#endif
a0d0e21e 4565 else if (which == OP_GPBYNUMBER)
e5c9fcd0 4566#ifdef HAS_GETPROTOBYNUMBER
6ad3d225 4567 pent = PerlSock_getprotobynumber(POPi);
e5c9fcd0 4568#else
cea2e8a9 4569 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
e5c9fcd0 4570#endif
a0d0e21e 4571 else
e5c9fcd0 4572#ifdef HAS_GETPROTOENT
6ad3d225 4573 pent = PerlSock_getprotoent();
e5c9fcd0 4574#else
cea2e8a9 4575 DIE(aTHX_ PL_no_sock_func, "getprotoent");
e5c9fcd0 4576#endif
a0d0e21e
LW		 4577
4578 EXTEND(SP, 3);
4579 if (GIMME != G_ARRAY) {
4580 PUSHs(sv = sv_newmortal());
4581 if (pent) {
4582 if (which == OP_GPBYNAME)
1e422769 4583 sv_setiv(sv, (IV)pent->p_proto);
a0d0e21e
LW		 4584 else
4585 sv_setpv(sv, pent->p_name);
4586 }
4587 RETURN;
4588 }
4589
4590 if (pent) {
3280af22 4591 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4592 sv_setpv(sv, pent->p_name);
3280af22 4593 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 4594 for (elem = pent->p_aliases; elem && *elem; elem++) {
a0d0e21e
LW		 4595 sv_catpv(sv, *elem);
4596 if (elem[1])
4597 sv_catpvn(sv, " ", 1);
4598 }
3280af22 4599 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4600 sv_setiv(sv, (IV)pent->p_proto);
a0d0e21e
LW		 4601 }
4602
4603 RETURN;
4604#else
cea2e8a9 4605 DIE(aTHX_ PL_no_sock_func, "getprotoent");
a0d0e21e
LW		 4606#endif
4607}
4608
4609PP(pp_gsbyname)
4610{
9ec75305 4611#ifdef HAS_GETSERVBYNAME
cea2e8a9 4612 return pp_gservent();
a0d0e21e 4613#else
cea2e8a9 4614 DIE(aTHX_ PL_no_sock_func, "getservbyname");
a0d0e21e
LW		 4615#endif
4616}
4617
4618PP(pp_gsbyport)
4619{
9ec75305 4620#ifdef HAS_GETSERVBYPORT
cea2e8a9 4621 return pp_gservent();
a0d0e21e 4622#else
cea2e8a9 4623 DIE(aTHX_ PL_no_sock_func, "getservbyport");
a0d0e21e
LW		 4624#endif
4625}
4626
4627PP(pp_gservent)
4628{
4e35701f 4629 djSP;
693762b4 4630#if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
533c011a 4631 I32 which = PL_op->op_type;
a0d0e21e
LW		 4632 register char **elem;
4633 register SV *sv;
dc45a647 4634#ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4599a1de
JH		 4635 struct servent *PerlSock_getservbyname(Netdb_name_t, Netdb_name_t);
4636 struct servent *PerlSock_getservbyport(int, Netdb_name_t);
6ad3d225 4637 struct servent *PerlSock_getservent(void);
8ac85365 4638#endif
a0d0e21e 4639 struct servent *sent;
2d8e6c8d 4640 STRLEN n_a;
a0d0e21e
LW		 4641
4642 if (which == OP_GSBYNAME) {
dc45a647 4643#ifdef HAS_GETSERVBYNAME
2d8e6c8d
GS		 4644 char *proto = POPpx;
4645 char *name = POPpx;
a0d0e21e
LW		 4646
4647 if (proto && !*proto)
4648 proto = Nullch;
4649
6ad3d225 4650 sent = PerlSock_getservbyname(name, proto);
dc45a647 4651#else
cea2e8a9 4652 DIE(aTHX_ PL_no_sock_func, "getservbyname");
dc45a647 4653#endif
a0d0e21e
LW		 4654 }
4655 else if (which == OP_GSBYPORT) {
dc45a647 4656#ifdef HAS_GETSERVBYPORT
2d8e6c8d 4657 char *proto = POPpx;
36477c24 4658 unsigned short port = POPu;
a0d0e21e 4659
36477c24 4660#ifdef HAS_HTONS
6ad3d225 4661 port = PerlSock_htons(port);
36477c24 4662#endif
6ad3d225 4663 sent = PerlSock_getservbyport(port, proto);
dc45a647 4664#else
cea2e8a9 4665 DIE(aTHX_ PL_no_sock_func, "getservbyport");
dc45a647 4666#endif
a0d0e21e
LW		 4667 }
4668 else
e5c9fcd0 4669#ifdef HAS_GETSERVENT
6ad3d225 4670 sent = PerlSock_getservent();
e5c9fcd0 4671#else
cea2e8a9 4672 DIE(aTHX_ PL_no_sock_func, "getservent");
e5c9fcd0 4673#endif
a0d0e21e
LW		 4674
4675 EXTEND(SP, 4);
4676 if (GIMME != G_ARRAY) {
4677 PUSHs(sv = sv_newmortal());
4678 if (sent) {
4679 if (which == OP_GSBYNAME) {
4680#ifdef HAS_NTOHS
6ad3d225 4681 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
a0d0e21e 4682#else
1e422769 4683 sv_setiv(sv, (IV)(sent->s_port));
a0d0e21e
LW		 4684#endif
4685 }
4686 else
4687 sv_setpv(sv, sent->s_name);
4688 }
4689 RETURN;
4690 }
4691
4692 if (sent) {
3280af22 4693 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4694 sv_setpv(sv, sent->s_name);
3280af22 4695 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 4696 for (elem = sent->s_aliases; elem && *elem; elem++) {
a0d0e21e
LW		 4697 sv_catpv(sv, *elem);
4698 if (elem[1])
4699 sv_catpvn(sv, " ", 1);
4700 }
3280af22 4701 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4702#ifdef HAS_NTOHS
76e3520e 4703 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
a0d0e21e 4704#else
1e422769 4705 sv_setiv(sv, (IV)(sent->s_port));
a0d0e21e 4706#endif
3280af22 4707 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 4708 sv_setpv(sv, sent->s_proto);
4709 }
4710
4711 RETURN;
4712#else
cea2e8a9 4713 DIE(aTHX_ PL_no_sock_func, "getservent");
a0d0e21e
LW		 4714#endif
4715}
4716
4717PP(pp_shostent)
4718{
4e35701f 4719 djSP;
693762b4 4720#ifdef HAS_SETHOSTENT
76e3520e 4721 PerlSock_sethostent(TOPi);
a0d0e21e
LW		 4722 RETSETYES;
4723#else
cea2e8a9 4724 DIE(aTHX_ PL_no_sock_func, "sethostent");
a0d0e21e
LW		 4725#endif
4726}
4727
4728PP(pp_snetent)
4729{
4e35701f 4730 djSP;
693762b4 4731#ifdef HAS_SETNETENT
76e3520e 4732 PerlSock_setnetent(TOPi);
a0d0e21e
LW		 4733 RETSETYES;
4734#else
cea2e8a9 4735 DIE(aTHX_ PL_no_sock_func, "setnetent");
a0d0e21e
LW		 4736#endif
4737}
4738
4739PP(pp_sprotoent)
4740{
4e35701f 4741 djSP;
693762b4 4742#ifdef HAS_SETPROTOENT
76e3520e 4743 PerlSock_setprotoent(TOPi);
a0d0e21e
LW		 4744 RETSETYES;
4745#else
cea2e8a9 4746 DIE(aTHX_ PL_no_sock_func, "setprotoent");
a0d0e21e
LW		 4747#endif
4748}
4749
4750PP(pp_sservent)
4751{
4e35701f 4752 djSP;
693762b4 4753#ifdef HAS_SETSERVENT
76e3520e 4754 PerlSock_setservent(TOPi);
a0d0e21e
LW		 4755 RETSETYES;
4756#else
cea2e8a9 4757 DIE(aTHX_ PL_no_sock_func, "setservent");
a0d0e21e
LW		 4758#endif
4759}
4760
4761PP(pp_ehostent)
4762{
4e35701f 4763 djSP;
693762b4 4764#ifdef HAS_ENDHOSTENT
76e3520e 4765 PerlSock_endhostent();
924508f0 4766 EXTEND(SP,1);
a0d0e21e
LW		 4767 RETPUSHYES;
4768#else
cea2e8a9 4769 DIE(aTHX_ PL_no_sock_func, "endhostent");
a0d0e21e
LW		 4770#endif
4771}
4772
4773PP(pp_enetent)
4774{
4e35701f 4775 djSP;
693762b4 4776#ifdef HAS_ENDNETENT
76e3520e 4777 PerlSock_endnetent();
924508f0 4778 EXTEND(SP,1);
a0d0e21e
LW		 4779 RETPUSHYES;
4780#else
cea2e8a9 4781 DIE(aTHX_ PL_no_sock_func, "endnetent");
a0d0e21e
LW		 4782#endif
4783}
4784
4785PP(pp_eprotoent)
4786{
4e35701f 4787 djSP;
693762b4 4788#ifdef HAS_ENDPROTOENT
76e3520e 4789 PerlSock_endprotoent();
924508f0 4790 EXTEND(SP,1);
a0d0e21e
LW		 4791 RETPUSHYES;
4792#else
cea2e8a9 4793 DIE(aTHX_ PL_no_sock_func, "endprotoent");
a0d0e21e
LW		 4794#endif
4795}
4796
4797PP(pp_eservent)
4798{
4e35701f 4799 djSP;
693762b4 4800#ifdef HAS_ENDSERVENT
76e3520e 4801 PerlSock_endservent();
924508f0 4802 EXTEND(SP,1);
a0d0e21e
LW		 4803 RETPUSHYES;
4804#else
cea2e8a9 4805 DIE(aTHX_ PL_no_sock_func, "endservent");
a0d0e21e
LW		 4806#endif
4807}
4808
4809PP(pp_gpwnam)
4810{
4811#ifdef HAS_PASSWD
cea2e8a9 4812 return pp_gpwent();
a0d0e21e 4813#else
cea2e8a9 4814 DIE(aTHX_ PL_no_func, "getpwnam");
a0d0e21e
LW		 4815#endif
4816}
4817
4818PP(pp_gpwuid)
4819{
4820#ifdef HAS_PASSWD
cea2e8a9 4821 return pp_gpwent();
a0d0e21e 4822#else
cea2e8a9 4823 DIE(aTHX_ PL_no_func, "getpwuid");
a0d0e21e
LW		 4824#endif
4825}
4826
4827PP(pp_gpwent)
4828{
4e35701f 4829 djSP;
0994c4d0 4830#ifdef HAS_PASSWD
533c011a 4831 I32 which = PL_op->op_type;
a0d0e21e 4832 register SV *sv;
2d8e6c8d 4833 STRLEN n_a;
e3aefe8d 4834 struct passwd *pwent = NULL;
bcf53261
JH		 4835 /*
4836 * We currently support only the SysV getsp* shadow password interface.
4837 * The interface is declared in <shadow.h> and often one needs to link
4838 * with -lsecurity or some such.
4839 * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
4840 * (and SCO?)
4841 *
4842 * AIX getpwnam() is clever enough to return the encrypted password
4843 * only if the caller (euid?) is root.
4844 *
4845 * There are at least two other shadow password APIs. Many platforms
4846 * seem to contain more than one interface for accessing the shadow
4847 * password databases, possibly for compatibility reasons.
3813c136 4848 * The getsp*() is by far he simplest one, the other two interfaces
bcf53261
JH		 4849 * are much more complicated, but also very similar to each other.
4850 *
4851 * <sys/types.h>
4852 * <sys/security.h>
4853 * <prot.h>
4854 * struct pr_passwd *getprpw*();
4855 * The password is in
3813c136
JH		 4856 * char getprpw*(...).ufld.fd_encrypt[]
4857 * Mention HAS_GETPRPWNAM here so that Configure probes for it.
bcf53261
JH		 4858 *
4859 * <sys/types.h>
4860 * <sys/security.h>
4861 * <prot.h>
4862 * struct es_passwd *getespw*();
4863 * The password is in
4864 * char *(getespw*(...).ufld.fd_encrypt)
3813c136 4865 * Mention HAS_GETESPWNAM here so that Configure probes for it.
bcf53261 4866 *
3813c136 4867 * Mention I_PROT here so that Configure probes for it.
bcf53261
JH		 4868 *
4869 * In HP-UX for getprpw*() the manual page claims that one should include
4870 * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
4871 * if one includes <shadow.h> as that includes <hpsecurity.h>,
4872 * and pp_sys.c already includes <shadow.h> if there is such.
3813c136
JH		 4873 *
4874 * Note that <sys/security.h> is already probed for, but currently
4875 * it is only included in special cases.
bcf53261
JH		 4876 *
4877 * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
4878 * be preferred interface, even though also the getprpw*() interface
4879 * is available) one needs to link with -lsecurity -ldb -laud -lm.
3813c136
JH		 4880 * One also needs to call set_auth_parameters() in main() before
4881 * doing anything else, whether one is using getespw*() or getprpw*().
4882 *
4883 * Note that accessing the shadow databases can be magnitudes
4884 * slower than accessing the standard databases.
bcf53261
JH		 4885 *
4886 * --jhi
4887 */
a0d0e21e 4888
e3aefe8d
JH		 4889 switch (which) {
4890 case OP_GPWNAM:
4891 pwent = getpwnam(POPpx);
e3aefe8d
JH		 4892 break;
4893 case OP_GPWUID:
4894 pwent = getpwuid((Uid_t)POPi);
4895 break;
4896 case OP_GPWENT:
1883634f 4897# ifdef HAS_GETPWENT
e3aefe8d 4898 pwent = getpwent();
1883634f 4899# else
a45d1c96 4900 DIE(aTHX_ PL_no_func, "getpwent");
1883634f 4901# endif
e3aefe8d
JH		 4902 break;
4903 }
8c0bfa08 4904
a0d0e21e
LW		 4905 EXTEND(SP, 10);
4906 if (GIMME != G_ARRAY) {
4907 PUSHs(sv = sv_newmortal());
4908 if (pwent) {
4909 if (which == OP_GPWNAM)
1883634f 4910# if Uid_t_sign <= 0
1e422769 4911 sv_setiv(sv, (IV)pwent->pw_uid);
1883634f 4912# else
23dcd6c8 4913 sv_setuv(sv, (UV)pwent->pw_uid);
1883634f 4914# endif
a0d0e21e
LW		 4915 else
4916 sv_setpv(sv, pwent->pw_name);
4917 }
4918 RETURN;
4919 }
4920
4921 if (pwent) {
3280af22 4922 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4923 sv_setpv(sv, pwent->pw_name);
6ee623d5 4924
3280af22 4925 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
3813c136
JH		 4926 SvPOK_off(sv);
4927 /* If we have getspnam(), we try to dig up the shadow
4928 * password. If we are underprivileged, the shadow
4929 * interface will set the errno to EACCES or similar,
4930 * and return a null pointer. If this happens, we will
4931 * use the dummy password (usually "*" or "x") from the
4932 * standard password database.
4933 *
4934 * In theory we could skip the shadow call completely
4935 * if euid != 0 but in practice we cannot know which
4936 * security measures are guarding the shadow databases
4937 * on a random platform.
4938 *
4939 * Resist the urge to use additional shadow interfaces.
4940 * Divert the urge to writing an extension instead.
4941 *
4942 * --jhi */
e3aefe8d 4943# ifdef HAS_GETSPNAM
3813c136
JH		 4944 {
4945 struct spwd *spwent;
4946 int saverrno; /* Save and restore errno so that
4947 * underprivileged attempts seem
4948 * to have never made the unsccessful
4949 * attempt to retrieve the shadow password. */
4950
4951 saverrno = errno;
4952 spwent = getspnam(pwent->pw_name);
4953 errno = saverrno;
4954 if (spwent && spwent->sp_pwdp)
4955 sv_setpv(sv, spwent->sp_pwdp);
4956 }
f1066039 4957# endif
3813c136
JH		 4958 if (!SvPOK(sv)) /* Use the standard password, then. */
4959 sv_setpv(sv, pwent->pw_passwd);
4960
1883634f 4961# ifndef INCOMPLETE_TAINTS
3813c136
JH		 4962 /* passwd is tainted because user himself can diddle with it.
4963 * admittedly not much and in a very limited way, but nevertheless. */
2959b6e3 4964 SvTAINTED_on(sv);
1883634f 4965# endif
6ee623d5 4966
3280af22 4967 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1883634f 4968# if Uid_t_sign <= 0
1e422769 4969 sv_setiv(sv, (IV)pwent->pw_uid);
1883634f 4970# else
23dcd6c8 4971 sv_setuv(sv, (UV)pwent->pw_uid);
1883634f 4972# endif
6ee623d5 4973
3280af22 4974 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1883634f 4975# if Uid_t_sign <= 0
1e422769 4976 sv_setiv(sv, (IV)pwent->pw_gid);
1883634f 4977# else
23dcd6c8 4978 sv_setuv(sv, (UV)pwent->pw_gid);
1883634f 4979# endif
3813c136
JH		 4980 /* pw_change, pw_quota, and pw_age are mutually exclusive--
4981 * because of the poor interface of the Perl getpw*(),
4982 * not because there's some standard/convention saying so.
4983 * A better interface would have been to return a hash,
4984 * but we are accursed by our history, alas. --jhi. */
3280af22 4985 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1883634f 4986# ifdef PWCHANGE
1e422769 4987 sv_setiv(sv, (IV)pwent->pw_change);
6ee623d5 4988# else
1883634f
JH		 4989# ifdef PWQUOTA
4990 sv_setiv(sv, (IV)pwent->pw_quota);
4991# else
a1757be1 4992# ifdef PWAGE
a0d0e21e 4993 sv_setpv(sv, pwent->pw_age);
a1757be1 4994# endif
6ee623d5
GS		 4995# endif
4996# endif
6ee623d5 4997
3813c136
JH		 4998 /* pw_class and pw_comment are mutually exclusive--.
4999 * see the above note for pw_change, pw_quota, and pw_age. */
3280af22 5000 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1883634f 5001# ifdef PWCLASS
a0d0e21e 5002 sv_setpv(sv, pwent->pw_class);
1883634f
JH		 5003# else
5004# ifdef PWCOMMENT
a0d0e21e 5005 sv_setpv(sv, pwent->pw_comment);
1883634f 5006# endif
6ee623d5 5007# endif
6ee623d5 5008
3280af22 5009 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1883634f 5010# ifdef PWGECOS
a0d0e21e 5011 sv_setpv(sv, pwent->pw_gecos);
1883634f
JH		 5012# endif
5013# ifndef INCOMPLETE_TAINTS
d2719217 5014 /* pw_gecos is tainted because user himself can diddle with it. */
fb73857a 5015 SvTAINTED_on(sv);
1883634f 5016# endif
6ee623d5 5017
3280af22 5018 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 5019 sv_setpv(sv, pwent->pw_dir);
6ee623d5 5020
3280af22 5021 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 5022 sv_setpv(sv, pwent->pw_shell);
1883634f 5023# ifndef INCOMPLETE_TAINTS
4602f195
JH		 5024 /* pw_shell is tainted because user himself can diddle with it. */
5025 SvTAINTED_on(sv);
1883634f 5026# endif
6ee623d5 5027
1883634f 5028# ifdef PWEXPIRE
6b88bc9c 5029 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 5030 sv_setiv(sv, (IV)pwent->pw_expire);
1883634f 5031# endif
a0d0e21e
LW		 5032 }
5033 RETURN;
5034#else
cea2e8a9 5035 DIE(aTHX_ PL_no_func, "getpwent");
a0d0e21e
LW		 5036#endif
5037}
5038
5039PP(pp_spwent)
5040{
4e35701f 5041 djSP;
d493b042 5042#if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
a0d0e21e
LW		 5043 setpwent();
5044 RETPUSHYES;
5045#else
cea2e8a9 5046 DIE(aTHX_ PL_no_func, "setpwent");
a0d0e21e
LW		 5047#endif
5048}
5049
5050PP(pp_epwent)
5051{
4e35701f 5052 djSP;
28e8609d 5053#if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
a0d0e21e
LW		 5054 endpwent();
5055 RETPUSHYES;
5056#else
cea2e8a9 5057 DIE(aTHX_ PL_no_func, "endpwent");
a0d0e21e
LW		 5058#endif
5059}
5060
5061PP(pp_ggrnam)
5062{
5063#ifdef HAS_GROUP
cea2e8a9 5064 return pp_ggrent();
a0d0e21e 5065#else
cea2e8a9 5066 DIE(aTHX_ PL_no_func, "getgrnam");
a0d0e21e
LW		 5067#endif
5068}
5069
5070PP(pp_ggrgid)
5071{
5072#ifdef HAS_GROUP
cea2e8a9 5073 return pp_ggrent();
a0d0e21e 5074#else
cea2e8a9 5075 DIE(aTHX_ PL_no_func, "getgrgid");
a0d0e21e
LW		 5076#endif
5077}
5078
5079PP(pp_ggrent)
5080{
4e35701f 5081 djSP;
0994c4d0 5082#ifdef HAS_GROUP
533c011a 5083 I32 which = PL_op->op_type;
a0d0e21e
LW		 5084 register char **elem;
5085 register SV *sv;
5086 struct group *grent;
2d8e6c8d 5087 STRLEN n_a;
a0d0e21e
LW		 5088
5089 if (which == OP_GGRNAM)
2d8e6c8d 5090 grent = (struct group *)getgrnam(POPpx);
a0d0e21e
LW		 5091 else if (which == OP_GGRGID)
5092 grent = (struct group *)getgrgid(POPi);
5093 else
0994c4d0 5094#ifdef HAS_GETGRENT
a0d0e21e 5095 grent = (struct group *)getgrent();
0994c4d0
JH		 5096#else
5097 DIE(aTHX_ PL_no_func, "getgrent");
5098#endif
a0d0e21e
LW		 5099
5100 EXTEND(SP, 4);
5101 if (GIMME != G_ARRAY) {
5102 PUSHs(sv = sv_newmortal());
5103 if (grent) {
5104 if (which == OP_GGRNAM)
1e422769 5105 sv_setiv(sv, (IV)grent->gr_gid);
a0d0e21e
LW		 5106 else
5107 sv_setpv(sv, grent->gr_name);
5108 }
5109 RETURN;
5110 }
5111
5112 if (grent) {
3280af22 5113 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 5114 sv_setpv(sv, grent->gr_name);
28e8609d 5115
3280af22 5116 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
28e8609d 5117#ifdef GRPASSWD
a0d0e21e 5118 sv_setpv(sv, grent->gr_passwd);
28e8609d
JH		 5119#endif
5120
3280af22 5121 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 5122 sv_setiv(sv, (IV)grent->gr_gid);
28e8609d 5123
3280af22 5124 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 5125 for (elem = grent->gr_mem; elem && *elem; elem++) {
a0d0e21e
LW		 5126 sv_catpv(sv, *elem);
5127 if (elem[1])
5128 sv_catpvn(sv, " ", 1);
5129 }
5130 }
5131
5132 RETURN;
5133#else
cea2e8a9 5134 DIE(aTHX_ PL_no_func, "getgrent");
a0d0e21e
LW		 5135#endif
5136}
5137
5138PP(pp_sgrent)
5139{
4e35701f 5140 djSP;
28e8609d 5141#if defined(HAS_GROUP) && defined(HAS_SETGRENT)
a0d0e21e
LW		 5142 setgrent();
5143 RETPUSHYES;
5144#else
cea2e8a9 5145 DIE(aTHX_ PL_no_func, "setgrent");
a0d0e21e
LW		 5146#endif
5147}
5148
5149PP(pp_egrent)
5150{
4e35701f 5151 djSP;
28e8609d 5152#if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
a0d0e21e
LW		 5153 endgrent();
5154 RETPUSHYES;
5155#else
cea2e8a9 5156 DIE(aTHX_ PL_no_func, "endgrent");
a0d0e21e
LW		 5157#endif
5158}
5159
5160PP(pp_getlogin)
5161{
4e35701f 5162 djSP; dTARGET;
a0d0e21e
LW		 5163#ifdef HAS_GETLOGIN
5164 char *tmps;
5165 EXTEND(SP, 1);
76e3520e 5166 if (!(tmps = PerlProc_getlogin()))
a0d0e21e
LW		 5167 RETPUSHUNDEF;
5168 PUSHp(tmps, strlen(tmps));
5169 RETURN;
5170#else
cea2e8a9 5171 DIE(aTHX_ PL_no_func, "getlogin");
a0d0e21e
LW		 5172#endif
5173}
5174
5175/* Miscellaneous. */
5176
5177PP(pp_syscall)
5178{
d2719217 5179#ifdef HAS_SYSCALL
4e35701f 5180 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW		 5181 register I32 items = SP - MARK;
5182 unsigned long a[20];
5183 register I32 i = 0;
5184 I32 retval = -1;
2d8e6c8d 5185 STRLEN n_a;
a0d0e21e 5186
3280af22 5187 if (PL_tainting) {
a0d0e21e 5188 while (++MARK <= SP) {
bbce6d69 5189 if (SvTAINTED(*MARK)) {
5190 TAINT;
5191 break;
5192 }
a0d0e21e
LW		 5193 }
5194 MARK = ORIGMARK;
5195 TAINT_PROPER("syscall");
5196 }
5197
5198 /* This probably won't work on machines where sizeof(long) != sizeof(int)
5199 * or where sizeof(long) != sizeof(char*). But such machines will
5200 * not likely have syscall implemented either, so who cares?
5201 */
5202 while (++MARK <= SP) {
5203 if (SvNIOK(*MARK) || !i)
5204 a[i++] = SvIV(*MARK);
3280af22 5205 else if (*MARK == &PL_sv_undef)
748a9306
LW		 5206 a[i++] = 0;
5207 else
2d8e6c8d 5208 a[i++] = (unsigned long)SvPV_force(*MARK, n_a);
a0d0e21e
LW		 5209 if (i > 15)
5210 break;
5211 }
5212 switch (items) {
5213 default:
cea2e8a9 5214 DIE(aTHX_ "Too many args to syscall");
a0d0e21e 5215 case 0:
cea2e8a9 5216 DIE(aTHX_ "Too few args to syscall");
a0d0e21e
LW		 5217 case 1:
5218 retval = syscall(a[0]);
5219 break;
5220 case 2:
5221 retval = syscall(a[0],a[1]);
5222 break;
5223 case 3:
5224 retval = syscall(a[0],a[1],a[2]);
5225 break;
5226 case 4:
5227 retval = syscall(a[0],a[1],a[2],a[3]);
5228 break;
5229 case 5:
5230 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5231 break;
5232 case 6:
5233 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5234 break;
5235 case 7:
5236 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5237 break;
5238 case 8:
5239 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5240 break;
5241#ifdef atarist
5242 case 9:
5243 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5244 break;
5245 case 10:
5246 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
5247 break;
5248 case 11:
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]);
5251 break;
5252 case 12:
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]);
5255 break;
5256 case 13:
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]);
5259 break;
5260 case 14:
5261 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5262 a[10],a[11],a[12],a[13]);
5263 break;
5264#endif /* atarist */
5265 }
5266 SP = ORIGMARK;
5267 PUSHi(retval);
5268 RETURN;
5269#else
cea2e8a9 5270 DIE(aTHX_ PL_no_func, "syscall");
a0d0e21e
LW		 5271#endif
5272}
5273
ff68c719 5274#ifdef FCNTL_EMULATE_FLOCK
5275
5276/* XXX Emulate flock() with fcntl().
5277 What's really needed is a good file locking module.
5278*/
5279
cea2e8a9
GS		 5280static int
5281fcntl_emulate_flock(int fd, int operation)
ff68c719 5282{
5283 struct flock flock;
5284
5285 switch (operation & ~LOCK_NB) {
5286 case LOCK_SH:
5287 flock.l_type = F_RDLCK;
5288 break;
5289 case LOCK_EX:
5290 flock.l_type = F_WRLCK;
5291 break;
5292 case LOCK_UN:
5293 flock.l_type = F_UNLCK;
5294 break;
5295 default:
5296 errno = EINVAL;
5297 return -1;
5298 }
5299 flock.l_whence = SEEK_SET;
d9b3e12d 5300 flock.l_start = flock.l_len = (Off_t)0;
ff68c719 5301
5302 return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5303}
5304
5305#endif /* FCNTL_EMULATE_FLOCK */
5306
5307#ifdef LOCKF_EMULATE_FLOCK
16d20bd9
AD		 5308
5309/* XXX Emulate flock() with lockf(). This is just to increase
5310 portability of scripts. The calls are not completely
5311 interchangeable. What's really needed is a good file
5312 locking module.
5313*/
5314
76c32331 5315/* The lockf() constants might have been defined in <unistd.h>.
5316 Unfortunately, <unistd.h> causes troubles on some mixed
5317 (BSD/POSIX) systems, such as SunOS 4.1.3.
16d20bd9
AD		 5318
5319 Further, the lockf() constants aren't POSIX, so they might not be
5320 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
5321 just stick in the SVID values and be done with it. Sigh.
5322*/
5323
5324# ifndef F_ULOCK
5325# define F_ULOCK 0 /* Unlock a previously locked region */
5326# endif
5327# ifndef F_LOCK
5328# define F_LOCK 1 /* Lock a region for exclusive use */
5329# endif
5330# ifndef F_TLOCK
5331# define F_TLOCK 2 /* Test and lock a region for exclusive use */
5332# endif
5333# ifndef F_TEST
5334# define F_TEST 3 /* Test a region for other processes locks */
5335# endif
5336
cea2e8a9
GS		 5337static int
5338lockf_emulate_flock(int fd, int operation)
16d20bd9
AD		 5339{
5340 int i;
84902520
TB		 5341 int save_errno;
5342 Off_t pos;
5343
5344 /* flock locks entire file so for lockf we need to do the same */
5345 save_errno = errno;
6ad3d225 5346 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
84902520 5347 if (pos > 0) /* is seekable and needs to be repositioned */
6ad3d225 5348 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
08b714dd 5349 pos = -1; /* seek failed, so don't seek back afterwards */
84902520
TB		 5350 errno = save_errno;
5351
16d20bd9
AD		 5352 switch (operation) {
5353
5354 /* LOCK_SH - get a shared lock */
5355 case LOCK_SH:
5356 /* LOCK_EX - get an exclusive lock */
5357 case LOCK_EX:
5358 i = lockf (fd, F_LOCK, 0);
5359 break;
5360
5361 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5362 case LOCK_SH|LOCK_NB:
5363 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5364 case LOCK_EX|LOCK_NB:
5365 i = lockf (fd, F_TLOCK, 0);
5366 if (i == -1)
5367 if ((errno == EAGAIN) || (errno == EACCES))
5368 errno = EWOULDBLOCK;
5369 break;
5370
ff68c719 5371 /* LOCK_UN - unlock (non-blocking is a no-op) */
16d20bd9 5372 case LOCK_UN:
ff68c719 5373 case LOCK_UN|LOCK_NB:
16d20bd9
AD		 5374 i = lockf (fd, F_ULOCK, 0);
5375 break;
5376
5377 /* Default - can't decipher operation */
5378 default:
5379 i = -1;
5380 errno = EINVAL;
5381 break;
5382 }
84902520
TB		 5383
5384 if (pos > 0) /* need to restore position of the handle */
6ad3d225 5385 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
84902520 5386
16d20bd9
AD		 5387 return (i);
5388}
ff68c719 5389
5390#endif /* LOCKF_EMULATE_FLOCK */
Unnamed repository; edit this file 'description' to name the repository.