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