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