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