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