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