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