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