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