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