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