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