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