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