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