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