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