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