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