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