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