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