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
perldelta: Rmv git relict line
[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 }
c5df3096
Z		 503 else if (SvPOK(ERRSV) && SvCUR(ERRSV)) {
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;
159b6efe 2344 GV * const gv = (MAXARG == 0) ? PL_last_in_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
6f1401dc
DM		 2898#define tryAMAGICftest_MG(chr) STMT_START { \
2899 if ( (SvFLAGS(TOPs) & (SVf_ROK|SVs_GMG)) \
49498caf 2900 && PL_op->op_flags & OPf_KIDS \
6f1401dc
DM		 2901 && S_try_amagic_ftest(aTHX_ chr)) \
2902 return NORMAL; \
2903 } STMT_END
2904
2905STATIC bool
2906S_try_amagic_ftest(pTHX_ char chr) {
2907 dVAR;
2908 dSP;
2909 SV* const arg = TOPs;
2910
2911 assert(chr != '?');
2912 SvGETMAGIC(arg);
2913
49498caf 2914 if (SvAMAGIC(TOPs))
6f1401dc
DM		 2915 {
2916 const char tmpchr = chr;
6f1401dc
DM		 2917 SV * const tmpsv = amagic_call(arg,
2918 newSVpvn_flags(&tmpchr, 1, SVs_TEMP),
2919 ftest_amg, AMGf_unary);
2920
2921 if (!tmpsv)
2922 return FALSE;
2923
2924 SPAGAIN;
2925
bbd91306 2926 if (PL_op->op_private & OPpFT_STACKING) {
6f1401dc
DM		 2927 if (SvTRUE(tmpsv))
2928 /* leave the object alone */
2929 return TRUE;
2930 }
2931
2932 SETs(tmpsv);
2933 PUTBACK;
2934 return TRUE;
2935 }
2936 return FALSE;
2937}
2938
2939
fbb0b3b3
RGS		 2940/* This macro is used by the stacked filetest operators :
2941 * if the previous filetest failed, short-circuit and pass its value.
2942 * Else, discard it from the stack and continue. --rgs
2943 */
2944#define STACKED_FTEST_CHECK if (PL_op->op_private & OPpFT_STACKED) { \
d724f706 2945 if (!SvTRUE(TOPs)) { RETURN; } \
fbb0b3b3
RGS		 2946 else { (void)POPs; PUTBACK; } \
2947 }
2948
a0d0e21e
LW		 2949PP(pp_ftrread)
2950{
97aff369 2951 dVAR;
9cad6237 2952 I32 result;
af9e49b4
NC		 2953 /* Not const, because things tweak this below. Not bool, because there's
2954 no guarantee that OPp_FT_ACCESS is <= CHAR_MAX */
2955#if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
2956 I32 use_access = PL_op->op_private & OPpFT_ACCESS;
2957 /* Giving some sort of initial value silences compilers. */
2958# ifdef R_OK
2959 int access_mode = R_OK;
2960# else
2961 int access_mode = 0;
2962# endif
5ff3f7a4 2963#else
af9e49b4
NC		 2964 /* access_mode is never used, but leaving use_access in makes the
2965 conditional compiling below much clearer. */
2966 I32 use_access = 0;
5ff3f7a4 2967#endif
2dcac756 2968 Mode_t stat_mode = S_IRUSR;
a0d0e21e 2969
af9e49b4 2970 bool effective = FALSE;
07fe7c6a 2971 char opchar = '?';
2a3ff820 2972 dSP;
af9e49b4 2973
7fb13887
BM		 2974 switch (PL_op->op_type) {
2975 case OP_FTRREAD: opchar = 'R'; break;
2976 case OP_FTRWRITE: opchar = 'W'; break;
2977 case OP_FTREXEC: opchar = 'X'; break;
2978 case OP_FTEREAD: opchar = 'r'; break;
2979 case OP_FTEWRITE: opchar = 'w'; break;
2980 case OP_FTEEXEC: opchar = 'x'; break;
2981 }
6f1401dc 2982 tryAMAGICftest_MG(opchar);
7fb13887 2983
fbb0b3b3 2984 STACKED_FTEST_CHECK;
af9e49b4
NC		 2985
2986 switch (PL_op->op_type) {
2987 case OP_FTRREAD:
2988#if !(defined(HAS_ACCESS) && defined(R_OK))
2989 use_access = 0;
2990#endif
2991 break;
2992
2993 case OP_FTRWRITE:
5ff3f7a4 2994#if defined(HAS_ACCESS) && defined(W_OK)
af9e49b4 2995 access_mode = W_OK;
5ff3f7a4 2996#else
af9e49b4 2997 use_access = 0;
5ff3f7a4 2998#endif
af9e49b4
NC		 2999 stat_mode = S_IWUSR;
3000 break;
a0d0e21e 3001
af9e49b4 3002 case OP_FTREXEC:
5ff3f7a4 3003#if defined(HAS_ACCESS) && defined(X_OK)
af9e49b4 3004 access_mode = X_OK;
5ff3f7a4 3005#else
af9e49b4 3006 use_access = 0;
5ff3f7a4 3007#endif
af9e49b4
NC		 3008 stat_mode = S_IXUSR;
3009 break;
a0d0e21e 3010
af9e49b4 3011 case OP_FTEWRITE:
faee0e31 3012#ifdef PERL_EFF_ACCESS
af9e49b4 3013 access_mode = W_OK;
5ff3f7a4 3014#endif
af9e49b4 3015 stat_mode = S_IWUSR;
7fb13887 3016 /* fall through */
a0d0e21e 3017
af9e49b4
NC		 3018 case OP_FTEREAD:
3019#ifndef PERL_EFF_ACCESS
3020 use_access = 0;
3021#endif
3022 effective = TRUE;
3023 break;
3024
af9e49b4 3025 case OP_FTEEXEC:
faee0e31 3026#ifdef PERL_EFF_ACCESS
b376053d 3027 access_mode = X_OK;
5ff3f7a4 3028#else
af9e49b4 3029 use_access = 0;
5ff3f7a4 3030#endif
af9e49b4
NC		 3031 stat_mode = S_IXUSR;
3032 effective = TRUE;
3033 break;
3034 }
a0d0e21e 3035
af9e49b4
NC		 3036 if (use_access) {
3037#if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
2c2f35ab 3038 const char *name = POPpx;
af9e49b4
NC		 3039 if (effective) {
3040# ifdef PERL_EFF_ACCESS
3041 result = PERL_EFF_ACCESS(name, access_mode);
3042# else
3043 DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3044 OP_NAME(PL_op));
3045# endif
3046 }
3047 else {
3048# ifdef HAS_ACCESS
3049 result = access(name, access_mode);
3050# else
3051 DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3052# endif
3053 }
5ff3f7a4
GS		 3054 if (result == 0)
3055 RETPUSHYES;
3056 if (result < 0)
3057 RETPUSHUNDEF;
3058 RETPUSHNO;
af9e49b4 3059#endif
22865c03 3060 }
af9e49b4 3061
40c852de 3062 result = my_stat_flags(0);
22865c03 3063 SPAGAIN;
a0d0e21e
LW		 3064 if (result < 0)
3065 RETPUSHUNDEF;
af9e49b4 3066 if (cando(stat_mode, effective, &PL_statcache))
a0d0e21e
LW		 3067 RETPUSHYES;
3068 RETPUSHNO;
3069}
3070
3071PP(pp_ftis)
3072{
97aff369 3073 dVAR;
fbb0b3b3 3074 I32 result;
d7f0a2f4 3075 const int op_type = PL_op->op_type;
07fe7c6a 3076 char opchar = '?';
2a3ff820 3077 dSP;
07fe7c6a
BM		 3078
3079 switch (op_type) {
3080 case OP_FTIS: opchar = 'e'; break;
3081 case OP_FTSIZE: opchar = 's'; break;
3082 case OP_FTMTIME: opchar = 'M'; break;
3083 case OP_FTCTIME: opchar = 'C'; break;
3084 case OP_FTATIME: opchar = 'A'; break;
3085 }
6f1401dc 3086 tryAMAGICftest_MG(opchar);
07fe7c6a 3087
fbb0b3b3 3088 STACKED_FTEST_CHECK;
7fb13887 3089
40c852de 3090 result = my_stat_flags(0);
fbb0b3b3 3091 SPAGAIN;
a0d0e21e
LW		 3092 if (result < 0)
3093 RETPUSHUNDEF;
d7f0a2f4
NC		 3094 if (op_type == OP_FTIS)
3095 RETPUSHYES;
957b0e1d 3096 {
d7f0a2f4
NC		 3097 /* You can't dTARGET inside OP_FTIS, because you'll get
3098 "panic: pad_sv po" - the op is not flagged to have a target. */
957b0e1d 3099 dTARGET;
d7f0a2f4 3100 switch (op_type) {
957b0e1d
NC		 3101 case OP_FTSIZE:
3102#if Off_t_size > IVSIZE
3103 PUSHn(PL_statcache.st_size);
3104#else
3105 PUSHi(PL_statcache.st_size);
3106#endif
3107 break;
3108 case OP_FTMTIME:
3109 PUSHn( (((NV)PL_basetime - PL_statcache.st_mtime)) / 86400.0 );
3110 break;
3111 case OP_FTATIME:
3112 PUSHn( (((NV)PL_basetime - PL_statcache.st_atime)) / 86400.0 );
3113 break;
3114 case OP_FTCTIME:
3115 PUSHn( (((NV)PL_basetime - PL_statcache.st_ctime)) / 86400.0 );
3116 break;
3117 }
3118 }
3119 RETURN;
a0d0e21e
LW		 3120}
3121
a0d0e21e
LW		 3122PP(pp_ftrowned)
3123{
97aff369 3124 dVAR;
fbb0b3b3 3125 I32 result;
07fe7c6a 3126 char opchar = '?';
2a3ff820 3127 dSP;
17ad201a 3128
7fb13887
BM		 3129 switch (PL_op->op_type) {
3130 case OP_FTROWNED: opchar = 'O'; break;
3131 case OP_FTEOWNED: opchar = 'o'; break;
3132 case OP_FTZERO: opchar = 'z'; break;
3133 case OP_FTSOCK: opchar = 'S'; break;
3134 case OP_FTCHR: opchar = 'c'; break;
3135 case OP_FTBLK: opchar = 'b'; break;
3136 case OP_FTFILE: opchar = 'f'; break;
3137 case OP_FTDIR: opchar = 'd'; break;
3138 case OP_FTPIPE: opchar = 'p'; break;
3139 case OP_FTSUID: opchar = 'u'; break;
3140 case OP_FTSGID: opchar = 'g'; break;
3141 case OP_FTSVTX: opchar = 'k'; break;
3142 }
6f1401dc 3143 tryAMAGICftest_MG(opchar);
7fb13887 3144
1b0124a7
JD		 3145 STACKED_FTEST_CHECK;
3146
17ad201a
NC		 3147 /* I believe that all these three are likely to be defined on most every
3148 system these days. */
3149#ifndef S_ISUID
c410dd6a 3150 if(PL_op->op_type == OP_FTSUID) {
1b0124a7
JD		 3151 if ((PL_op->op_flags & OPf_REF) == 0 && (PL_op->op_private & OPpFT_STACKED) == 0)
3152 (void) POPs;
17ad201a 3153 RETPUSHNO;
c410dd6a 3154 }
17ad201a
NC		 3155#endif
3156#ifndef S_ISGID
c410dd6a 3157 if(PL_op->op_type == OP_FTSGID) {
1b0124a7
JD		 3158 if ((PL_op->op_flags & OPf_REF) == 0 && (PL_op->op_private & OPpFT_STACKED) == 0)
3159 (void) POPs;
17ad201a 3160 RETPUSHNO;
c410dd6a 3161 }
17ad201a
NC		 3162#endif
3163#ifndef S_ISVTX
c410dd6a 3164 if(PL_op->op_type == OP_FTSVTX) {
1b0124a7
JD		 3165 if ((PL_op->op_flags & OPf_REF) == 0 && (PL_op->op_private & OPpFT_STACKED) == 0)
3166 (void) POPs;
17ad201a 3167 RETPUSHNO;
c410dd6a 3168 }
17ad201a
NC		 3169#endif
3170
40c852de 3171 result = my_stat_flags(0);
fbb0b3b3 3172 SPAGAIN;
a0d0e21e
LW		 3173 if (result < 0)
3174 RETPUSHUNDEF;
f1cb2d48
NC		 3175 switch (PL_op->op_type) {
3176 case OP_FTROWNED:
9ab9fa88 3177 if (PL_statcache.st_uid == PL_uid)
f1cb2d48
NC		 3178 RETPUSHYES;
3179 break;
3180 case OP_FTEOWNED:
3181 if (PL_statcache.st_uid == PL_euid)
3182 RETPUSHYES;
3183 break;
3184 case OP_FTZERO:
3185 if (PL_statcache.st_size == 0)
3186 RETPUSHYES;
3187 break;
3188 case OP_FTSOCK:
3189 if (S_ISSOCK(PL_statcache.st_mode))
3190 RETPUSHYES;
3191 break;
3192 case OP_FTCHR:
3193 if (S_ISCHR(PL_statcache.st_mode))
3194 RETPUSHYES;
3195 break;
3196 case OP_FTBLK:
3197 if (S_ISBLK(PL_statcache.st_mode))
3198 RETPUSHYES;
3199 break;
3200 case OP_FTFILE:
3201 if (S_ISREG(PL_statcache.st_mode))
3202 RETPUSHYES;
3203 break;
3204 case OP_FTDIR:
3205 if (S_ISDIR(PL_statcache.st_mode))
3206 RETPUSHYES;
3207 break;
3208 case OP_FTPIPE:
3209 if (S_ISFIFO(PL_statcache.st_mode))
3210 RETPUSHYES;
3211 break;
a0d0e21e 3212#ifdef S_ISUID
17ad201a
NC		 3213 case OP_FTSUID:
3214 if (PL_statcache.st_mode & S_ISUID)
3215 RETPUSHYES;
3216 break;
a0d0e21e 3217#endif
a0d0e21e 3218#ifdef S_ISGID
17ad201a
NC		 3219 case OP_FTSGID:
3220 if (PL_statcache.st_mode & S_ISGID)
3221 RETPUSHYES;
3222 break;
3223#endif
3224#ifdef S_ISVTX
3225 case OP_FTSVTX:
3226 if (PL_statcache.st_mode & S_ISVTX)
3227 RETPUSHYES;
3228 break;
a0d0e21e 3229#endif
17ad201a 3230 }
a0d0e21e
LW		 3231 RETPUSHNO;
3232}
3233
17ad201a 3234PP(pp_ftlink)
a0d0e21e 3235{
97aff369 3236 dVAR;
39644a26 3237 dSP;
500ff13f 3238 I32 result;
07fe7c6a 3239
6f1401dc 3240 tryAMAGICftest_MG('l');
1f26655e 3241 STACKED_FTEST_CHECK;
40c852de 3242 result = my_lstat_flags(0);
500ff13f
BM		 3243 SPAGAIN;
3244
a0d0e21e
LW		 3245 if (result < 0)
3246 RETPUSHUNDEF;
17ad201a 3247 if (S_ISLNK(PL_statcache.st_mode))
a0d0e21e 3248 RETPUSHYES;
a0d0e21e
LW		 3249 RETPUSHNO;
3250}
3251
3252PP(pp_fttty)
3253{
97aff369 3254 dVAR;
39644a26 3255 dSP;
a0d0e21e
LW		 3256 int fd;
3257 GV *gv;
0784aae0 3258 char *name = NULL;
40c852de 3259 STRLEN namelen;
fb73857a 3260
6f1401dc 3261 tryAMAGICftest_MG('t');
07fe7c6a 3262
fbb0b3b3
RGS		 3263 STACKED_FTEST_CHECK;
3264
533c011a 3265 if (PL_op->op_flags & OPf_REF)
146174a9 3266 gv = cGVOP_gv;
e5e154d2 3267 else {
b6cb94c5 3268 SV *tmpsv = POPs;
e5e154d2 3269 if (!(gv = MAYBE_DEREF_GV_nomg(tmpsv))) {
40c852de
DM		 3270 name = SvPV_nomg(tmpsv, namelen);
3271 gv = gv_fetchpvn_flags(name, namelen, SvUTF8(tmpsv), SVt_PVIO);
e5e154d2 3272 }
40c852de 3273 }
fb73857a 3274
a0d0e21e 3275 if (GvIO(gv) && IoIFP(GvIOp(gv)))
760ac839 3276 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
b6cb94c5 3277 else if (name && isDIGIT(*name))
40c852de 3278 fd = atoi(name);
a0d0e21e
LW		 3279 else
3280 RETPUSHUNDEF;
6ad3d225 3281 if (PerlLIO_isatty(fd))
a0d0e21e
LW		 3282 RETPUSHYES;
3283 RETPUSHNO;
3284}
3285
16d20bd9
AD		 3286#if defined(atarist) /* this will work with atariST. Configure will
3287 make guesses for other systems. */
3288# define FILE_base(f) ((f)->_base)
3289# define FILE_ptr(f) ((f)->_ptr)
3290# define FILE_cnt(f) ((f)->_cnt)
3291# define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
a0d0e21e
LW		 3292#endif
3293
3294PP(pp_fttext)
3295{
97aff369 3296 dVAR;
39644a26 3297 dSP;
a0d0e21e
LW		 3298 I32 i;
3299 I32 len;
3300 I32 odd = 0;
3301 STDCHAR tbuf[512];
3302 register STDCHAR *s;
3303 register IO *io;
e5e154d2 3304 register SV *sv = NULL;
5f05dabc 3305 GV *gv;
146174a9 3306 PerlIO *fp;
a0d0e21e 3307
6f1401dc 3308 tryAMAGICftest_MG(PL_op->op_type == OP_FTTEXT ? 'T' : 'B');
07fe7c6a 3309
fbb0b3b3
RGS		 3310 STACKED_FTEST_CHECK;
3311
533c011a 3312 if (PL_op->op_flags & OPf_REF)
6bb6781a 3313 {
146174a9 3314 gv = cGVOP_gv;
6bb6781a
FC		 3315 EXTEND(SP, 1);
3316 }
ba8182f8
FC		 3317 else if (PL_op->op_private & OPpFT_STACKED)
3318 gv = PL_defgv;
e5e154d2 3319 else sv = POPs, gv = MAYBE_DEREF_GV_nomg(sv);
5f05dabc 3320
3321 if (gv) {
3280af22
NIS		 3322 if (gv == PL_defgv) {
3323 if (PL_statgv)
bd5f6c01
FC		 3324 io = SvTYPE(PL_statgv) == SVt_PVIO
3325 ? (IO *)PL_statgv
3326 : GvIO(PL_statgv);
a0d0e21e 3327 else {
a0d0e21e
LW		 3328 goto really_filename;
3329 }
3330 }
3331 else {
3280af22 3332 PL_statgv = gv;
76f68e9b 3333 sv_setpvs(PL_statname, "");
3280af22 3334 io = GvIO(PL_statgv);
a0d0e21e 3335 }
eb4c377a 3336 PL_laststatval = -1;
21a64c3e 3337 PL_laststype = OP_STAT;
a0d0e21e 3338 if (io && IoIFP(io)) {
5f05dabc 3339 if (! PerlIO_has_base(IoIFP(io)))
cea2e8a9 3340 DIE(aTHX_ "-T and -B not implemented on filehandles");
3280af22
NIS		 3341 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3342 if (PL_laststatval < 0)
5f05dabc 3343 RETPUSHUNDEF;
9cbac4c7 3344 if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
533c011a 3345 if (PL_op->op_type == OP_FTTEXT)
a0d0e21e
LW		 3346 RETPUSHNO;
3347 else
3348 RETPUSHYES;
9cbac4c7 3349 }
a20bf0c3 3350 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
760ac839 3351 i = PerlIO_getc(IoIFP(io));
a0d0e21e 3352 if (i != EOF)
760ac839 3353 (void)PerlIO_ungetc(IoIFP(io),i);
a0d0e21e 3354 }
a20bf0c3 3355 if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
a0d0e21e 3356 RETPUSHYES;
a20bf0c3
JH		 3357 len = PerlIO_get_bufsiz(IoIFP(io));
3358 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
760ac839
LW		 3359 /* sfio can have large buffers - limit to 512 */
3360 if (len > 512)
3361 len = 512;
a0d0e21e
LW		 3362 }
3363 else {
2ad48547 3364 SETERRNO(EBADF,RMS_IFI);
3f12cff4 3365 report_evil_fh(gv);
93189314 3366 SETERRNO(EBADF,RMS_IFI);
a0d0e21e
LW		 3367 RETPUSHUNDEF;
3368 }
3369 }
3370 else {
81e9306f 3371 sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
5f05dabc 3372 really_filename:
a0714e2c 3373 PL_statgv = NULL;
aa07b2f6 3374 if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) {
ad2d99e3
FC		 3375 if (!gv) {
3376 PL_laststatval = -1;
3377 PL_laststype = OP_STAT;
3378 }
349d4f2f
NC		 3379 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname),
3380 '\n'))
9014280d 3381 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
a0d0e21e
LW		 3382 RETPUSHUNDEF;
3383 }
ad2d99e3 3384 PL_laststype = OP_STAT;
146174a9
CB		 3385 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3386 if (PL_laststatval < 0) {
3387 (void)PerlIO_close(fp);
5f05dabc 3388 RETPUSHUNDEF;
146174a9 3389 }
bd61b366 3390 PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
146174a9
CB		 3391 len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3392 (void)PerlIO_close(fp);
a0d0e21e 3393 if (len <= 0) {
533c011a 3394 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
a0d0e21e
LW		 3395 RETPUSHNO; /* special case NFS directories */
3396 RETPUSHYES; /* null file is anything */
3397 }
3398 s = tbuf;
3399 }
3400
3401 /* now scan s to look for textiness */
4633a7c4 3402 /* XXX ASCII dependent code */
a0d0e21e 3403
146174a9
CB		 3404#if defined(DOSISH) || defined(USEMYBINMODE)
3405 /* ignore trailing ^Z on short files */
58c0efa5 3406 if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26)
146174a9
CB		 3407 --len;
3408#endif
3409
a0d0e21e
LW		 3410 for (i = 0; i < len; i++, s++) {
3411 if (!*s) { /* null never allowed in text */
3412 odd += len;
3413 break;
3414 }
9d116dd7 3415#ifdef EBCDIC
301e8125 3416 else if (!(isPRINT(*s) || isSPACE(*s)))
9d116dd7
JH		 3417 odd++;
3418#else
146174a9
CB		 3419 else if (*s & 128) {
3420#ifdef USE_LOCALE
2de3dbcc 3421 if (IN_LOCALE_RUNTIME && isALPHA_LC(*s))
b3f66c68
GS		 3422 continue;
3423#endif
3424 /* utf8 characters don't count as odd */
fd400ab9 3425 if (UTF8_IS_START(*s)) {
b3f66c68
GS		 3426 int ulen = UTF8SKIP(s);
3427 if (ulen < len - i) {
3428 int j;
3429 for (j = 1; j < ulen; j++) {
fd400ab9 3430 if (!UTF8_IS_CONTINUATION(s[j]))
b3f66c68
GS		 3431 goto not_utf8;
3432 }
3433 --ulen; /* loop does extra increment */
3434 s += ulen;
3435 i += ulen;
3436 continue;
3437 }
3438 }
3439 not_utf8:
3440 odd++;
146174a9 3441 }
a0d0e21e
LW		 3442 else if (*s < 32 &&
3443 *s != '\n' && *s != '\r' && *s != '\b' &&
3444 *s != '\t' && *s != '\f' && *s != 27)
3445 odd++;
9d116dd7 3446#endif
a0d0e21e
LW		 3447 }
3448
533c011a 3449 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
a0d0e21e
LW		 3450 RETPUSHNO;
3451 else
3452 RETPUSHYES;
3453}
3454
a0d0e21e
LW		 3455/* File calls. */
3456
3457PP(pp_chdir)
3458{
97aff369 3459 dVAR; dSP; dTARGET;
c445ea15 3460 const char *tmps = NULL;
9a957fbc 3461 GV *gv = NULL;
a0d0e21e 3462
c4aca7d0 3463 if( MAXARG == 1 ) {
9a957fbc 3464 SV * const sv = POPs;
d4ac975e
GA		 3465 if (PL_op->op_flags & OPf_SPECIAL) {
3466 gv = gv_fetchsv(sv, 0, SVt_PVIO);
3467 }
2ea1cce7 3468 else if (!(gv = MAYBE_DEREF_GV(sv)))
a0c4bfab 3469 tmps = SvPV_nomg_const_nolen(sv);
c4aca7d0 3470 }
35ae6b54 3471
c4aca7d0 3472 if( !gv && (!tmps || !*tmps) ) {
9a957fbc
AL		 3473 HV * const table = GvHVn(PL_envgv);
3474 SV **svp;
3475
a4fc7abc
AL		 3476 if ( (svp = hv_fetchs(table, "HOME", FALSE))
3477 || (svp = hv_fetchs(table, "LOGDIR", FALSE))
491527d0 3478#ifdef VMS
a4fc7abc 3479 || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
491527d0 3480#endif
35ae6b54
MS		 3481 )
3482 {
3483 if( MAXARG == 1 )
9014280d 3484 deprecate("chdir('') or chdir(undef) as chdir()");
8c074e2a 3485 tmps = SvPV_nolen_const(*svp);
35ae6b54 3486 }
72f496dc 3487 else {
389ec635 3488 PUSHi(0);
b7ab37f8 3489 TAINT_PROPER("chdir");
389ec635
MS		 3490 RETURN;
3491 }
8ea155d1 3492 }
8ea155d1 3493
a0d0e21e 3494 TAINT_PROPER("chdir");
c4aca7d0
GA		 3495 if (gv) {
3496#ifdef HAS_FCHDIR
9a957fbc 3497 IO* const io = GvIO(gv);
c4aca7d0 3498 if (io) {
c08d6937 3499 if (IoDIRP(io)) {
3497a01f 3500 PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
c08d6937
SP		 3501 } else if (IoIFP(io)) {
3502 PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
c4aca7d0
GA		 3503 }
3504 else {
51087808 3505 report_evil_fh(gv);
4dc171f0 3506 SETERRNO(EBADF, RMS_IFI);
c4aca7d0
GA		 3507 PUSHi(0);
3508 }
3509 }
3510 else {
51087808 3511 report_evil_fh(gv);
4dc171f0 3512 SETERRNO(EBADF,RMS_IFI);
c4aca7d0
GA		 3513 PUSHi(0);
3514 }
3515#else
3516 DIE(aTHX_ PL_no_func, "fchdir");
3517#endif
3518 }
3519 else
b8ffc8df 3520 PUSHi( PerlDir_chdir(tmps) >= 0 );
748a9306
LW		 3521#ifdef VMS
3522 /* Clear the DEFAULT element of ENV so we'll get the new value
3523 * in the future. */
6b88bc9c 3524 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
748a9306 3525#endif
a0d0e21e
LW		 3526 RETURN;
3527}
3528
3529PP(pp_chown)
3530{
97aff369 3531 dVAR; dSP; dMARK; dTARGET;
605b9385 3532 const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
76ffd3b9 3533
a0d0e21e 3534 SP = MARK;
b59aed67 3535 XPUSHi(value);
a0d0e21e 3536 RETURN;
a0d0e21e
LW		 3537}
3538
3539PP(pp_chroot)
3540{
a0d0e21e 3541#ifdef HAS_CHROOT
97aff369 3542 dVAR; dSP; dTARGET;
7452cf6a 3543 char * const tmps = POPpx;
a0d0e21e
LW		 3544 TAINT_PROPER("chroot");
3545 PUSHi( chroot(tmps) >= 0 );
3546 RETURN;
3547#else
cea2e8a9 3548 DIE(aTHX_ PL_no_func, "chroot");
a0d0e21e
LW		 3549#endif
3550}
3551
a0d0e21e
LW		 3552PP(pp_rename)
3553{
97aff369 3554 dVAR; dSP; dTARGET;
a0d0e21e 3555 int anum;
7452cf6a
AL		 3556 const char * const tmps2 = POPpconstx;
3557 const char * const tmps = SvPV_nolen_const(TOPs);
a0d0e21e
LW		 3558 TAINT_PROPER("rename");
3559#ifdef HAS_RENAME
baed7233 3560 anum = PerlLIO_rename(tmps, tmps2);
a0d0e21e 3561#else
6b88bc9c 3562 if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
ed969818
W		 3563 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3564 anum = 1;
3565 else {
3654eb6c 3566 if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
ed969818
W		 3567 (void)UNLINK(tmps2);
3568 if (!(anum = link(tmps, tmps2)))
3569 anum = UNLINK(tmps);
3570 }
a0d0e21e
LW		 3571 }
3572#endif
3573 SETi( anum >= 0 );
3574 RETURN;
3575}
3576
ce6987d0 3577#if defined(HAS_LINK) || defined(HAS_SYMLINK)
a0d0e21e
LW		 3578PP(pp_link)
3579{
97aff369 3580 dVAR; dSP; dTARGET;
ce6987d0
NC		 3581 const int op_type = PL_op->op_type;
3582 int result;
a0d0e21e 3583
ce6987d0
NC		 3584# ifndef HAS_LINK
3585 if (op_type == OP_LINK)
3586 DIE(aTHX_ PL_no_func, "link");
3587# endif
3588# ifndef HAS_SYMLINK
3589 if (op_type == OP_SYMLINK)
3590 DIE(aTHX_ PL_no_func, "symlink");
3591# endif
3592
3593 {
7452cf6a
AL		 3594 const char * const tmps2 = POPpconstx;
3595 const char * const tmps = SvPV_nolen_const(TOPs);
ce6987d0
NC		 3596 TAINT_PROPER(PL_op_desc[op_type]);
3597 result =
3598# if defined(HAS_LINK)
3599# if defined(HAS_SYMLINK)
3600 /* Both present - need to choose which. */
3601 (op_type == OP_LINK) ?
3602 PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3603# else
4a8ebb7f
SH		 3604 /* Only have link, so calls to pp_symlink will have DIE()d above. */
3605 PerlLIO_link(tmps, tmps2);
ce6987d0
NC		 3606# endif
3607# else
3608# if defined(HAS_SYMLINK)
4a8ebb7f
SH		 3609 /* Only have symlink, so calls to pp_link will have DIE()d above. */
3610 symlink(tmps, tmps2);
ce6987d0
NC		 3611# endif
3612# endif
3613 }
3614
3615 SETi( result >= 0 );
a0d0e21e 3616 RETURN;
ce6987d0 3617}
a0d0e21e 3618#else
ce6987d0
NC		 3619PP(pp_link)
3620{
3621 /* Have neither. */
3622 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
a0d0e21e 3623}
ce6987d0 3624#endif
a0d0e21e
LW		 3625
3626PP(pp_readlink)
3627{
97aff369 3628 dVAR;
76ffd3b9 3629 dSP;
a0d0e21e 3630#ifdef HAS_SYMLINK
76ffd3b9 3631 dTARGET;
10516c54 3632 const char *tmps;
46fc3d4c 3633 char buf[MAXPATHLEN];
a0d0e21e 3634 int len;
46fc3d4c 3635
fb73857a 3636#ifndef INCOMPLETE_TAINTS
3637 TAINT;
3638#endif
10516c54 3639 tmps = POPpconstx;
97dcea33 3640 len = readlink(tmps, buf, sizeof(buf) - 1);
a0d0e21e
LW		 3641 if (len < 0)
3642 RETPUSHUNDEF;
3643 PUSHp(buf, len);
3644 RETURN;
3645#else
3646 EXTEND(SP, 1);
3647 RETSETUNDEF; /* just pretend it's a normal file */
3648#endif
3649}
3650
3651#if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
ba106d47 3652STATIC int
b464bac0 3653S_dooneliner(pTHX_ const char *cmd, const char *filename)
a0d0e21e 3654{
b464bac0 3655 char * const save_filename = filename;
1e422769 3656 char *cmdline;
3657 char *s;
760ac839 3658 PerlIO *myfp;
1e422769 3659 int anum = 1;
6fca0082 3660 Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
a0d0e21e 3661
7918f24d
NC		 3662 PERL_ARGS_ASSERT_DOONELINER;
3663
6fca0082
SP		 3664 Newx(cmdline, size, char);
3665 my_strlcpy(cmdline, cmd, size);
3666 my_strlcat(cmdline, " ", size);
1e422769 3667 for (s = cmdline + strlen(cmdline); *filename; ) {
a0d0e21e
LW		 3668 *s++ = '\\';
3669 *s++ = *filename++;
3670 }
d1307786
JH		 3671 if (s - cmdline < size)
3672 my_strlcpy(s, " 2>&1", size - (s - cmdline));
6ad3d225 3673 myfp = PerlProc_popen(cmdline, "r");
1e422769 3674 Safefree(cmdline);
3675
a0d0e21e 3676 if (myfp) {
0bcc34c2 3677 SV * const tmpsv = sv_newmortal();
6b88bc9c 3678 /* Need to save/restore 'PL_rs' ?? */
760ac839 3679 s = sv_gets(tmpsv, myfp, 0);
6ad3d225 3680 (void)PerlProc_pclose(myfp);
bd61b366 3681 if (s != NULL) {
1e422769 3682 int e;
3683 for (e = 1;
a0d0e21e 3684#ifdef HAS_SYS_ERRLIST
1e422769 3685 e <= sys_nerr
3686#endif
3687 ; e++)
3688 {
3689 /* you don't see this */
6136c704 3690 const char * const errmsg =
1e422769 3691#ifdef HAS_SYS_ERRLIST
3692 sys_errlist[e]
a0d0e21e 3693#else
1e422769 3694 strerror(e)
a0d0e21e 3695#endif
1e422769 3696 ;
3697 if (!errmsg)
3698 break;
3699 if (instr(s, errmsg)) {
3700 SETERRNO(e,0);
3701 return 0;
3702 }
a0d0e21e 3703 }
748a9306 3704 SETERRNO(0,0);
a0d0e21e
LW		 3705#ifndef EACCES
3706#define EACCES EPERM
3707#endif
1e422769 3708 if (instr(s, "cannot make"))
93189314 3709 SETERRNO(EEXIST,RMS_FEX);
1e422769 3710 else if (instr(s, "existing file"))
93189314 3711 SETERRNO(EEXIST,RMS_FEX);
1e422769 3712 else if (instr(s, "ile exists"))
93189314 3713 SETERRNO(EEXIST,RMS_FEX);
1e422769 3714 else if (instr(s, "non-exist"))
93189314 3715 SETERRNO(ENOENT,RMS_FNF);
1e422769 3716 else if (instr(s, "does not exist"))
93189314 3717 SETERRNO(ENOENT,RMS_FNF);
1e422769 3718 else if (instr(s, "not empty"))
93189314 3719 SETERRNO(EBUSY,SS_DEVOFFLINE);
1e422769 3720 else if (instr(s, "cannot access"))
93189314 3721 SETERRNO(EACCES,RMS_PRV);
a0d0e21e 3722 else
93189314 3723 SETERRNO(EPERM,RMS_PRV);
a0d0e21e
LW		 3724 return 0;
3725 }
3726 else { /* some mkdirs return no failure indication */
6b88bc9c 3727 anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
911d147d 3728 if (PL_op->op_type == OP_RMDIR)
a0d0e21e
LW		 3729 anum = !anum;
3730 if (anum)
748a9306 3731 SETERRNO(0,0);
a0d0e21e 3732 else
93189314 3733 SETERRNO(EACCES,RMS_PRV); /* a guess */
a0d0e21e
LW		 3734 }
3735 return anum;
3736 }
3737 else
3738 return 0;
3739}
3740#endif
3741
0c54f65b
RGS		 3742/* This macro removes trailing slashes from a directory name.
3743 * Different operating and file systems take differently to
3744 * trailing slashes. According to POSIX 1003.1 1996 Edition
3745 * any number of trailing slashes should be allowed.
3746 * Thusly we snip them away so that even non-conforming
3747 * systems are happy.
3748 * We should probably do this "filtering" for all
3749 * the functions that expect (potentially) directory names:
3750 * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3751 * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3752
5c144d81 3753#define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
0c54f65b
RGS		 3754 if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3755 do { \
3756 (len)--; \
3757 } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3758 (tmps) = savepvn((tmps), (len)); \
3759 (copy) = TRUE; \
3760 }
3761
a0d0e21e
LW		 3762PP(pp_mkdir)
3763{
97aff369 3764 dVAR; dSP; dTARGET;
df25ddba 3765 STRLEN len;
5c144d81 3766 const char *tmps;
df25ddba 3767 bool copy = FALSE;
f6c68483 3768 const int mode = (MAXARG > 1 && (TOPs||((void)POPs,0))) ? POPi : 0777;
5a211162 3769
0c54f65b 3770 TRIMSLASHES(tmps,len,copy);
a0d0e21e
LW		 3771
3772 TAINT_PROPER("mkdir");
3773#ifdef HAS_MKDIR
b8ffc8df 3774 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
a0d0e21e 3775#else
0bcc34c2
AL		 3776 {
3777 int oldumask;
a0d0e21e 3778 SETi( dooneliner("mkdir", tmps) );
6ad3d225
GS		 3779 oldumask = PerlLIO_umask(0);
3780 PerlLIO_umask(oldumask);
3781 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
0bcc34c2 3782 }
a0d0e21e 3783#endif
df25ddba
JH		 3784 if (copy)
3785 Safefree(tmps);
a0d0e21e
LW		 3786 RETURN;
3787}
3788
3789PP(pp_rmdir)
3790{
97aff369 3791 dVAR; dSP; dTARGET;
0c54f65b 3792 STRLEN len;
5c144d81 3793 const char *tmps;
0c54f65b 3794 bool copy = FALSE;
a0d0e21e 3795
0c54f65b 3796 TRIMSLASHES(tmps,len,copy);
a0d0e21e
LW		 3797 TAINT_PROPER("rmdir");
3798#ifdef HAS_RMDIR
b8ffc8df 3799 SETi( PerlDir_rmdir(tmps) >= 0 );
a0d0e21e 3800#else
0c54f65b 3801 SETi( dooneliner("rmdir", tmps) );
a0d0e21e 3802#endif
0c54f65b
RGS		 3803 if (copy)
3804 Safefree(tmps);
a0d0e21e
LW		 3805 RETURN;
3806}
3807
3808/* Directory calls. */
3809
3810PP(pp_open_dir)
3811{
a0d0e21e 3812#if defined(Direntry_t) && defined(HAS_READDIR)
97aff369 3813 dVAR; dSP;
7452cf6a 3814 const char * const dirname = POPpconstx;
159b6efe 3815 GV * const gv = MUTABLE_GV(POPs);
7452cf6a 3816 register IO * const io = GvIOn(gv);
a0d0e21e
LW		 3817
3818 if (!io)
3819 goto nope;
3820
a2a5de95 3821 if ((IoIFP(io) || IoOFP(io)))
d1d15184 3822 Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
d0c0e7dd
FC		 3823 "Opening filehandle %"HEKf" also as a directory",
3824 HEKfARG(GvENAME_HEK(gv)) );
a0d0e21e 3825 if (IoDIRP(io))
6ad3d225 3826 PerlDir_close(IoDIRP(io));
b8ffc8df 3827 if (!(IoDIRP(io) = PerlDir_open(dirname)))
a0d0e21e
LW		 3828 goto nope;
3829
3830 RETPUSHYES;
3831nope:
3832 if (!errno)
93189314 3833 SETERRNO(EBADF,RMS_DIR);
a0d0e21e
LW		 3834 RETPUSHUNDEF;
3835#else
cea2e8a9 3836 DIE(aTHX_ PL_no_dir_func, "opendir");
a0d0e21e
LW		 3837#endif
3838}
3839
3840PP(pp_readdir)
3841{
34b7f128
AMS		 3842#if !defined(Direntry_t) || !defined(HAS_READDIR)
3843 DIE(aTHX_ PL_no_dir_func, "readdir");
3844#else
fd8cd3a3 3845#if !defined(I_DIRENT) && !defined(VMS)
20ce7b12 3846 Direntry_t *readdir (DIR *);
a0d0e21e 3847#endif
97aff369 3848 dVAR;
34b7f128
AMS		 3849 dSP;
3850
3851 SV *sv;
f54cb97a 3852 const I32 gimme = GIMME;
159b6efe 3853 GV * const gv = MUTABLE_GV(POPs);
7452cf6a
AL		 3854 register const Direntry_t *dp;
3855 register IO * const io = GvIOn(gv);
a0d0e21e 3856
3b7fbd4a 3857 if (!io || !IoDIRP(io)) {
a2a5de95 3858 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
d0c0e7dd
FC		 3859 "readdir() attempted on invalid dirhandle %"HEKf,
3860 HEKfARG(GvENAME_HEK(gv)));
3b7fbd4a
SP		 3861 goto nope;
3862 }
a0d0e21e 3863
34b7f128
AMS		 3864 do {
3865 dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
3866 if (!dp)
3867 break;
a0d0e21e 3868#ifdef DIRNAMLEN
34b7f128 3869 sv = newSVpvn(dp->d_name, dp->d_namlen);
a0d0e21e 3870#else
34b7f128 3871 sv = newSVpv(dp->d_name, 0);
fb73857a 3872#endif
3873#ifndef INCOMPLETE_TAINTS
34b7f128
AMS		 3874 if (!(IoFLAGS(io) & IOf_UNTAINT))
3875 SvTAINTED_on(sv);
a0d0e21e 3876#endif
6e449a3a 3877 mXPUSHs(sv);
a79db61d 3878 } while (gimme == G_ARRAY);
34b7f128
AMS		 3879
3880 if (!dp && gimme != G_ARRAY)
3881 goto nope;
3882
a0d0e21e
LW		 3883 RETURN;
3884
3885nope:
3886 if (!errno)
93189314 3887 SETERRNO(EBADF,RMS_ISI);
a0d0e21e
LW		 3888 if (GIMME == G_ARRAY)
3889 RETURN;
3890 else
3891 RETPUSHUNDEF;
a0d0e21e
LW		 3892#endif
3893}
3894
3895PP(pp_telldir)
3896{
a0d0e21e 3897#if defined(HAS_TELLDIR) || defined(telldir)
27da23d5 3898 dVAR; dSP; dTARGET;
968dcd91
JH		 3899 /* XXX does _anyone_ need this? --AD 2/20/1998 */
3900 /* XXX netbsd still seemed to.
3901 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3902 --JHI 1999-Feb-02 */
3903# if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
20ce7b12 3904 long telldir (DIR *);
dfe9444c 3905# endif
159b6efe 3906 GV * const gv = MUTABLE_GV(POPs);
7452cf6a 3907 register IO * const io = GvIOn(gv);
a0d0e21e 3908
abc7ecad 3909 if (!io || !IoDIRP(io)) {
a2a5de95 3910 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
d0c0e7dd
FC		 3911 "telldir() attempted on invalid dirhandle %"HEKf,
3912 HEKfARG(GvENAME_HEK(gv)));
abc7ecad
SP		 3913 goto nope;
3914 }
a0d0e21e 3915
6ad3d225 3916 PUSHi( PerlDir_tell(IoDIRP(io)) );
a0d0e21e
LW		 3917 RETURN;
3918nope:
3919 if (!errno)
93189314 3920 SETERRNO(EBADF,RMS_ISI);
a0d0e21e
LW		 3921 RETPUSHUNDEF;
3922#else
cea2e8a9 3923 DIE(aTHX_ PL_no_dir_func, "telldir");
a0d0e21e
LW		 3924#endif
3925}
3926
3927PP(pp_seekdir)
3928{
a0d0e21e 3929#if defined(HAS_SEEKDIR) || defined(seekdir)
97aff369 3930 dVAR; dSP;
7452cf6a 3931 const long along = POPl;
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 "seekdir() attempted on invalid dirhandle %"HEKf,
3938 HEKfARG(GvENAME_HEK(gv)));
abc7ecad
SP		 3939 goto nope;
3940 }
6ad3d225 3941 (void)PerlDir_seek(IoDIRP(io), along);
a0d0e21e
LW		 3942
3943 RETPUSHYES;
3944nope:
3945 if (!errno)
93189314 3946 SETERRNO(EBADF,RMS_ISI);
a0d0e21e
LW		 3947 RETPUSHUNDEF;
3948#else
cea2e8a9 3949 DIE(aTHX_ PL_no_dir_func, "seekdir");
a0d0e21e
LW		 3950#endif
3951}
3952
3953PP(pp_rewinddir)
3954{
a0d0e21e 3955#if defined(HAS_REWINDDIR) || defined(rewinddir)
97aff369 3956 dVAR; dSP;
159b6efe 3957 GV * const gv = MUTABLE_GV(POPs);
7452cf6a 3958 register IO * const io = GvIOn(gv);
a0d0e21e 3959
abc7ecad 3960 if (!io || !IoDIRP(io)) {
a2a5de95 3961 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
d0c0e7dd
FC		 3962 "rewinddir() attempted on invalid dirhandle %"HEKf,
3963 HEKfARG(GvENAME_HEK(gv)));
a0d0e21e 3964 goto nope;
abc7ecad 3965 }
6ad3d225 3966 (void)PerlDir_rewind(IoDIRP(io));
a0d0e21e
LW		 3967 RETPUSHYES;
3968nope:
3969 if (!errno)
93189314 3970 SETERRNO(EBADF,RMS_ISI);
a0d0e21e
LW		 3971 RETPUSHUNDEF;
3972#else
cea2e8a9 3973 DIE(aTHX_ PL_no_dir_func, "rewinddir");
a0d0e21e
LW		 3974#endif
3975}
3976
3977PP(pp_closedir)
3978{
a0d0e21e 3979#if defined(Direntry_t) && defined(HAS_READDIR)
97aff369 3980 dVAR; dSP;
159b6efe 3981 GV * const gv = MUTABLE_GV(POPs);
7452cf6a 3982 register IO * const io = GvIOn(gv);
a0d0e21e 3983
abc7ecad 3984 if (!io || !IoDIRP(io)) {
a2a5de95 3985 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
d0c0e7dd
FC		 3986 "closedir() attempted on invalid dirhandle %"HEKf,
3987 HEKfARG(GvENAME_HEK(gv)));
abc7ecad
SP		 3988 goto nope;
3989 }
a0d0e21e 3990#ifdef VOID_CLOSEDIR
6ad3d225 3991 PerlDir_close(IoDIRP(io));
a0d0e21e 3992#else
6ad3d225 3993 if (PerlDir_close(IoDIRP(io)) < 0) {
748a9306 3994 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
a0d0e21e 3995 goto nope;
748a9306 3996 }
a0d0e21e
LW		 3997#endif
3998 IoDIRP(io) = 0;
3999
4000 RETPUSHYES;
4001nope:
4002 if (!errno)
93189314 4003 SETERRNO(EBADF,RMS_IFI);
a0d0e21e
LW		 4004 RETPUSHUNDEF;
4005#else
cea2e8a9 4006 DIE(aTHX_ PL_no_dir_func, "closedir");
a0d0e21e
LW		 4007#endif
4008}
4009
4010/* Process control. */
4011
4012PP(pp_fork)
4013{
44a8e56a 4014#ifdef HAS_FORK
97aff369 4015 dVAR; dSP; dTARGET;
761237fe 4016 Pid_t childpid;
a0d0e21e
LW		 4017
4018 EXTEND(SP, 1);
45bc9206 4019 PERL_FLUSHALL_FOR_CHILD;
52e18b1f 4020 childpid = PerlProc_fork();
a0d0e21e
LW		 4021 if (childpid < 0)
4022 RETSETUNDEF;
4023 if (!childpid) {
4d76a344
RGS		 4024#ifdef THREADS_HAVE_PIDS
4025 PL_ppid = (IV)getppid();
4026#endif
ca0c25f6 4027#ifdef PERL_USES_PL_PIDSTATUS
3280af22 4028 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
ca0c25f6 4029#endif
a0d0e21e
LW		 4030 }
4031 PUSHi(childpid);
4032 RETURN;
4033#else
146174a9 4034# if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
39644a26 4035 dSP; dTARGET;
146174a9
CB		 4036 Pid_t childpid;
4037
4038 EXTEND(SP, 1);
4039 PERL_FLUSHALL_FOR_CHILD;
4040 childpid = PerlProc_fork();
60fa28ff
GS		 4041 if (childpid == -1)
4042 RETSETUNDEF;
146174a9
CB		 4043 PUSHi(childpid);
4044 RETURN;
4045# else
0322a713 4046 DIE(aTHX_ PL_no_func, "fork");
146174a9 4047# endif
a0d0e21e
LW		 4048#endif
4049}
4050
4051PP(pp_wait)
4052{
e37778c2 4053#if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
97aff369 4054 dVAR; dSP; dTARGET;
761237fe 4055 Pid_t childpid;
a0d0e21e 4056 int argflags;
a0d0e21e 4057
4ffa73a3
JH		 4058 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4059 childpid = wait4pid(-1, &argflags, 0);
4060 else {
4061 while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4062 errno == EINTR) {
4063 PERL_ASYNC_CHECK();
4064 }
0a0ada86 4065 }
68a29c53
GS		 4066# if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4067 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
2fbb330f 4068 STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
68a29c53 4069# else
2fbb330f 4070 STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
68a29c53 4071# endif
44a8e56a 4072 XPUSHi(childpid);
a0d0e21e
LW		 4073 RETURN;
4074#else
0322a713 4075 DIE(aTHX_ PL_no_func, "wait");
a0d0e21e
LW		 4076#endif
4077}
4078
4079PP(pp_waitpid)
4080{
e37778c2 4081#if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
97aff369 4082 dVAR; dSP; dTARGET;
0bcc34c2
AL		 4083 const int optype = POPi;
4084 const Pid_t pid = TOPi;
2ec0bfb3 4085 Pid_t result;
a0d0e21e 4086 int argflags;
a0d0e21e 4087
4ffa73a3 4088 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2ec0bfb3 4089 result = wait4pid(pid, &argflags, optype);
4ffa73a3 4090 else {
2ec0bfb3 4091 while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4ffa73a3
JH		 4092 errno == EINTR) {
4093 PERL_ASYNC_CHECK();
4094 }
0a0ada86 4095 }
68a29c53
GS		 4096# if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4097 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
2fbb330f 4098 STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
68a29c53 4099# else
2fbb330f 4100 STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
68a29c53 4101# endif
2ec0bfb3 4102 SETi(result);
a0d0e21e
LW		 4103 RETURN;
4104#else
0322a713 4105 DIE(aTHX_ PL_no_func, "waitpid");
a0d0e21e
LW		 4106#endif
4107}
4108
4109PP(pp_system)
4110{
97aff369 4111 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
9c12f1e5
RGS		 4112#if defined(__LIBCATAMOUNT__)
4113 PL_statusvalue = -1;
4114 SP = ORIGMARK;
4115 XPUSHi(-1);
4116#else
a0d0e21e 4117 I32 value;
76ffd3b9 4118 int result;
a0d0e21e 4119
bbd7eb8a
RD		 4120 if (PL_tainting) {
4121 TAINT_ENV();
4122 while (++MARK <= SP) {
10516c54 4123 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
5a445156 4124 if (PL_tainted)
bbd7eb8a
RD		 4125 break;
4126 }
4127 MARK = ORIGMARK;
5a445156 4128 TAINT_PROPER("system");
a0d0e21e 4129 }
45bc9206 4130 PERL_FLUSHALL_FOR_CHILD;
273b0206 4131#if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
d7e492a4 4132 {
eb160463
GS		 4133 Pid_t childpid;
4134 int pp[2];
27da23d5 4135 I32 did_pipes = 0;
b1cf9e92
LT		 4136#if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO))
4137 sigset_t newset, oldset;
4138#endif
eb160463
GS		 4139
4140 if (PerlProc_pipe(pp) >= 0)
4141 did_pipes = 1;
b1cf9e92
LT		 4142#if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO))
4143 sigemptyset(&newset);
4144 sigaddset(&newset, SIGCHLD);
4145 sigprocmask(SIG_BLOCK, &newset, &oldset);
4146#endif
eb160463
GS		 4147 while ((childpid = PerlProc_fork()) == -1) {
4148 if (errno != EAGAIN) {
4149 value = -1;
4150 SP = ORIGMARK;
b59aed67 4151 XPUSHi(value);
eb160463
GS		 4152 if (did_pipes) {
4153 PerlLIO_close(pp[0]);
4154 PerlLIO_close(pp[1]);
4155 }
b1cf9e92
LT		 4156#if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO))
4157 sigprocmask(SIG_SETMASK, &oldset, NULL);
4158#endif
eb160463
GS		 4159 RETURN;
4160 }
4161 sleep(5);
4162 }
4163 if (childpid > 0) {
4164 Sigsave_t ihand,qhand; /* place to save signals during system() */
4165 int status;
4166
4167 if (did_pipes)
4168 PerlLIO_close(pp[1]);
64ca3a65 4169#ifndef PERL_MICRO
8aad04aa
JH		 4170 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &ihand);
4171 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
64ca3a65 4172#endif
eb160463
GS		 4173 do {
4174 result = wait4pid(childpid, &status, 0);
4175 } while (result == -1 && errno == EINTR);
64ca3a65 4176#ifndef PERL_MICRO
b1cf9e92
LT		 4177#ifdef HAS_SIGPROCMASK
4178 sigprocmask(SIG_SETMASK, &oldset, NULL);
4179#endif
eb160463
GS		 4180 (void)rsignal_restore(SIGINT, &ihand);
4181 (void)rsignal_restore(SIGQUIT, &qhand);
4182#endif
37038d91 4183 STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
eb160463
GS		 4184 do_execfree(); /* free any memory child malloced on fork */
4185 SP = ORIGMARK;
4186 if (did_pipes) {
4187 int errkid;
bb7a0f54
MHM		 4188 unsigned n = 0;
4189 SSize_t n1;
eb160463
GS		 4190
4191 while (n < sizeof(int)) {
4192 n1 = PerlLIO_read(pp[0],
4193 (void*)(((char*)&errkid)+n),
4194 (sizeof(int)) - n);
4195 if (n1 <= 0)
4196 break;
4197 n += n1;
4198 }
4199 PerlLIO_close(pp[0]);
4200 if (n) { /* Error */
4201 if (n != sizeof(int))
5637ef5b 4202 DIE(aTHX_ "panic: kid popen errno read, n=%u", n);
eb160463 4203 errno = errkid; /* Propagate errno from kid */
37038d91 4204 STATUS_NATIVE_CHILD_SET(-1);
eb160463
GS		 4205 }
4206 }
b59aed67 4207 XPUSHi(STATUS_CURRENT);
eb160463
GS		 4208 RETURN;
4209 }
b1cf9e92
LT		 4210#if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO))
4211 sigprocmask(SIG_SETMASK, &oldset, NULL);
4212#endif
eb160463
GS		 4213 if (did_pipes) {
4214 PerlLIO_close(pp[0]);
d5a9bfb0 4215#if defined(HAS_FCNTL) && defined(F_SETFD)
eb160463 4216 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
d5a9bfb0 4217#endif
eb160463 4218 }
e0a1f643 4219 if (PL_op->op_flags & OPf_STACKED) {
0bcc34c2 4220 SV * const really = *++MARK;
e0a1f643
JH		 4221 value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4222 }
4223 else if (SP - MARK != 1)
a0714e2c 4224 value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
e0a1f643 4225 else {
8c074e2a 4226 value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
e0a1f643
JH		 4227 }
4228 PerlProc__exit(-1);
d5a9bfb0 4229 }
c3293030 4230#else /* ! FORK or VMS or OS/2 */
922b1888
GS		 4231 PL_statusvalue = 0;
4232 result = 0;
911d147d 4233 if (PL_op->op_flags & OPf_STACKED) {
0bcc34c2 4234 SV * const really = *++MARK;
9ec7171b 4235# if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
54725af6
GS		 4236 value = (I32)do_aspawn(really, MARK, SP);
4237# else
c5be433b 4238 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
54725af6 4239# endif
a0d0e21e 4240 }
54725af6 4241 else if (SP - MARK != 1) {
9ec7171b 4242# if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
a0714e2c 4243 value = (I32)do_aspawn(NULL, MARK, SP);
54725af6 4244# else
a0714e2c 4245 value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
54725af6
GS		 4246# endif
4247 }
a0d0e21e 4248 else {
8c074e2a 4249 value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
a0d0e21e 4250 }
922b1888
GS		 4251 if (PL_statusvalue == -1) /* hint that value must be returned as is */
4252 result = 1;
2fbb330f 4253 STATUS_NATIVE_CHILD_SET(value);
a0d0e21e
LW		 4254 do_execfree();
4255 SP = ORIGMARK;
b59aed67 4256 XPUSHi(result ? value : STATUS_CURRENT);
9c12f1e5
RGS		 4257#endif /* !FORK or VMS or OS/2 */
4258#endif
a0d0e21e
LW		 4259 RETURN;
4260}
4261
4262PP(pp_exec)
4263{
97aff369 4264 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW		 4265 I32 value;
4266
bbd7eb8a
RD		 4267 if (PL_tainting) {
4268 TAINT_ENV();
4269 while (++MARK <= SP) {
10516c54 4270 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
5a445156 4271 if (PL_tainted)
bbd7eb8a
RD		 4272 break;
4273 }
4274 MARK = ORIGMARK;
5a445156 4275 TAINT_PROPER("exec");
bbd7eb8a 4276 }
45bc9206 4277 PERL_FLUSHALL_FOR_CHILD;
533c011a 4278 if (PL_op->op_flags & OPf_STACKED) {
0bcc34c2 4279 SV * const really = *++MARK;
a0d0e21e
LW		 4280 value = (I32)do_aexec(really, MARK, SP);
4281 }
4282 else if (SP - MARK != 1)
4283#ifdef VMS
a0714e2c 4284 value = (I32)vms_do_aexec(NULL, MARK, SP);
a0d0e21e 4285#else
092bebab
JH		 4286# ifdef __OPEN_VM
4287 {
a0714e2c 4288 (void ) do_aspawn(NULL, MARK, SP);
092bebab
JH		 4289 value = 0;
4290 }
4291# else
a0714e2c 4292 value = (I32)do_aexec(NULL, MARK, SP);
092bebab 4293# endif
a0d0e21e
LW		 4294#endif
4295 else {
a0d0e21e 4296#ifdef VMS
8c074e2a 4297 value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
a0d0e21e 4298#else
092bebab 4299# ifdef __OPEN_VM
8c074e2a 4300 (void) do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
092bebab
JH		 4301 value = 0;
4302# else
5dd60a52 4303 value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
092bebab 4304# endif
a0d0e21e
LW		 4305#endif
4306 }
146174a9 4307
a0d0e21e 4308 SP = ORIGMARK;
b59aed67 4309 XPUSHi(value);
a0d0e21e
LW		 4310 RETURN;
4311}
4312
a0d0e21e
LW		 4313PP(pp_getppid)
4314{
4315#ifdef HAS_GETPPID
97aff369 4316 dVAR; dSP; dTARGET;
4d76a344 4317# ifdef THREADS_HAVE_PIDS
e39f92a7
RGS		 4318 if (PL_ppid != 1 && getppid() == 1)
4319 /* maybe the parent process has died. Refresh ppid cache */
4320 PL_ppid = 1;
4d76a344
RGS		 4321 XPUSHi( PL_ppid );
4322# else
a0d0e21e 4323 XPUSHi( getppid() );
4d76a344 4324# endif
a0d0e21e
LW		 4325 RETURN;
4326#else
cea2e8a9 4327 DIE(aTHX_ PL_no_func, "getppid");
a0d0e21e
LW		 4328#endif
4329}
4330
4331PP(pp_getpgrp)
4332{
4333#ifdef HAS_GETPGRP
97aff369 4334 dVAR; dSP; dTARGET;
9853a804 4335 Pid_t pgrp;
8af20142
FC		 4336 const Pid_t pid =
4337 (MAXARG < 1) ? 0 : TOPs ? SvIVx(POPs) : ((void)POPs, 0);
a0d0e21e 4338
c3293030 4339#ifdef BSD_GETPGRP
9853a804 4340 pgrp = (I32)BSD_GETPGRP(pid);
a0d0e21e 4341#else
146174a9 4342 if (pid != 0 && pid != PerlProc_getpid())
cea2e8a9 4343 DIE(aTHX_ "POSIX getpgrp can't take an argument");
9853a804 4344 pgrp = getpgrp();
a0d0e21e 4345#endif
9853a804 4346 XPUSHi(pgrp);
a0d0e21e
LW		 4347 RETURN;
4348#else
cea2e8a9 4349 DIE(aTHX_ PL_no_func, "getpgrp()");
a0d0e21e
LW		 4350#endif
4351}
4352
4353PP(pp_setpgrp)
4354{
4355#ifdef HAS_SETPGRP
97aff369 4356 dVAR; dSP; dTARGET;
d8a83dd3
JH		 4357 Pid_t pgrp;
4358 Pid_t pid;
92f2ac5f
FC		 4359 pgrp = MAXARG == 2 && (TOPs||POPs) ? POPi : 0;
4360 if (MAXARG > 0) pid = TOPs && TOPi;
4361 else {
a0d0e21e 4362 pid = 0;
1f200948 4363 XPUSHi(-1);
a0d0e21e 4364 }
a0d0e21e
LW		 4365
4366 TAINT_PROPER("setpgrp");
c3293030
IZ		 4367#ifdef BSD_SETPGRP
4368 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
a0d0e21e 4369#else
146174a9
CB		 4370 if ((pgrp != 0 && pgrp != PerlProc_getpid())
4371 || (pid != 0 && pid != PerlProc_getpid()))
4372 {
4373 DIE(aTHX_ "setpgrp can't take arguments");
4374 }
a0d0e21e
LW		 4375 SETi( setpgrp() >= 0 );
4376#endif /* USE_BSDPGRP */
4377 RETURN;
4378#else
cea2e8a9 4379 DIE(aTHX_ PL_no_func, "setpgrp()");
a0d0e21e
LW		 4380#endif
4381}
4382
8b079db6 4383#if defined(__GLIBC__) && ((__GLIBC__ == 2 && __GLIBC_MINOR__ >= 3) || (__GLIBC__ > 2))
5baa2e4f
RB		 4384# define PRIORITY_WHICH_T(which) (__priority_which_t)which
4385#else
4386# define PRIORITY_WHICH_T(which) which
4387#endif
4388
a0d0e21e
LW		 4389PP(pp_getpriority)
4390{
a0d0e21e 4391#ifdef HAS_GETPRIORITY
97aff369 4392 dVAR; dSP; dTARGET;
0bcc34c2
AL		 4393 const int who = POPi;
4394 const int which = TOPi;
5baa2e4f 4395 SETi( getpriority(PRIORITY_WHICH_T(which), who) );
a0d0e21e
LW		 4396 RETURN;
4397#else
cea2e8a9 4398 DIE(aTHX_ PL_no_func, "getpriority()");
a0d0e21e
LW		 4399#endif
4400}
4401
4402PP(pp_setpriority)
4403{
a0d0e21e 4404#ifdef HAS_SETPRIORITY
97aff369 4405 dVAR; dSP; dTARGET;
0bcc34c2
AL		 4406 const int niceval = POPi;
4407 const int who = POPi;
4408 const int which = TOPi;
a0d0e21e 4409 TAINT_PROPER("setpriority");
5baa2e4f 4410 SETi( setpriority(PRIORITY_WHICH_T(which), who, niceval) >= 0 );
a0d0e21e
LW		 4411 RETURN;
4412#else
cea2e8a9 4413 DIE(aTHX_ PL_no_func, "setpriority()");
a0d0e21e
LW		 4414#endif
4415}
4416
5baa2e4f
RB		 4417#undef PRIORITY_WHICH_T
4418
a0d0e21e
LW		 4419/* Time calls. */
4420
4421PP(pp_time)
4422{
97aff369 4423 dVAR; dSP; dTARGET;
cbdc8872 4424#ifdef BIG_TIME
4608196e 4425 XPUSHn( time(NULL) );
cbdc8872 4426#else
4608196e 4427 XPUSHi( time(NULL) );
cbdc8872 4428#endif
a0d0e21e
LW		 4429 RETURN;
4430}
4431
a0d0e21e
LW		 4432PP(pp_tms)
4433{
9cad6237 4434#ifdef HAS_TIMES
97aff369 4435 dVAR;
39644a26 4436 dSP;
a0d0e21e 4437 EXTEND(SP, 4);
a0d0e21e 4438#ifndef VMS
3280af22 4439 (void)PerlProc_times(&PL_timesbuf);
a0d0e21e 4440#else
6b88bc9c 4441 (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */
76e3520e
GS		 4442 /* struct tms, though same data */
4443 /* is returned. */
a0d0e21e
LW		 4444#endif
4445
6e449a3a 4446 mPUSHn(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick);
a0d0e21e 4447 if (GIMME == G_ARRAY) {
6e449a3a
MHM		 4448 mPUSHn(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick);
4449 mPUSHn(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick);
4450 mPUSHn(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick);
a0d0e21e
LW		 4451 }
4452 RETURN;
9cad6237 4453#else
2f42fcb0
JH		 4454# ifdef PERL_MICRO
4455 dSP;
6e449a3a 4456 mPUSHn(0.0);
2f42fcb0
JH		 4457 EXTEND(SP, 4);
4458 if (GIMME == G_ARRAY) {
6e449a3a
MHM		 4459 mPUSHn(0.0);
4460 mPUSHn(0.0);
4461 mPUSHn(0.0);
2f42fcb0
JH		 4462 }
4463 RETURN;
4464# else
9cad6237 4465 DIE(aTHX_ "times not implemented");
2f42fcb0 4466# endif
55497cff 4467#endif /* HAS_TIMES */
a0d0e21e
LW		 4468}
4469
fc003d4b
MS		 4470/* The 32 bit int year limits the times we can represent to these
4471 boundaries with a few days wiggle room to account for time zone
4472 offsets
4473*/
4474/* Sat Jan 3 00:00:00 -2147481748 */
4475#define TIME_LOWER_BOUND -67768100567755200.0
4476/* Sun Dec 29 12:00:00 2147483647 */
4477#define TIME_UPPER_BOUND 67767976233316800.0
4478
a0d0e21e
LW		 4479PP(pp_gmtime)
4480{
97aff369 4481 dVAR;
39644a26 4482 dSP;
a272e669 4483 Time64_T when;
806a119a
MS		 4484 struct TM tmbuf;
4485 struct TM *err;
a8cb0261 4486 const char *opname = PL_op->op_type == OP_LOCALTIME ? "localtime" : "gmtime";
27da23d5
JH		 4487 static const char * const dayname[] =
4488 {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4489 static const char * const monname[] =
4490 {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4491 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
a0d0e21e 4492
0163043a 4493 if (MAXARG < 1 || (!TOPs && ((void)POPs, 1))) {
a272e669
MS		 4494 time_t now;
4495 (void)time(&now);
4496 when = (Time64_T)now;
4497 }
7315c673 4498 else {
7eb4f9b7 4499 NV input = Perl_floor(POPn);
8efababc 4500 when = (Time64_T)input;
a2a5de95 4501 if (when != input) {
dcbac5bb 4502 /* diag_listed_as: gmtime(%f) too large */
a2a5de95 4503 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
7eb4f9b7 4504 "%s(%.0" NVff ") too large", opname, input);
7315c673
MS		 4505 }
4506 }
a0d0e21e 4507
fc003d4b 4508 if ( TIME_LOWER_BOUND > when ) {
dcbac5bb 4509 /* diag_listed_as: gmtime(%f) too small */
fc003d4b 4510 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
7eb4f9b7 4511 "%s(%.0" NVff ") too small", opname, when);
fc003d4b
MS		 4512 err = NULL;
4513 }
4514 else if( when > TIME_UPPER_BOUND ) {
dcbac5bb 4515 /* diag_listed_as: gmtime(%f) too small */
fc003d4b 4516 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
7eb4f9b7 4517 "%s(%.0" NVff ") too large", opname, when);
fc003d4b
MS		 4518 err = NULL;
4519 }
4520 else {
4521 if (PL_op->op_type == OP_LOCALTIME)
4522 err = S_localtime64_r(&when, &tmbuf);
4523 else
4524 err = S_gmtime64_r(&when, &tmbuf);
4525 }
a0d0e21e 4526
a2a5de95 4527 if (err == NULL) {
8efababc 4528 /* XXX %lld broken for quads */
a2a5de95 4529 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
7eb4f9b7 4530 "%s(%.0" NVff ") failed", opname, when);
5b6366c2 4531 }
a0d0e21e 4532
a272e669 4533 if (GIMME != G_ARRAY) { /* scalar context */
46fc3d4c 4534 SV *tsv;
8efababc
MS		 4535 /* XXX newSVpvf()'s %lld type is broken, so cheat with a double */
4536 double year = (double)tmbuf.tm_year + 1900;
4537
9a5ff6d9
AB		 4538 EXTEND(SP, 1);
4539 EXTEND_MORTAL(1);
a272e669 4540 if (err == NULL)
a0d0e21e 4541 RETPUSHUNDEF;
a272e669 4542
8efababc 4543 tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %.0f",
a272e669
MS		 4544 dayname[tmbuf.tm_wday],
4545 monname[tmbuf.tm_mon],
4546 tmbuf.tm_mday,
4547 tmbuf.tm_hour,
4548 tmbuf.tm_min,
4549 tmbuf.tm_sec,
8efababc 4550 year);
6e449a3a 4551 mPUSHs(tsv);
a0d0e21e 4552 }
a272e669
MS		 4553 else { /* list context */
4554 if ( err == NULL )
4555 RETURN;
4556
9a5ff6d9
AB		 4557 EXTEND(SP, 9);
4558 EXTEND_MORTAL(9);
a272e669
MS		 4559 mPUSHi(tmbuf.tm_sec);
4560 mPUSHi(tmbuf.tm_min);
4561 mPUSHi(tmbuf.tm_hour);
4562 mPUSHi(tmbuf.tm_mday);
4563 mPUSHi(tmbuf.tm_mon);
7315c673 4564 mPUSHn(tmbuf.tm_year);
a272e669
MS		 4565 mPUSHi(tmbuf.tm_wday);
4566 mPUSHi(tmbuf.tm_yday);
4567 mPUSHi(tmbuf.tm_isdst);
a0d0e21e
LW		 4568 }
4569 RETURN;
4570}
4571
4572PP(pp_alarm)
4573{
9cad6237 4574#ifdef HAS_ALARM
97aff369 4575 dVAR; dSP; dTARGET;
a0d0e21e 4576 int anum;
a0d0e21e
LW		 4577 anum = POPi;
4578 anum = alarm((unsigned int)anum);
a0d0e21e
LW		 4579 if (anum < 0)
4580 RETPUSHUNDEF;
c6419e06 4581 PUSHi(anum);
a0d0e21e
LW		 4582 RETURN;
4583#else
0322a713 4584 DIE(aTHX_ PL_no_func, "alarm");
a0d0e21e
LW		 4585#endif
4586}
4587
4588PP(pp_sleep)
4589{
97aff369 4590 dVAR; dSP; dTARGET;
a0d0e21e
LW		 4591 I32 duration;
4592 Time_t lasttime;
4593 Time_t when;
4594
4595 (void)time(&lasttime);
0da4a804 4596 if (MAXARG < 1 || (!TOPs && !POPs))
76e3520e 4597 PerlProc_pause();
a0d0e21e
LW		 4598 else {
4599 duration = POPi;
76e3520e 4600 PerlProc_sleep((unsigned int)duration);
a0d0e21e
LW		 4601 }
4602 (void)time(&when);
4603 XPUSHi(when - lasttime);
4604 RETURN;
4605}
4606
4607/* Shared memory. */
c9f7ac20 4608/* Merged with some message passing. */
a0d0e21e 4609
a0d0e21e
LW		 4610PP(pp_shmwrite)
4611{
4612#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
97aff369 4613 dVAR; dSP; dMARK; dTARGET;
c9f7ac20
NC		 4614 const int op_type = PL_op->op_type;
4615 I32 value;
a0d0e21e 4616
c9f7ac20
NC		 4617 switch (op_type) {
4618 case OP_MSGSND:
4619 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4620 break;
4621 case OP_MSGRCV:
4622 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4623 break;
ca563b4e
NC		 4624 case OP_SEMOP:
4625 value = (I32)(do_semop(MARK, SP) >= 0);
4626 break;
c9f7ac20
NC		 4627 default:
4628 value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4629 break;
4630 }
a0d0e21e 4631
a0d0e21e
LW		 4632 SP = MARK;
4633 PUSHi(value);
4634 RETURN;
4635#else
897d3989 4636 return Perl_pp_semget(aTHX);
a0d0e21e
LW		 4637#endif
4638}
4639
4640/* Semaphores. */
4641
4642PP(pp_semget)
4643{
4644#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
97aff369 4645 dVAR; dSP; dMARK; dTARGET;
0bcc34c2 4646 const int anum = do_ipcget(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 4647 SP = MARK;
4648 if (anum == -1)
4649 RETPUSHUNDEF;
4650 PUSHi(anum);
4651 RETURN;
4652#else
cea2e8a9 4653 DIE(aTHX_ "System V IPC is not implemented on this machine");
a0d0e21e
LW		 4654#endif
4655}
4656
4657PP(pp_semctl)
4658{
4659#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
97aff369 4660 dVAR; dSP; dMARK; dTARGET;
0bcc34c2 4661 const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 4662 SP = MARK;
4663 if (anum == -1)
4664 RETSETUNDEF;
4665 if (anum != 0) {
4666 PUSHi(anum);
4667 }
4668 else {
8903cb82 4669 PUSHp(zero_but_true, ZBTLEN);
a0d0e21e
LW		 4670 }
4671 RETURN;
4672#else
897d3989 4673 return Perl_pp_semget(aTHX);
a0d0e21e
LW		 4674#endif
4675}
4676
5cdc4e88
NC		 4677/* I can't const this further without getting warnings about the types of
4678 various arrays passed in from structures. */
4679static SV *
4680S_space_join_names_mortal(pTHX_ char *const *array)
4681{
7c58897d 4682 SV *target;
5cdc4e88 4683
7918f24d
NC		 4684 PERL_ARGS_ASSERT_SPACE_JOIN_NAMES_MORTAL;
4685
5cdc4e88 4686 if (array && *array) {
84bafc02 4687 target = newSVpvs_flags("", SVs_TEMP);
5cdc4e88
NC		 4688 while (1) {
4689 sv_catpv(target, *array);
4690 if (!*++array)
4691 break;
4692 sv_catpvs(target, " ");
4693 }
7c58897d
NC		 4694 } else {
4695 target = sv_mortalcopy(&PL_sv_no);
5cdc4e88
NC		 4696 }
4697 return target;
4698}
4699
a0d0e21e
LW		 4700/* Get system info. */
4701
a0d0e21e
LW		 4702PP(pp_ghostent)
4703{
693762b4 4704#if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
97aff369 4705 dVAR; dSP;
533c011a 4706 I32 which = PL_op->op_type;
a0d0e21e
LW		 4707 register char **elem;
4708 register SV *sv;
dc45a647 4709#ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
1d88b533
JH		 4710 struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4711 struct hostent *gethostbyname(Netdb_name_t);
4712 struct hostent *gethostent(void);
a0d0e21e 4713#endif
07822e36 4714 struct hostent *hent = NULL;
a0d0e21e
LW		 4715 unsigned long len;
4716
4717 EXTEND(SP, 10);
edd309b7 4718 if (which == OP_GHBYNAME) {
dc45a647 4719#ifdef HAS_GETHOSTBYNAME
0bcc34c2 4720 const char* const name = POPpbytex;
edd309b7 4721 hent = PerlSock_gethostbyname(name);
dc45a647 4722#else
cea2e8a9 4723 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
dc45a647 4724#endif
edd309b7 4725 }
a0d0e21e 4726 else if (which == OP_GHBYADDR) {
dc45a647 4727#ifdef HAS_GETHOSTBYADDR
0bcc34c2
AL		 4728 const int addrtype = POPi;
4729 SV * const addrsv = POPs;
a0d0e21e 4730 STRLEN addrlen;
48fc4736 4731 const char *addr = (char *)SvPVbyte(addrsv, addrlen);
a0d0e21e 4732
48fc4736 4733 hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
dc45a647 4734#else
cea2e8a9 4735 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
dc45a647 4736#endif
a0d0e21e
LW		 4737 }
4738 else
4739#ifdef HAS_GETHOSTENT
6ad3d225 4740 hent = PerlSock_gethostent();
a0d0e21e 4741#else
cea2e8a9 4742 DIE(aTHX_ PL_no_sock_func, "gethostent");
a0d0e21e
LW		 4743#endif
4744
4745#ifdef HOST_NOT_FOUND
10bc17b6
JH		 4746 if (!hent) {
4747#ifdef USE_REENTRANT_API
4748# ifdef USE_GETHOSTENT_ERRNO
4749 h_errno = PL_reentrant_buffer->_gethostent_errno;
4750# endif
4751#endif
37038d91 4752 STATUS_UNIX_SET(h_errno);
10bc17b6 4753 }
a0d0e21e
LW		 4754#endif
4755
4756 if (GIMME != G_ARRAY) {
4757 PUSHs(sv = sv_newmortal());
4758 if (hent) {
4759 if (which == OP_GHBYNAME) {
fd0af264 4760 if (hent->h_addr)
4761 sv_setpvn(sv, hent->h_addr, hent->h_length);
a0d0e21e
LW		 4762 }
4763 else
4764 sv_setpv(sv, (char*)hent->h_name);
4765 }
4766 RETURN;
4767 }
4768
4769 if (hent) {
6e449a3a 4770 mPUSHs(newSVpv((char*)hent->h_name, 0));
931e0695 4771 PUSHs(space_join_names_mortal(hent->h_aliases));
6e449a3a 4772 mPUSHi(hent->h_addrtype);
a0d0e21e 4773 len = hent->h_length;
6e449a3a 4774 mPUSHi(len);
a0d0e21e
LW		 4775#ifdef h_addr
4776 for (elem = hent->h_addr_list; elem && *elem; elem++) {
6e449a3a 4777 mXPUSHp(*elem, len);
a0d0e21e
LW		 4778 }
4779#else
fd0af264 4780 if (hent->h_addr)
22f1178f 4781 mPUSHp(hent->h_addr, len);
7c58897d
NC		 4782 else
4783 PUSHs(sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 4784#endif /* h_addr */
4785 }
4786 RETURN;
4787#else
7844cc62 4788 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
a0d0e21e
LW		 4789#endif
4790}
4791
a0d0e21e
LW		 4792PP(pp_gnetent)
4793{
693762b4 4794#if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
97aff369 4795 dVAR; dSP;
533c011a 4796 I32 which = PL_op->op_type;
a0d0e21e 4797 register SV *sv;
dc45a647 4798#ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
1d88b533
JH		 4799 struct netent *getnetbyaddr(Netdb_net_t, int);
4800 struct netent *getnetbyname(Netdb_name_t);
4801 struct netent *getnetent(void);
8ac85365 4802#endif
a0d0e21e
LW		 4803 struct netent *nent;
4804
edd309b7 4805 if (which == OP_GNBYNAME){
dc45a647 4806#ifdef HAS_GETNETBYNAME
0bcc34c2 4807 const char * const name = POPpbytex;
edd309b7 4808 nent = PerlSock_getnetbyname(name);
dc45a647 4809#else
cea2e8a9 4810 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
dc45a647 4811#endif
edd309b7 4812 }
a0d0e21e 4813 else if (which == OP_GNBYADDR) {
dc45a647 4814#ifdef HAS_GETNETBYADDR
0bcc34c2
AL		 4815 const int addrtype = POPi;
4816 const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
76e3520e 4817 nent = PerlSock_getnetbyaddr(addr, addrtype);
dc45a647 4818#else
cea2e8a9 4819 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
dc45a647 4820#endif
a0d0e21e
LW		 4821 }
4822 else
dc45a647 4823#ifdef HAS_GETNETENT
76e3520e 4824 nent = PerlSock_getnetent();
dc45a647 4825#else
cea2e8a9 4826 DIE(aTHX_ PL_no_sock_func, "getnetent");
dc45a647 4827#endif
a0d0e21e 4828
10bc17b6
JH		 4829#ifdef HOST_NOT_FOUND
4830 if (!nent) {
4831#ifdef USE_REENTRANT_API
4832# ifdef USE_GETNETENT_ERRNO
4833 h_errno = PL_reentrant_buffer->_getnetent_errno;
4834# endif
4835#endif
37038d91 4836 STATUS_UNIX_SET(h_errno);
10bc17b6
JH		 4837 }
4838#endif
4839
a0d0e21e
LW		 4840 EXTEND(SP, 4);
4841 if (GIMME != G_ARRAY) {
4842 PUSHs(sv = sv_newmortal());
4843 if (nent) {
4844 if (which == OP_GNBYNAME)
1e422769 4845 sv_setiv(sv, (IV)nent->n_net);
a0d0e21e
LW		 4846 else
4847 sv_setpv(sv, nent->n_name);
4848 }
4849 RETURN;
4850 }
4851
4852 if (nent) {
6e449a3a 4853 mPUSHs(newSVpv(nent->n_name, 0));
931e0695 4854 PUSHs(space_join_names_mortal(nent->n_aliases));
6e449a3a
MHM		 4855 mPUSHi(nent->n_addrtype);
4856 mPUSHi(nent->n_net);
a0d0e21e
LW		 4857 }
4858
4859 RETURN;
4860#else
7844cc62 4861 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
a0d0e21e
LW		 4862#endif
4863}
4864
a0d0e21e
LW		 4865PP(pp_gprotoent)
4866{
693762b4 4867#if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
97aff369 4868 dVAR; dSP;
533c011a 4869 I32 which = PL_op->op_type;
301e8125 4870 register SV *sv;
dc45a647 4871#ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
1d88b533
JH		 4872 struct protoent *getprotobyname(Netdb_name_t);
4873 struct protoent *getprotobynumber(int);
4874 struct protoent *getprotoent(void);
8ac85365 4875#endif
a0d0e21e
LW		 4876 struct protoent *pent;
4877
edd309b7 4878 if (which == OP_GPBYNAME) {
e5c9fcd0 4879#ifdef HAS_GETPROTOBYNAME
0bcc34c2 4880 const char* const name = POPpbytex;
edd309b7 4881 pent = PerlSock_getprotobyname(name);
e5c9fcd0 4882#else
cea2e8a9 4883 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
e5c9fcd0 4884#endif
edd309b7
JH		 4885 }
4886 else if (which == OP_GPBYNUMBER) {
e5c9fcd0 4887#ifdef HAS_GETPROTOBYNUMBER
0bcc34c2 4888 const int number = POPi;
edd309b7 4889 pent = PerlSock_getprotobynumber(number);
e5c9fcd0 4890#else
edd309b7 4891 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
e5c9fcd0 4892#endif
edd309b7 4893 }
a0d0e21e 4894 else
e5c9fcd0 4895#ifdef HAS_GETPROTOENT
6ad3d225 4896 pent = PerlSock_getprotoent();
e5c9fcd0 4897#else
cea2e8a9 4898 DIE(aTHX_ PL_no_sock_func, "getprotoent");
e5c9fcd0 4899#endif
a0d0e21e
LW		 4900
4901 EXTEND(SP, 3);
4902 if (GIMME != G_ARRAY) {
4903 PUSHs(sv = sv_newmortal());
4904 if (pent) {
4905 if (which == OP_GPBYNAME)
1e422769 4906 sv_setiv(sv, (IV)pent->p_proto);
a0d0e21e
LW		 4907 else
4908 sv_setpv(sv, pent->p_name);
4909 }
4910 RETURN;
4911 }
4912
4913 if (pent) {
6e449a3a 4914 mPUSHs(newSVpv(pent->p_name, 0));
931e0695 4915 PUSHs(space_join_names_mortal(pent->p_aliases));
6e449a3a 4916 mPUSHi(pent->p_proto);
a0d0e21e
LW		 4917 }
4918
4919 RETURN;
4920#else
7844cc62 4921 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
a0d0e21e
LW		 4922#endif
4923}
4924
a0d0e21e
LW		 4925PP(pp_gservent)
4926{
693762b4 4927#if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
97aff369 4928 dVAR; dSP;
533c011a 4929 I32 which = PL_op->op_type;
a0d0e21e 4930 register SV *sv;
dc45a647 4931#ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
1d88b533
JH		 4932 struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
4933 struct servent *getservbyport(int, Netdb_name_t);
4934 struct servent *getservent(void);
8ac85365 4935#endif
a0d0e21e
LW		 4936 struct servent *sent;
4937
4938 if (which == OP_GSBYNAME) {
dc45a647 4939#ifdef HAS_GETSERVBYNAME
0bcc34c2
AL		 4940 const char * const proto = POPpbytex;
4941 const char * const name = POPpbytex;
bd61b366 4942 sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
dc45a647 4943#else
cea2e8a9 4944 DIE(aTHX_ PL_no_sock_func, "getservbyname");
dc45a647 4945#endif
a0d0e21e
LW		 4946 }
4947 else if (which == OP_GSBYPORT) {
dc45a647 4948#ifdef HAS_GETSERVBYPORT
0bcc34c2 4949 const char * const proto = POPpbytex;
eb160463 4950 unsigned short port = (unsigned short)POPu;
36477c24 4951#ifdef HAS_HTONS
6ad3d225 4952 port = PerlSock_htons(port);
36477c24 4953#endif
bd61b366 4954 sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
dc45a647 4955#else
cea2e8a9 4956 DIE(aTHX_ PL_no_sock_func, "getservbyport");
dc45a647 4957#endif
a0d0e21e
LW		 4958 }
4959 else
e5c9fcd0 4960#ifdef HAS_GETSERVENT
6ad3d225 4961 sent = PerlSock_getservent();
e5c9fcd0 4962#else
cea2e8a9 4963 DIE(aTHX_ PL_no_sock_func, "getservent");
e5c9fcd0 4964#endif
a0d0e21e
LW		 4965
4966 EXTEND(SP, 4);
4967 if (GIMME != G_ARRAY) {
4968 PUSHs(sv = sv_newmortal());
4969 if (sent) {
4970 if (which == OP_GSBYNAME) {
4971#ifdef HAS_NTOHS
6ad3d225 4972 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
a0d0e21e 4973#else
1e422769 4974 sv_setiv(sv, (IV)(sent->s_port));
a0d0e21e
LW		 4975#endif
4976 }
4977 else
4978 sv_setpv(sv, sent->s_name);
4979 }
4980 RETURN;
4981 }
4982
4983 if (sent) {
6e449a3a 4984 mPUSHs(newSVpv(sent->s_name, 0));
931e0695 4985 PUSHs(space_join_names_mortal(sent->s_aliases));
a0d0e21e 4986#ifdef HAS_NTOHS
6e449a3a 4987 mPUSHi(PerlSock_ntohs(sent->s_port));
a0d0e21e 4988#else
6e449a3a 4989 mPUSHi(sent->s_port);
a0d0e21e 4990#endif
6e449a3a 4991 mPUSHs(newSVpv(sent->s_proto, 0));
a0d0e21e
LW		 4992 }
4993
4994 RETURN;
4995#else
7844cc62 4996 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
a0d0e21e
LW		 4997#endif
4998}
4999
5000PP(pp_shostent)
5001{
97aff369 5002 dVAR; dSP;
396166e1
NC		 5003 const int stayopen = TOPi;
5004 switch(PL_op->op_type) {
5005 case OP_SHOSTENT:
5006#ifdef HAS_SETHOSTENT
5007 PerlSock_sethostent(stayopen);
a0d0e21e 5008#else
396166e1 5009 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
a0d0e21e 5010#endif
396166e1 5011 break;
693762b4 5012#ifdef HAS_SETNETENT
396166e1
NC		 5013 case OP_SNETENT:
5014 PerlSock_setnetent(stayopen);
a0d0e21e 5015#else
396166e1 5016 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
a0d0e21e 5017#endif
396166e1
NC		 5018 break;
5019 case OP_SPROTOENT:
693762b4 5020#ifdef HAS_SETPROTOENT
396166e1 5021 PerlSock_setprotoent(stayopen);
a0d0e21e 5022#else
396166e1 5023 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
a0d0e21e 5024#endif
396166e1
NC		 5025 break;
5026 case OP_SSERVENT:
693762b4 5027#ifdef HAS_SETSERVENT
396166e1 5028 PerlSock_setservent(stayopen);
a0d0e21e 5029#else
396166e1 5030 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
a0d0e21e 5031#endif
396166e1
NC		 5032 break;
5033 }
5034 RETSETYES;
a0d0e21e
LW		 5035}
5036
5037PP(pp_ehostent)
5038{
97aff369 5039 dVAR; dSP;
d8ef1fcd
NC		 5040 switch(PL_op->op_type) {
5041 case OP_EHOSTENT:
5042#ifdef HAS_ENDHOSTENT
5043 PerlSock_endhostent();
a0d0e21e 5044#else
d8ef1fcd 5045 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
a0d0e21e 5046#endif
d8ef1fcd
NC		 5047 break;
5048 case OP_ENETENT:
693762b4 5049#ifdef HAS_ENDNETENT
d8ef1fcd 5050 PerlSock_endnetent();
a0d0e21e 5051#else
d8ef1fcd 5052 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
a0d0e21e 5053#endif
d8ef1fcd
NC		 5054 break;
5055 case OP_EPROTOENT:
693762b4 5056#ifdef HAS_ENDPROTOENT
d8ef1fcd 5057 PerlSock_endprotoent();
a0d0e21e 5058#else
d8ef1fcd 5059 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
a0d0e21e 5060#endif
d8ef1fcd
NC		 5061 break;
5062 case OP_ESERVENT:
693762b4 5063#ifdef HAS_ENDSERVENT
d8ef1fcd 5064 PerlSock_endservent();
a0d0e21e 5065#else
d8ef1fcd 5066 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
a0d0e21e 5067#endif
d8ef1fcd 5068 break;
720d5dbf
NC		 5069 case OP_SGRENT:
5070#if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5071 setgrent();
5072#else
5073 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5074#endif
5075 break;
5076 case OP_EGRENT:
5077#if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5078 endgrent();
5079#else
5080 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5081#endif
5082 break;
5083 case OP_SPWENT:
5084#if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5085 setpwent();
5086#else
5087 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5088#endif
5089 break;
5090 case OP_EPWENT:
5091#if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5092 endpwent();
5093#else
5094 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5095#endif
5096 break;
d8ef1fcd
NC		 5097 }
5098 EXTEND(SP,1);
5099 RETPUSHYES;
a0d0e21e
LW		 5100}
5101
a0d0e21e
LW		 5102PP(pp_gpwent)
5103{
0994c4d0 5104#ifdef HAS_PASSWD
97aff369 5105 dVAR; dSP;
533c011a 5106 I32 which = PL_op->op_type;
a0d0e21e 5107 register SV *sv;
e3aefe8d 5108 struct passwd *pwent = NULL;
301e8125 5109 /*
bcf53261
JH		 5110 * We currently support only the SysV getsp* shadow password interface.
5111 * The interface is declared in <shadow.h> and often one needs to link
5112 * with -lsecurity or some such.
5113 * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5114 * (and SCO?)
5115 *
5116 * AIX getpwnam() is clever enough to return the encrypted password
5117 * only if the caller (euid?) is root.
5118 *
e549f1c5 5119 * There are at least three other shadow password APIs. Many platforms
bcf53261
JH		 5120 * seem to contain more than one interface for accessing the shadow
5121 * password databases, possibly for compatibility reasons.
3813c136 5122 * The getsp*() is by far he simplest one, the other two interfaces
bcf53261
JH		 5123 * are much more complicated, but also very similar to each other.
5124 *
5125 * <sys/types.h>
5126 * <sys/security.h>
5127 * <prot.h>
5128 * struct pr_passwd *getprpw*();
5129 * The password is in
3813c136
JH		 5130 * char getprpw*(...).ufld.fd_encrypt[]
5131 * Mention HAS_GETPRPWNAM here so that Configure probes for it.
bcf53261
JH		 5132 *
5133 * <sys/types.h>
5134 * <sys/security.h>
5135 * <prot.h>
5136 * struct es_passwd *getespw*();
5137 * The password is in
5138 * char *(getespw*(...).ufld.fd_encrypt)
3813c136 5139 * Mention HAS_GETESPWNAM here so that Configure probes for it.
bcf53261 5140 *
e1920a95 5141 * <userpw.h> (AIX)
e549f1c5
JH		 5142 * struct userpw *getuserpw();
5143 * The password is in
5144 * char *(getuserpw(...)).spw_upw_passwd
5145 * (but the de facto standard getpwnam() should work okay)
5146 *
3813c136 5147 * Mention I_PROT here so that Configure probes for it.
bcf53261
JH		 5148 *
5149 * In HP-UX for getprpw*() the manual page claims that one should include
5150 * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5151 * if one includes <shadow.h> as that includes <hpsecurity.h>,
5152 * and pp_sys.c already includes <shadow.h> if there is such.
3813c136
JH		 5153 *
5154 * Note that <sys/security.h> is already probed for, but currently
5155 * it is only included in special cases.
301e8125 5156 *
bcf53261
JH		 5157 * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5158 * be preferred interface, even though also the getprpw*() interface
5159 * is available) one needs to link with -lsecurity -ldb -laud -lm.
3813c136
JH		 5160 * One also needs to call set_auth_parameters() in main() before
5161 * doing anything else, whether one is using getespw*() or getprpw*().
5162 *
5163 * Note that accessing the shadow databases can be magnitudes
5164 * slower than accessing the standard databases.
bcf53261
JH		 5165 *
5166 * --jhi
5167 */
a0d0e21e 5168
9e5f0c48
JH		 5169# if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5170 /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5171 * the pw_comment is left uninitialized. */
5172 PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5173# endif
5174
e3aefe8d
JH		 5175 switch (which) {
5176 case OP_GPWNAM:
edd309b7 5177 {
0bcc34c2 5178 const char* const name = POPpbytex;
edd309b7
JH		 5179 pwent = getpwnam(name);
5180 }
5181 break;
e3aefe8d 5182 case OP_GPWUID:
edd309b7
JH		 5183 {
5184 Uid_t uid = POPi;
5185 pwent = getpwuid(uid);
5186 }
e3aefe8d
JH		 5187 break;
5188 case OP_GPWENT:
1883634f 5189# ifdef HAS_GETPWENT
e3aefe8d 5190 pwent = getpwent();
faea9016
IRC		 5191#ifdef POSIX_BC /* In some cases pw_passwd has invalid addresses */
5192 if (pwent) pwent = getpwnam(pwent->pw_name);
5193#endif
1883634f 5194# else
a45d1c96 5195 DIE(aTHX_ PL_no_func, "getpwent");
1883634f 5196# endif
e3aefe8d
JH		 5197 break;
5198 }
8c0bfa08 5199
a0d0e21e
LW		 5200 EXTEND(SP, 10);
5201 if (GIMME != G_ARRAY) {
5202 PUSHs(sv = sv_newmortal());
5203 if (pwent) {
5204 if (which == OP_GPWNAM)
1883634f 5205# if Uid_t_sign <= 0
1e422769 5206 sv_setiv(sv, (IV)pwent->pw_uid);
1883634f 5207# else
23dcd6c8 5208 sv_setuv(sv, (UV)pwent->pw_uid);
1883634f 5209# endif
a0d0e21e
LW		 5210 else
5211 sv_setpv(sv, pwent->pw_name);
5212 }
5213 RETURN;
5214 }
5215
5216 if (pwent) {
6e449a3a 5217 mPUSHs(newSVpv(pwent->pw_name, 0));
6ee623d5 5218
6e449a3a
MHM		 5219 sv = newSViv(0);
5220 mPUSHs(sv);
3813c136
JH		 5221 /* If we have getspnam(), we try to dig up the shadow
5222 * password. If we are underprivileged, the shadow
5223 * interface will set the errno to EACCES or similar,
5224 * and return a null pointer. If this happens, we will
5225 * use the dummy password (usually "*" or "x") from the
5226 * standard password database.
5227 *
5228 * In theory we could skip the shadow call completely
5229 * if euid != 0 but in practice we cannot know which
5230 * security measures are guarding the shadow databases
5231 * on a random platform.
5232 *
5233 * Resist the urge to use additional shadow interfaces.
5234 * Divert the urge to writing an extension instead.
5235 *
5236 * --jhi */
e549f1c5
JH		 5237 /* Some AIX setups falsely(?) detect some getspnam(), which
5238 * has a different API than the Solaris/IRIX one. */
5239# if defined(HAS_GETSPNAM) && !defined(_AIX)
3813c136 5240 {
4ee39169 5241 dSAVE_ERRNO;
0bcc34c2
AL		 5242 const struct spwd * const spwent = getspnam(pwent->pw_name);
5243 /* Save and restore errno so that
3813c136 5244 * underprivileged attempts seem
486ec47a 5245 * to have never made the unsuccessful
3813c136 5246 * attempt to retrieve the shadow password. */
4ee39169 5247 RESTORE_ERRNO;
3813c136
JH		 5248 if (spwent && spwent->sp_pwdp)
5249 sv_setpv(sv, spwent->sp_pwdp);
5250 }
f1066039 5251# endif
e020c87d 5252# ifdef PWPASSWD
3813c136
JH		 5253 if (!SvPOK(sv)) /* Use the standard password, then. */
5254 sv_setpv(sv, pwent->pw_passwd);
e020c87d 5255# endif
3813c136 5256
1883634f 5257# ifndef INCOMPLETE_TAINTS
3813c136
JH		 5258 /* passwd is tainted because user himself can diddle with it.
5259 * admittedly not much and in a very limited way, but nevertheless. */
2959b6e3 5260 SvTAINTED_on(sv);
1883634f 5261# endif
6ee623d5 5262
1883634f 5263# if Uid_t_sign <= 0
6e449a3a 5264 mPUSHi(pwent->pw_uid);
1883634f 5265# else
6e449a3a 5266 mPUSHu(pwent->pw_uid);
1883634f 5267# endif
6ee623d5 5268
1883634f 5269# if Uid_t_sign <= 0
6e449a3a 5270 mPUSHi(pwent->pw_gid);
1883634f 5271# else
6e449a3a 5272 mPUSHu(pwent->pw_gid);
1883634f 5273# endif
3813c136
JH		 5274 /* pw_change, pw_quota, and pw_age are mutually exclusive--
5275 * because of the poor interface of the Perl getpw*(),
5276 * not because there's some standard/convention saying so.
5277 * A better interface would have been to return a hash,
5278 * but we are accursed by our history, alas. --jhi. */
1883634f 5279# ifdef PWCHANGE
6e449a3a 5280 mPUSHi(pwent->pw_change);
6ee623d5 5281# else
1883634f 5282# ifdef PWQUOTA
6e449a3a 5283 mPUSHi(pwent->pw_quota);
1883634f 5284# else
a1757be1 5285# ifdef PWAGE
6e449a3a 5286 mPUSHs(newSVpv(pwent->pw_age, 0));
7c58897d
NC		 5287# else
5288 /* I think that you can never get this compiled, but just in case. */
5289 PUSHs(sv_mortalcopy(&PL_sv_no));
a1757be1 5290# endif
6ee623d5
GS		 5291# endif
5292# endif
6ee623d5 5293
3813c136
JH		 5294 /* pw_class and pw_comment are mutually exclusive--.
5295 * see the above note for pw_change, pw_quota, and pw_age. */
1883634f 5296# ifdef PWCLASS
6e449a3a 5297 mPUSHs(newSVpv(pwent->pw_class, 0));
1883634f
JH		 5298# else
5299# ifdef PWCOMMENT
6e449a3a 5300 mPUSHs(newSVpv(pwent->pw_comment, 0));
7c58897d
NC		 5301# else
5302 /* I think that you can never get this compiled, but just in case. */
5303 PUSHs(sv_mortalcopy(&PL_sv_no));
1883634f 5304# endif
6ee623d5 5305# endif
6ee623d5 5306
1883634f 5307# ifdef PWGECOS
7c58897d
NC		 5308 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
5309# else
c4c533cb 5310 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1883634f
JH		 5311# endif
5312# ifndef INCOMPLETE_TAINTS
d2719217 5313 /* pw_gecos is tainted because user himself can diddle with it. */
fb73857a 5314 SvTAINTED_on(sv);
1883634f 5315# endif
6ee623d5 5316
6e449a3a 5317 mPUSHs(newSVpv(pwent->pw_dir, 0));
6ee623d5 5318
7c58897d 5319 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
1883634f 5320# ifndef INCOMPLETE_TAINTS
4602f195
JH		 5321 /* pw_shell is tainted because user himself can diddle with it. */
5322 SvTAINTED_on(sv);
1883634f 5323# endif
6ee623d5 5324
1883634f 5325# ifdef PWEXPIRE
6e449a3a 5326 mPUSHi(pwent->pw_expire);
1883634f 5327# endif
a0d0e21e
LW		 5328 }
5329 RETURN;
5330#else
af51a00e 5331 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
a0d0e21e
LW		 5332#endif
5333}
5334
a0d0e21e
LW		 5335PP(pp_ggrent)
5336{
0994c4d0 5337#ifdef HAS_GROUP
97aff369 5338 dVAR; dSP;
6136c704
AL		 5339 const I32 which = PL_op->op_type;
5340 const struct group *grent;
a0d0e21e 5341
edd309b7 5342 if (which == OP_GGRNAM) {
0bcc34c2 5343 const char* const name = POPpbytex;
6136c704 5344 grent = (const struct group *)getgrnam(name);
edd309b7
JH		 5345 }
5346 else if (which == OP_GGRGID) {
0bcc34c2 5347 const Gid_t gid = POPi;
6136c704 5348 grent = (const struct group *)getgrgid(gid);
edd309b7 5349 }
a0d0e21e 5350 else
0994c4d0 5351#ifdef HAS_GETGRENT
a0d0e21e 5352 grent = (struct group *)getgrent();
0994c4d0
JH		 5353#else
5354 DIE(aTHX_ PL_no_func, "getgrent");
5355#endif
a0d0e21e
LW		 5356
5357 EXTEND(SP, 4);
5358 if (GIMME != G_ARRAY) {
6136c704
AL		 5359 SV * const sv = sv_newmortal();
5360
5361 PUSHs(sv);
a0d0e21e
LW		 5362 if (grent) {
5363 if (which == OP_GGRNAM)
f325df1b 5364#if Gid_t_sign <= 0
1e422769 5365 sv_setiv(sv, (IV)grent->gr_gid);
f325df1b
DS		 5366#else
5367 sv_setuv(sv, (UV)grent->gr_gid);
5368#endif
a0d0e21e
LW		 5369 else
5370 sv_setpv(sv, grent->gr_name);
5371 }
5372 RETURN;
5373 }
5374
5375 if (grent) {
6e449a3a 5376 mPUSHs(newSVpv(grent->gr_name, 0));
28e8609d 5377
28e8609d 5378#ifdef GRPASSWD
6e449a3a 5379 mPUSHs(newSVpv(grent->gr_passwd, 0));
7c58897d
NC		 5380#else
5381 PUSHs(sv_mortalcopy(&PL_sv_no));
28e8609d
JH		 5382#endif
5383
f325df1b 5384#if Gid_t_sign <= 0
6e449a3a 5385 mPUSHi(grent->gr_gid);
f325df1b
DS		 5386#else
5387 mPUSHu(grent->gr_gid);
5388#endif
28e8609d 5389
5b56e7c5 5390#if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
3d7e8424
JH		 5391 /* In UNICOS/mk (_CRAYMPP) the multithreading
5392 * versions (getgrnam_r, getgrgid_r)
5393 * seem to return an illegal pointer
5394 * as the group members list, gr_mem.
5395 * getgrent() doesn't even have a _r version
5396 * but the gr_mem is poisonous anyway.
5397 * So yes, you cannot get the list of group
5398 * members if building multithreaded in UNICOS/mk. */
931e0695 5399 PUSHs(space_join_names_mortal(grent->gr_mem));
3d7e8424 5400#endif
a0d0e21e
LW		 5401 }
5402
5403 RETURN;
5404#else
af51a00e 5405 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
a0d0e21e
LW		 5406#endif
5407}
5408
a0d0e21e
LW		 5409PP(pp_getlogin)
5410{
a0d0e21e 5411#ifdef HAS_GETLOGIN
97aff369 5412 dVAR; dSP; dTARGET;
a0d0e21e
LW		 5413 char *tmps;
5414 EXTEND(SP, 1);
76e3520e 5415 if (!(tmps = PerlProc_getlogin()))
a0d0e21e 5416 RETPUSHUNDEF;
bee8aa44
NC		 5417 sv_setpv_mg(TARG, tmps);
5418 PUSHs(TARG);
a0d0e21e
LW		 5419 RETURN;
5420#else
cea2e8a9 5421 DIE(aTHX_ PL_no_func, "getlogin");
a0d0e21e
LW		 5422#endif
5423}
5424
5425/* Miscellaneous. */
5426
5427PP(pp_syscall)
5428{
d2719217 5429#ifdef HAS_SYSCALL
97aff369 5430 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW		 5431 register I32 items = SP - MARK;
5432 unsigned long a[20];
5433 register I32 i = 0;
5434 I32 retval = -1;
5435
3280af22 5436 if (PL_tainting) {
a0d0e21e 5437 while (++MARK <= SP) {
bbce6d69 5438 if (SvTAINTED(*MARK)) {
5439 TAINT;
5440 break;
5441 }
a0d0e21e
LW		 5442 }
5443 MARK = ORIGMARK;
5444 TAINT_PROPER("syscall");
5445 }
5446
5447 /* This probably won't work on machines where sizeof(long) != sizeof(int)
5448 * or where sizeof(long) != sizeof(char*). But such machines will
5449 * not likely have syscall implemented either, so who cares?
5450 */
5451 while (++MARK <= SP) {
5452 if (SvNIOK(*MARK) || !i)
5453 a[i++] = SvIV(*MARK);
3280af22 5454 else if (*MARK == &PL_sv_undef)
748a9306 5455 a[i++] = 0;
301e8125 5456 else
8b6b16e7 5457 a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
a0d0e21e
LW		 5458 if (i > 15)
5459 break;
5460 }
5461 switch (items) {
5462 default:
cea2e8a9 5463 DIE(aTHX_ "Too many args to syscall");
a0d0e21e 5464 case 0:
cea2e8a9 5465 DIE(aTHX_ "Too few args to syscall");
a0d0e21e
LW		 5466 case 1:
5467 retval = syscall(a[0]);
5468 break;
5469 case 2:
5470 retval = syscall(a[0],a[1]);
5471 break;
5472 case 3:
5473 retval = syscall(a[0],a[1],a[2]);
5474 break;
5475 case 4:
5476 retval = syscall(a[0],a[1],a[2],a[3]);
5477 break;
5478 case 5:
5479 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5480 break;
5481 case 6:
5482 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5483 break;
5484 case 7:
5485 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5486 break;
5487 case 8:
5488 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5489 break;
5490#ifdef atarist
5491 case 9:
5492 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5493 break;
5494 case 10:
5495 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
5496 break;
5497 case 11:
5498 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5499 a[10]);
5500 break;
5501 case 12:
5502 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5503 a[10],a[11]);
5504 break;
5505 case 13:
5506 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5507 a[10],a[11],a[12]);
5508 break;
5509 case 14:
5510 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5511 a[10],a[11],a[12],a[13]);
5512 break;
5513#endif /* atarist */
5514 }
5515 SP = ORIGMARK;
5516 PUSHi(retval);
5517 RETURN;
5518#else
cea2e8a9 5519 DIE(aTHX_ PL_no_func, "syscall");
a0d0e21e
LW		 5520#endif
5521}
5522
ff68c719 5523#ifdef FCNTL_EMULATE_FLOCK
301e8125 5524
ff68c719 5525/* XXX Emulate flock() with fcntl().
5526 What's really needed is a good file locking module.
5527*/
5528
cea2e8a9
GS		 5529static int
5530fcntl_emulate_flock(int fd, int operation)
ff68c719 5531{
fd9e8b45 5532 int res;
ff68c719 5533 struct flock flock;
301e8125 5534
ff68c719 5535 switch (operation & ~LOCK_NB) {
5536 case LOCK_SH:
5537 flock.l_type = F_RDLCK;
5538 break;
5539 case LOCK_EX:
5540 flock.l_type = F_WRLCK;
5541 break;
5542 case LOCK_UN:
5543 flock.l_type = F_UNLCK;
5544 break;
5545 default:
5546 errno = EINVAL;
5547 return -1;
5548 }
5549 flock.l_whence = SEEK_SET;
d9b3e12d 5550 flock.l_start = flock.l_len = (Off_t)0;
301e8125 5551
fd9e8b45
JD		 5552 res = fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5553 if (res == -1 && ((errno == EAGAIN) || (errno == EACCES)))
5554 errno = EWOULDBLOCK;
5555 return res;
ff68c719 5556}
5557
5558#endif /* FCNTL_EMULATE_FLOCK */
5559
5560#ifdef LOCKF_EMULATE_FLOCK
16d20bd9
AD		 5561
5562/* XXX Emulate flock() with lockf(). This is just to increase
5563 portability of scripts. The calls are not completely
5564 interchangeable. What's really needed is a good file
5565 locking module.
5566*/
5567
76c32331 5568/* The lockf() constants might have been defined in <unistd.h>.
5569 Unfortunately, <unistd.h> causes troubles on some mixed
5570 (BSD/POSIX) systems, such as SunOS 4.1.3.
16d20bd9
AD		 5571
5572 Further, the lockf() constants aren't POSIX, so they might not be
5573 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
5574 just stick in the SVID values and be done with it. Sigh.
5575*/
5576
5577# ifndef F_ULOCK
5578# define F_ULOCK 0 /* Unlock a previously locked region */
5579# endif
5580# ifndef F_LOCK
5581# define F_LOCK 1 /* Lock a region for exclusive use */
5582# endif
5583# ifndef F_TLOCK
5584# define F_TLOCK 2 /* Test and lock a region for exclusive use */
5585# endif
5586# ifndef F_TEST
5587# define F_TEST 3 /* Test a region for other processes locks */
5588# endif
5589
cea2e8a9
GS		 5590static int
5591lockf_emulate_flock(int fd, int operation)
16d20bd9
AD		 5592{
5593 int i;
84902520 5594 Off_t pos;
4ee39169 5595 dSAVE_ERRNO;
84902520
TB		 5596
5597 /* flock locks entire file so for lockf we need to do the same */
6ad3d225 5598 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
84902520 5599 if (pos > 0) /* is seekable and needs to be repositioned */
6ad3d225 5600 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
08b714dd 5601 pos = -1; /* seek failed, so don't seek back afterwards */
4ee39169 5602 RESTORE_ERRNO;
84902520 5603
16d20bd9
AD		 5604 switch (operation) {
5605
5606 /* LOCK_SH - get a shared lock */
5607 case LOCK_SH:
5608 /* LOCK_EX - get an exclusive lock */
5609 case LOCK_EX:
5610 i = lockf (fd, F_LOCK, 0);
5611 break;
5612
5613 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5614 case LOCK_SH|LOCK_NB:
5615 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5616 case LOCK_EX|LOCK_NB:
5617 i = lockf (fd, F_TLOCK, 0);
5618 if (i == -1)
5619 if ((errno == EAGAIN) || (errno == EACCES))
5620 errno = EWOULDBLOCK;
5621 break;
5622
ff68c719 5623 /* LOCK_UN - unlock (non-blocking is a no-op) */
16d20bd9 5624 case LOCK_UN:
ff68c719 5625 case LOCK_UN|LOCK_NB:
16d20bd9
AD		 5626 i = lockf (fd, F_ULOCK, 0);
5627 break;
5628
5629 /* Default - can't decipher operation */
5630 default:
5631 i = -1;
5632 errno = EINVAL;
5633 break;
5634 }
84902520
TB		 5635
5636 if (pos > 0) /* need to restore position of the handle */
6ad3d225 5637 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
84902520 5638
16d20bd9
AD		 5639 return (i);
5640}
ff68c719 5641
5642#endif /* LOCKF_EMULATE_FLOCK */
241d1a3b
NC		 5643
5644/*
5645 * Local variables:
5646 * c-indentation-style: bsd
5647 * c-basic-offset: 4
5648 * indent-tabs-mode: t
5649 * End:
5650 *
37442d52
RGS		 5651 * ex: set ts=8 sts=4 sw=4 noet:
5652 */
Unnamed repository; edit this file 'description' to name the repository.