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