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