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