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