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