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