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