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