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