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