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