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
Group 3 headers as $(generated_headers) in the *nix, VMS and Win32 makefiles.
[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 421 SV *exsv;
06bf62c7 422 STRLEN len;
b59aed67 423 if (SP - MARK > 1) {
a0d0e21e 424 dTARGET;
3280af22 425 do_join(TARG, &PL_sv_no, MARK, SP);
c5df3096 426 exsv = TARG;
a0d0e21e
LW		 427 SP = MARK + 1;
428 }
b59aed67 429 else if (SP == MARK) {
c5df3096 430 exsv = &PL_sv_no;
b59aed67 431 EXTEND(SP, 1);
83f957ec 432 SP = MARK + 1;
b59aed67 433 }
a0d0e21e 434 else {
c5df3096 435 exsv = TOPs;
a0d0e21e 436 }
06bf62c7 437
72d74926 438 if (SvROK(exsv) || (SvPV_const(exsv, len), len)) {
c5df3096
Z		 439 /* well-formed exception supplied */
440 }
441 else if (SvROK(ERRSV)) {
442 exsv = ERRSV;
443 }
444 else if (SvPOK(ERRSV) && SvCUR(ERRSV)) {
445 exsv = sv_mortalcopy(ERRSV);
446 sv_catpvs(exsv, "\t...caught");
447 }
448 else {
449 exsv = newSVpvs_flags("Warning: something's wrong", SVs_TEMP);
450 }
3b7f69a5
FC		 451 if (SvROK(exsv) && !PL_warnhook)
452 Perl_warn(aTHX_ "%"SVf, SVfARG(exsv));
453 else warn_sv(exsv);
a0d0e21e
LW		 454 RETSETYES;
455}
456
457PP(pp_die)
458{
97aff369 459 dVAR; dSP; dMARK;
c5df3096 460 SV *exsv;
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 474
72d74926 475 if (SvROK(exsv) || (SvPV_const(exsv, len), len)) {
c5df3096
Z		 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{
d8ef3a16
DM		 514 SV **orig_sp = sp;
515 I32 ret_args;
516
d682515d 517 PERL_ARGS_ASSERT_TIED_METHOD;
6bcca55b
NC		 518
519 /* Ensure that our flag bits do not overlap. */
d682515d
NC		 520 assert((TIED_METHOD_MORTALIZE_NOT_NEEDED & G_WANT) == 0);
521 assert((TIED_METHOD_ARGUMENTS_ON_STACK & G_WANT) == 0);
94bc412f 522 assert((TIED_METHOD_SAY & G_WANT) == 0);
6bcca55b 523
d8ef3a16
DM		 524 PUTBACK; /* sp is at *foot* of args, so this pops args from old stack */
525 PUSHSTACKi(PERLSI_MAGIC);
526 EXTEND(SP, argc+1); /* object + args */
6bcca55b 527 PUSHMARK(sp);
d682515d 528 PUSHs(SvTIED_obj(sv, mg));
d8ef3a16
DM		 529 if (flags & TIED_METHOD_ARGUMENTS_ON_STACK) {
530 Copy(orig_sp + 2, sp + 1, argc, SV*); /* copy args to new stack */
1a8c1d59 531 sp += argc;
d8ef3a16 532 }
1a8c1d59 533 else if (argc) {
d682515d
NC		 534 const U32 mortalize_not_needed
535 = flags & TIED_METHOD_MORTALIZE_NOT_NEEDED;
6bcca55b 536 va_list args;
0d5509eb 537 va_start(args, argc);
6bcca55b
NC		 538 do {
539 SV *const arg = va_arg(args, SV *);
540 if(mortalize_not_needed)
541 PUSHs(arg);
542 else
543 mPUSHs(arg);
544 } while (--argc);
545 va_end(args);
546 }
547
548 PUTBACK;
d682515d 549 ENTER_with_name("call_tied_method");
94bc412f
NC		 550 if (flags & TIED_METHOD_SAY) {
551 /* local $\ = "\n" */
552 SAVEGENERICSV(PL_ors_sv);
553 PL_ors_sv = newSVpvs("\n");
554 }
d8ef3a16
DM		 555 ret_args = call_method(methname, flags & G_WANT);
556 SPAGAIN;
557 orig_sp = sp;
558 POPSTACK;
559 SPAGAIN;
560 if (ret_args) { /* copy results back to original stack */
561 EXTEND(sp, ret_args);
562 Copy(orig_sp - ret_args + 1, sp + 1, ret_args, SV*);
563 sp += ret_args;
564 PUTBACK;
565 }
d682515d 566 LEAVE_with_name("call_tied_method");
6bcca55b
NC		 567 return NORMAL;
568}
569
d682515d
NC		 570#define tied_method0(a,b,c,d) \
571 Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,0)
572#define tied_method1(a,b,c,d,e) \
573 Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,1,e)
574#define tied_method2(a,b,c,d,e,f) \
575 Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,2,e,f)
6bcca55b 576
a0d0e21e
LW		 577PP(pp_open)
578{
27da23d5 579 dVAR; dSP;
a567e93b
NIS		 580 dMARK; dORIGMARK;
581 dTARGET;
a0d0e21e 582 SV *sv;
5b468f54 583 IO *io;
5c144d81 584 const char *tmps;
a0d0e21e 585 STRLEN len;
a567e93b 586 bool ok;
a0d0e21e 587
159b6efe 588 GV * const gv = MUTABLE_GV(*++MARK);
c4420975 589
13be902c 590 if (!isGV(gv) && !(SvTYPE(gv) == SVt_PVLV && isGV_with_GP(gv)))
cea2e8a9 591 DIE(aTHX_ PL_no_usym, "filehandle");
abc718f2 592
a79db61d 593 if ((io = GvIOp(gv))) {
a5e1d062 594 const MAGIC *mg;
36477c24 595 IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
853846ea 596
a2a5de95 597 if (IoDIRP(io))
d1d15184
NC		 598 Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
599 "Opening dirhandle %s also as a file",
600 GvENAME(gv));
abc718f2 601
ad64d0ec 602 mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
c4420975
AL		 603 if (mg) {
604 /* Method's args are same as ours ... */
605 /* ... except handle is replaced by the object */
d682515d
NC		 606 return Perl_tied_method(aTHX_ "OPEN", mark - 1, MUTABLE_SV(io), mg,
607 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
608 sp - mark);
c4420975 609 }
4592e6ca
NIS		 610 }
611
a567e93b
NIS		 612 if (MARK < SP) {
613 sv = *++MARK;
614 }
615 else {
35a08ec7 616 sv = GvSVn(gv);
a567e93b
NIS		 617 }
618
5c144d81 619 tmps = SvPV_const(sv, len);
4608196e 620 ok = do_openn(gv, tmps, len, FALSE, O_RDONLY, 0, NULL, MARK+1, (SP-MARK));
a567e93b
NIS		 621 SP = ORIGMARK;
622 if (ok)
3280af22
NIS		 623 PUSHi( (I32)PL_forkprocess );
624 else if (PL_forkprocess == 0) /* we are a new child */
a0d0e21e
LW		 625 PUSHi(0);
626 else
627 RETPUSHUNDEF;
628 RETURN;
629}
630
631PP(pp_close)
632{
27da23d5 633 dVAR; dSP;
159b6efe 634 GV * const gv = (MAXARG == 0) ? PL_defoutgv : MUTABLE_GV(POPs);
1d603a67 635
2addaaf3
NC		 636 if (MAXARG == 0)
637 EXTEND(SP, 1);
638
a79db61d
AL		 639 if (gv) {
640 IO * const io = GvIO(gv);
641 if (io) {
a5e1d062 642 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
a79db61d 643 if (mg) {
d682515d 644 return tied_method0("CLOSE", SP, MUTABLE_SV(io), mg);
a79db61d
AL		 645 }
646 }
1d603a67 647 }
54310121 648 PUSHs(boolSV(do_close(gv, TRUE)));
a0d0e21e
LW		 649 RETURN;
650}
651
652PP(pp_pipe_op)
653{
a0d0e21e 654#ifdef HAS_PIPE
97aff369 655 dVAR;
9cad6237 656 dSP;
a0d0e21e
LW		 657 register IO *rstio;
658 register IO *wstio;
659 int fd[2];
660
159b6efe
NC		 661 GV * const wgv = MUTABLE_GV(POPs);
662 GV * const rgv = MUTABLE_GV(POPs);
a0d0e21e
LW		 663
664 if (!rgv || !wgv)
665 goto badexit;
666
6e592b3a 667 if (!isGV_with_GP(rgv) || !isGV_with_GP(wgv))
cea2e8a9 668 DIE(aTHX_ PL_no_usym, "filehandle");
a0d0e21e
LW		 669 rstio = GvIOn(rgv);
670 wstio = GvIOn(wgv);
671
672 if (IoIFP(rstio))
673 do_close(rgv, FALSE);
674 if (IoIFP(wstio))
675 do_close(wgv, FALSE);
676
6ad3d225 677 if (PerlProc_pipe(fd) < 0)
a0d0e21e
LW		 678 goto badexit;
679
460c8493
IZ		 680 IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"PIPE_OPEN_MODE);
681 IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"PIPE_OPEN_MODE);
b5ac89c3 682 IoOFP(rstio) = IoIFP(rstio);
a0d0e21e 683 IoIFP(wstio) = IoOFP(wstio);
50952442
JH		 684 IoTYPE(rstio) = IoTYPE_RDONLY;
685 IoTYPE(wstio) = IoTYPE_WRONLY;
a0d0e21e
LW		 686
687 if (!IoIFP(rstio) || !IoOFP(wstio)) {
a79db61d
AL		 688 if (IoIFP(rstio))
689 PerlIO_close(IoIFP(rstio));
690 else
691 PerlLIO_close(fd[0]);
692 if (IoOFP(wstio))
693 PerlIO_close(IoOFP(wstio));
694 else
695 PerlLIO_close(fd[1]);
a0d0e21e
LW		 696 goto badexit;
697 }
4771b018
GS		 698#if defined(HAS_FCNTL) && defined(F_SETFD)
699 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
700 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
701#endif
a0d0e21e
LW		 702 RETPUSHYES;
703
704badexit:
705 RETPUSHUNDEF;
706#else
cea2e8a9 707 DIE(aTHX_ PL_no_func, "pipe");
a0d0e21e
LW		 708#endif
709}
710
711PP(pp_fileno)
712{
27da23d5 713 dVAR; dSP; dTARGET;
a0d0e21e
LW		 714 GV *gv;
715 IO *io;
760ac839 716 PerlIO *fp;
a5e1d062 717 const MAGIC *mg;
4592e6ca 718
a0d0e21e
LW		 719 if (MAXARG < 1)
720 RETPUSHUNDEF;
159b6efe 721 gv = MUTABLE_GV(POPs);
9c9f25b8 722 io = GvIO(gv);
4592e6ca 723
9c9f25b8 724 if (io
ad64d0ec 725 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
5b468f54 726 {
d682515d 727 return tied_method0("FILENO", SP, MUTABLE_SV(io), mg);
4592e6ca
NIS		 728 }
729
9c9f25b8 730 if (!io || !(fp = IoIFP(io))) {
c289d2f7
JH		 731 /* Can't do this because people seem to do things like
732 defined(fileno($foo)) to check whether $foo is a valid fh.
51087808
NC		 733
734 report_evil_fh(gv);
c289d2f7 735 */
a0d0e21e 736 RETPUSHUNDEF;
c289d2f7
JH		 737 }
738
760ac839 739 PUSHi(PerlIO_fileno(fp));
a0d0e21e
LW		 740 RETURN;
741}
742
743PP(pp_umask)
744{
97aff369 745 dVAR;
27da23d5 746 dSP;
d7e492a4 747#ifdef HAS_UMASK
27da23d5 748 dTARGET;
761237fe 749 Mode_t anum;
a0d0e21e 750
a0d0e21e 751 if (MAXARG < 1) {
b0b546b3
GA		 752 anum = PerlLIO_umask(022);
753 /* setting it to 022 between the two calls to umask avoids
754 * to have a window where the umask is set to 0 -- meaning
755 * that another thread could create world-writeable files. */
756 if (anum != 022)
757 (void)PerlLIO_umask(anum);
a0d0e21e
LW		 758 }
759 else
6ad3d225 760 anum = PerlLIO_umask(POPi);
a0d0e21e
LW		 761 TAINT_PROPER("umask");
762 XPUSHi(anum);
763#else
a0288114 764 /* Only DIE if trying to restrict permissions on "user" (self).
eec2d3df
GS		 765 * Otherwise it's harmless and more useful to just return undef
766 * since 'group' and 'other' concepts probably don't exist here. */
767 if (MAXARG >= 1 && (POPi & 0700))
cea2e8a9 768 DIE(aTHX_ "umask not implemented");
6b88bc9c 769 XPUSHs(&PL_sv_undef);
a0d0e21e
LW		 770#endif
771 RETURN;
772}
773
774PP(pp_binmode)
775{
27da23d5 776 dVAR; dSP;
a0d0e21e
LW		 777 GV *gv;
778 IO *io;
760ac839 779 PerlIO *fp;
a0714e2c 780 SV *discp = NULL;
a0d0e21e
LW		 781
782 if (MAXARG < 1)
783 RETPUSHUNDEF;
60382766 784 if (MAXARG > 1) {
16fe6d59 785 discp = POPs;
60382766 786 }
a0d0e21e 787
159b6efe 788 gv = MUTABLE_GV(POPs);
9c9f25b8 789 io = GvIO(gv);
4592e6ca 790
9c9f25b8 791 if (io) {
a5e1d062 792 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
a79db61d 793 if (mg) {
bc0c81ca
NC		 794 /* This takes advantage of the implementation of the varargs
795 function, which I don't think that the optimiser will be able to
796 figure out. Although, as it's a static function, in theory it
797 could. */
d682515d
NC		 798 return Perl_tied_method(aTHX_ "BINMODE", SP, MUTABLE_SV(io), mg,
799 G_SCALAR|TIED_METHOD_MORTALIZE_NOT_NEEDED,
800 discp ? 1 : 0, discp);
a79db61d 801 }
4592e6ca 802 }
a0d0e21e 803
9c9f25b8 804 if (!io || !(fp = IoIFP(io))) {
51087808 805 report_evil_fh(gv);
b5fe5ca2 806 SETERRNO(EBADF,RMS_IFI);
50f846a7
SC		 807 RETPUSHUNDEF;
808 }
a0d0e21e 809
40d98b49 810 PUTBACK;
f0a78170 811 {
a79b25b7
VP		 812 STRLEN len = 0;
813 const char *d = NULL;
814 int mode;
815 if (discp)
816 d = SvPV_const(discp, len);
817 mode = mode_from_discipline(d, len);
f0a78170
NC		 818 if (PerlIO_binmode(aTHX_ fp, IoTYPE(io), mode, d)) {
819 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
820 if (!PerlIO_binmode(aTHX_ IoOFP(io), IoTYPE(io), mode, d)) {
821 SPAGAIN;
822 RETPUSHUNDEF;
823 }
824 }
825 SPAGAIN;
826 RETPUSHYES;
827 }
828 else {
829 SPAGAIN;
830 RETPUSHUNDEF;
38af81ff 831 }
40d98b49 832 }
a0d0e21e
LW		 833}
834
835PP(pp_tie)
836{
27da23d5 837 dVAR; dSP; dMARK;
a0d0e21e 838 HV* stash;
07822e36 839 GV *gv = NULL;
a0d0e21e 840 SV *sv;
1df70142 841 const I32 markoff = MARK - PL_stack_base;
e1ec3a88 842 const char *methname;
14befaf4 843 int how = PERL_MAGIC_tied;
e336de0d 844 U32 items;
c4420975 845 SV *varsv = *++MARK;
a0d0e21e 846
6b05c17a
NIS		 847 switch(SvTYPE(varsv)) {
848 case SVt_PVHV:
849 methname = "TIEHASH";
85fbaab2 850 HvEITER_set(MUTABLE_HV(varsv), 0);
6b05c17a
NIS		 851 break;
852 case SVt_PVAV:
853 methname = "TIEARRAY";
854 break;
855 case SVt_PVGV:
13be902c 856 case SVt_PVLV:
8bb5f786 857 if (isGV_with_GP(varsv) && !SvFAKE(varsv)) {
6e592b3a
BM		 858 methname = "TIEHANDLE";
859 how = PERL_MAGIC_tiedscalar;
860 /* For tied filehandles, we apply tiedscalar magic to the IO
861 slot of the GP rather than the GV itself. AMS 20010812 */
862 if (!GvIOp(varsv))
863 GvIOp(varsv) = newIO();
ad64d0ec 864 varsv = MUTABLE_SV(GvIOp(varsv));
6e592b3a
BM		 865 break;
866 }
867 /* FALL THROUGH */
6b05c17a
NIS		 868 default:
869 methname = "TIESCALAR";
14befaf4 870 how = PERL_MAGIC_tiedscalar;
6b05c17a
NIS		 871 break;
872 }
e336de0d 873 items = SP - MARK++;
a91d1d42 874 if (sv_isobject(*MARK)) { /* Calls GET magic. */
d343c3ef 875 ENTER_with_name("call_TIE");
e788e7d3 876 PUSHSTACKi(PERLSI_MAGIC);
e336de0d 877 PUSHMARK(SP);
eb160463 878 EXTEND(SP,(I32)items);
e336de0d
GS		 879 while (items--)
880 PUSHs(*MARK++);
881 PUTBACK;
864dbfa3 882 call_method(methname, G_SCALAR);
301e8125 883 }
6b05c17a 884 else {
086d2913
NC		 885 /* Can't use call_method here, else this: fileno FOO; tie @a, "FOO"
886 * will attempt to invoke IO::File::TIEARRAY, with (best case) the
887 * wrong error message, and worse case, supreme action at a distance.
888 * (Sorry obfuscation writers. You're not going to be given this one.)
6b05c17a 889 */
a91d1d42
VP		 890 STRLEN len;
891 const char *name = SvPV_nomg_const(*MARK, len);
892 stash = gv_stashpvn(name, len, 0);
6b05c17a 893 if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
35c1215d 894 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"",
a91d1d42 895 methname, SVfARG(SvOK(*MARK) ? *MARK : &PL_sv_no));
6b05c17a 896 }
d343c3ef 897 ENTER_with_name("call_TIE");
e788e7d3 898 PUSHSTACKi(PERLSI_MAGIC);
e336de0d 899 PUSHMARK(SP);
eb160463 900 EXTEND(SP,(I32)items);
e336de0d
GS		 901 while (items--)
902 PUSHs(*MARK++);
903 PUTBACK;
ad64d0ec 904 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
6b05c17a 905 }
a0d0e21e
LW		 906 SPAGAIN;
907
908 sv = TOPs;
d3acc0f7 909 POPSTACK;
a0d0e21e 910 if (sv_isobject(sv)) {
33c27489 911 sv_unmagic(varsv, how);
ae21d580 912 /* Croak if a self-tie on an aggregate is attempted. */
b881518d 913 if (varsv == SvRV(sv) &&
d87ebaca
YST		 914 (SvTYPE(varsv) == SVt_PVAV ||
915 SvTYPE(varsv) == SVt_PVHV))
ae21d580
JH		 916 Perl_croak(aTHX_
917 "Self-ties of arrays and hashes are not supported");
a0714e2c 918 sv_magic(varsv, (SvRV(sv) == varsv ? NULL : sv), how, NULL, 0);
a0d0e21e 919 }
d343c3ef 920 LEAVE_with_name("call_TIE");
3280af22 921 SP = PL_stack_base + markoff;
a0d0e21e
LW		 922 PUSHs(sv);
923 RETURN;
924}
925
926PP(pp_untie)
927{
27da23d5 928 dVAR; dSP;
5b468f54 929 MAGIC *mg;
33c27489 930 SV *sv = POPs;
1df70142 931 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
14befaf4 932 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
55497cff 933
ca0d4ed9 934 if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
5b468f54
AMS		 935 RETPUSHYES;
936
65eba18f 937 if ((mg = SvTIED_mg(sv, how))) {
1b6737cc 938 SV * const obj = SvRV(SvTIED_obj(sv, mg));
fa2b88e0 939 if (obj) {
c4420975 940 GV * const gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE);
0bd48802 941 CV *cv;
c4420975 942 if (gv && isGV(gv) && (cv = GvCV(gv))) {
fa2b88e0 943 PUSHMARK(SP);
c33ef3ac 944 PUSHs(SvTIED_obj(MUTABLE_SV(gv), mg));
6e449a3a 945 mXPUSHi(SvREFCNT(obj) - 1);
fa2b88e0 946 PUTBACK;
d343c3ef 947 ENTER_with_name("call_UNTIE");
ad64d0ec 948 call_sv(MUTABLE_SV(cv), G_VOID);
d343c3ef 949 LEAVE_with_name("call_UNTIE");
fa2b88e0
JS		 950 SPAGAIN;
951 }
a2a5de95
NC		 952 else if (mg && SvREFCNT(obj) > 1) {
953 Perl_ck_warner(aTHX_ packWARN(WARN_UNTIE),
954 "untie attempted while %"UVuf" inner references still exist",
955 (UV)SvREFCNT(obj) - 1 ) ;
c4420975 956 }
cbdc8872 957 }
958 }
38193a09 959 sv_unmagic(sv, how) ;
55497cff 960 RETPUSHYES;
a0d0e21e
LW		 961}
962
c07a80fd 963PP(pp_tied)
964{
97aff369 965 dVAR;
39644a26 966 dSP;
1b6737cc 967 const MAGIC *mg;
33c27489 968 SV *sv = POPs;
1df70142 969 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
14befaf4 970 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
5b468f54 971
4be76e1f 972 if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
5b468f54 973 RETPUSHUNDEF;
c07a80fd 974
155aba94 975 if ((mg = SvTIED_mg(sv, how))) {
33c27489
GS		 976 SV *osv = SvTIED_obj(sv, mg);
977 if (osv == mg->mg_obj)
978 osv = sv_mortalcopy(osv);
979 PUSHs(osv);
980 RETURN;
c07a80fd 981 }
c07a80fd 982 RETPUSHUNDEF;
983}
984
a0d0e21e
LW		 985PP(pp_dbmopen)
986{
27da23d5 987 dVAR; dSP;
a0d0e21e
LW		 988 dPOPPOPssrl;
989 HV* stash;
07822e36 990 GV *gv = NULL;
a0d0e21e 991
85fbaab2 992 HV * const hv = MUTABLE_HV(POPs);
84bafc02 993 SV * const sv = newSVpvs_flags("AnyDBM_File", SVs_TEMP);
da51bb9b 994 stash = gv_stashsv(sv, 0);
8ebc5c01 995 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
a0d0e21e 996 PUTBACK;
864dbfa3 997 require_pv("AnyDBM_File.pm");
a0d0e21e 998 SPAGAIN;
eff494dd 999 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH")))
cea2e8a9 1000 DIE(aTHX_ "No dbm on this machine");
a0d0e21e
LW		 1001 }
1002
57d3b86d 1003 ENTER;
924508f0 1004 PUSHMARK(SP);
6b05c17a 1005
924508f0 1006 EXTEND(SP, 5);
a0d0e21e
LW		 1007 PUSHs(sv);
1008 PUSHs(left);
1009 if (SvIV(right))
6e449a3a 1010 mPUSHu(O_RDWR|O_CREAT);
a0d0e21e 1011 else
6e449a3a 1012 mPUSHu(O_RDWR);
a0d0e21e 1013 PUSHs(right);
57d3b86d 1014 PUTBACK;
ad64d0ec 1015 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
a0d0e21e
LW		 1016 SPAGAIN;
1017
1018 if (!sv_isobject(TOPs)) {
924508f0
GS		 1019 SP--;
1020 PUSHMARK(SP);
a0d0e21e
LW		 1021 PUSHs(sv);
1022 PUSHs(left);
6e449a3a 1023 mPUSHu(O_RDONLY);
a0d0e21e 1024 PUSHs(right);
a0d0e21e 1025 PUTBACK;
ad64d0ec 1026 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
a0d0e21e
LW		 1027 SPAGAIN;
1028 }
1029
6b05c17a 1030 if (sv_isobject(TOPs)) {
ad64d0ec
NC		 1031 sv_unmagic(MUTABLE_SV(hv), PERL_MAGIC_tied);
1032 sv_magic(MUTABLE_SV(hv), TOPs, PERL_MAGIC_tied, NULL, 0);
6b05c17a 1033 }
a0d0e21e
LW		 1034 LEAVE;
1035 RETURN;
1036}
1037
a0d0e21e
LW		 1038PP(pp_sselect)
1039{
a0d0e21e 1040#ifdef HAS_SELECT
97aff369 1041 dVAR; dSP; dTARGET;
a0d0e21e
LW		 1042 register I32 i;
1043 register I32 j;
1044 register char *s;
1045 register SV *sv;
65202027 1046 NV value;
a0d0e21e
LW		 1047 I32 maxlen = 0;
1048 I32 nfound;
1049 struct timeval timebuf;
1050 struct timeval *tbuf = &timebuf;
1051 I32 growsize;
1052 char *fd_sets[4];
1053#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1054 I32 masksize;
1055 I32 offset;
1056 I32 k;
1057
1058# if BYTEORDER & 0xf0000
1059# define ORDERBYTE (0x88888888 - BYTEORDER)
1060# else
1061# define ORDERBYTE (0x4444 - BYTEORDER)
1062# endif
1063
1064#endif
1065
1066 SP -= 4;
1067 for (i = 1; i <= 3; i++) {
c4420975 1068 SV * const sv = SP[i];
15547071
GA		 1069 if (!SvOK(sv))
1070 continue;
1071 if (SvREADONLY(sv)) {
729c079f
NC		 1072 if (SvIsCOW(sv))
1073 sv_force_normal_flags(sv, 0);
15547071 1074 if (SvREADONLY(sv) && !(SvPOK(sv) && SvCUR(sv) == 0))
6ad8f254 1075 Perl_croak_no_modify(aTHX);
729c079f 1076 }
4ef2275c 1077 if (!SvPOK(sv)) {
a2a5de95 1078 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Non-string passed as bitmask");
4ef2275c
GA		 1079 SvPV_force_nolen(sv); /* force string conversion */
1080 }
729c079f 1081 j = SvCUR(sv);
a0d0e21e
LW		 1082 if (maxlen < j)
1083 maxlen = j;
1084 }
1085
5ff3f7a4 1086/* little endians can use vecs directly */
e366b469 1087#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
5ff3f7a4 1088# ifdef NFDBITS
a0d0e21e 1089
5ff3f7a4
GS		 1090# ifndef NBBY
1091# define NBBY 8
1092# endif
a0d0e21e
LW		 1093
1094 masksize = NFDBITS / NBBY;
5ff3f7a4 1095# else
a0d0e21e 1096 masksize = sizeof(long); /* documented int, everyone seems to use long */
5ff3f7a4 1097# endif
a0d0e21e
LW		 1098 Zero(&fd_sets[0], 4, char*);
1099#endif
1100
ad517f75
MHM		 1101# if SELECT_MIN_BITS == 1
1102 growsize = sizeof(fd_set);
1103# else
1104# if defined(__GLIBC__) && defined(__FD_SETSIZE)
1105# undef SELECT_MIN_BITS
1106# define SELECT_MIN_BITS __FD_SETSIZE
1107# endif
e366b469
PG		 1108 /* If SELECT_MIN_BITS is greater than one we most probably will want
1109 * to align the sizes with SELECT_MIN_BITS/8 because for example
1110 * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
1111 * UNIX, Solaris, NeXT, Darwin) the smallest quantum select() operates
1112 * on (sets/tests/clears bits) is 32 bits. */
1113 growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
e366b469
PG		 1114# endif
1115
a0d0e21e
LW		 1116 sv = SP[4];
1117 if (SvOK(sv)) {
1118 value = SvNV(sv);
1119 if (value < 0.0)
1120 value = 0.0;
1121 timebuf.tv_sec = (long)value;
65202027 1122 value -= (NV)timebuf.tv_sec;
a0d0e21e
LW		 1123 timebuf.tv_usec = (long)(value * 1000000.0);
1124 }
1125 else
4608196e 1126 tbuf = NULL;
a0d0e21e
LW		 1127
1128 for (i = 1; i <= 3; i++) {
1129 sv = SP[i];
15547071 1130 if (!SvOK(sv) || SvCUR(sv) == 0) {
a0d0e21e
LW		 1131 fd_sets[i] = 0;
1132 continue;
1133 }
4ef2275c 1134 assert(SvPOK(sv));
a0d0e21e
LW		 1135 j = SvLEN(sv);
1136 if (j < growsize) {
1137 Sv_Grow(sv, growsize);
a0d0e21e 1138 }
c07a80fd 1139 j = SvCUR(sv);
1140 s = SvPVX(sv) + j;
1141 while (++j <= growsize) {
1142 *s++ = '\0';
1143 }
1144
a0d0e21e
LW		 1145#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1146 s = SvPVX(sv);
a02a5408 1147 Newx(fd_sets[i], growsize, char);
a0d0e21e
LW		 1148 for (offset = 0; offset < growsize; offset += masksize) {
1149 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1150 fd_sets[i][j+offset] = s[(k % masksize) + offset];
1151 }
1152#else
1153 fd_sets[i] = SvPVX(sv);
1154#endif
1155 }
1156
dc4c69d9
JH		 1157#ifdef PERL_IRIX5_SELECT_TIMEVAL_VOID_CAST
1158 /* Can't make just the (void*) conditional because that would be
1159 * cpp #if within cpp macro, and not all compilers like that. */
1160 nfound = PerlSock_select(
1161 maxlen * 8,
1162 (Select_fd_set_t) fd_sets[1],
1163 (Select_fd_set_t) fd_sets[2],
1164 (Select_fd_set_t) fd_sets[3],
1165 (void*) tbuf); /* Workaround for compiler bug. */
1166#else
6ad3d225 1167 nfound = PerlSock_select(
a0d0e21e
LW		 1168 maxlen * 8,
1169 (Select_fd_set_t) fd_sets[1],
1170 (Select_fd_set_t) fd_sets[2],
1171 (Select_fd_set_t) fd_sets[3],
1172 tbuf);
dc4c69d9 1173#endif
a0d0e21e
LW		 1174 for (i = 1; i <= 3; i++) {
1175 if (fd_sets[i]) {
1176 sv = SP[i];
1177#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1178 s = SvPVX(sv);
1179 for (offset = 0; offset < growsize; offset += masksize) {
1180 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1181 s[(k % masksize) + offset] = fd_sets[i][j+offset];
1182 }
1183 Safefree(fd_sets[i]);
1184#endif
1185 SvSETMAGIC(sv);
1186 }
1187 }
1188
4189264e 1189 PUSHi(nfound);
a0d0e21e 1190 if (GIMME == G_ARRAY && tbuf) {
65202027
DS		 1191 value = (NV)(timebuf.tv_sec) +
1192 (NV)(timebuf.tv_usec) / 1000000.0;
6e449a3a 1193 mPUSHn(value);
a0d0e21e
LW		 1194 }
1195 RETURN;
1196#else
cea2e8a9 1197 DIE(aTHX_ "select not implemented");
a0d0e21e
LW		 1198#endif
1199}
1200
8226a3d7
NC		 1201/*
1202=for apidoc setdefout
1203
1204Sets PL_defoutgv, the default file handle for output, to the passed in
1205typeglob. As PL_defoutgv "owns" a reference on its typeglob, the reference
1206count of the passed in typeglob is increased by one, and the reference count
1207of the typeglob that PL_defoutgv points to is decreased by one.
1208
1209=cut
1210*/
1211
4633a7c4 1212void
864dbfa3 1213Perl_setdefout(pTHX_ GV *gv)
4633a7c4 1214{
97aff369 1215 dVAR;
b37c2d43 1216 SvREFCNT_inc_simple_void(gv);
ef8d46e8 1217 SvREFCNT_dec(PL_defoutgv);
3280af22 1218 PL_defoutgv = gv;
4633a7c4
LW		 1219}
1220
a0d0e21e
LW		 1221PP(pp_select)
1222{
97aff369 1223 dVAR; dSP; dTARGET;
4633a7c4 1224 HV *hv;
159b6efe 1225 GV * const newdefout = (PL_op->op_private > 0) ? (MUTABLE_GV(POPs)) : NULL;
099be4f1 1226 GV * egv = GvEGVx(PL_defoutgv);
4633a7c4 1227
4633a7c4 1228 if (!egv)
3280af22 1229 egv = PL_defoutgv;
099be4f1 1230 hv = isGV_with_GP(egv) ? GvSTASH(egv) : NULL;
4633a7c4 1231 if (! hv)
3280af22 1232 XPUSHs(&PL_sv_undef);
4633a7c4 1233 else {
c4420975 1234 GV * const * const gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
f86702cc 1235 if (gvp && *gvp == egv) {
bd61b366 1236 gv_efullname4(TARG, PL_defoutgv, NULL, TRUE);
f86702cc 1237 XPUSHTARG;
1238 }
1239 else {
ad64d0ec 1240 mXPUSHs(newRV(MUTABLE_SV(egv)));
f86702cc 1241 }
4633a7c4
LW		 1242 }
1243
1244 if (newdefout) {
ded8aa31
GS		 1245 if (!GvIO(newdefout))
1246 gv_IOadd(newdefout);
4633a7c4
LW		 1247 setdefout(newdefout);
1248 }
1249
a0d0e21e
LW		 1250 RETURN;
1251}
1252
1253PP(pp_getc)
1254{
27da23d5 1255 dVAR; dSP; dTARGET;
159b6efe 1256 GV * const gv = (MAXARG==0) ? PL_stdingv : MUTABLE_GV(POPs);
9c9f25b8 1257 IO *const io = GvIO(gv);
2ae324a7 1258
ac3697cd
NC		 1259 if (MAXARG == 0)
1260 EXTEND(SP, 1);
1261
9c9f25b8 1262 if (io) {
a5e1d062 1263 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
a79db61d 1264 if (mg) {
0240605e 1265 const U32 gimme = GIMME_V;
d682515d 1266 Perl_tied_method(aTHX_ "GETC", SP, MUTABLE_SV(io), mg, gimme, 0);
0240605e
NC		 1267 if (gimme == G_SCALAR) {
1268 SPAGAIN;
a79db61d 1269 SvSetMagicSV_nosteal(TARG, TOPs);
0240605e
NC		 1270 }
1271 return NORMAL;
a79db61d 1272 }
2ae324a7 1273 }
90133b69 1274 if (!gv || do_eof(gv)) { /* make sure we have fp with something */
51087808 1275 if (!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY))
831e4cc3 1276 report_evil_fh(gv);
b5fe5ca2 1277 SETERRNO(EBADF,RMS_IFI);
a0d0e21e 1278 RETPUSHUNDEF;
90133b69 1279 }
bbce6d69 1280 TAINT;
76f68e9b 1281 sv_setpvs(TARG, " ");
9bc64814 1282 *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
7d59b7e4
NIS		 1283 if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) {
1284 /* Find out how many bytes the char needs */
aa07b2f6 1285 Size_t len = UTF8SKIP(SvPVX_const(TARG));
7d59b7e4
NIS		 1286 if (len > 1) {
1287 SvGROW(TARG,len+1);
1288 len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1);
1289 SvCUR_set(TARG,1+len);
1290 }
1291 SvUTF8_on(TARG);
1292 }
a0d0e21e
LW		 1293 PUSHTARG;
1294 RETURN;
1295}
1296
76e3520e 1297STATIC OP *
cea2e8a9 1298S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
a0d0e21e 1299{
27da23d5 1300 dVAR;
c09156bb 1301 register PERL_CONTEXT *cx;
f54cb97a 1302 const I32 gimme = GIMME_V;
a0d0e21e 1303
7918f24d
NC		 1304 PERL_ARGS_ASSERT_DOFORM;
1305
7b190374
NC		 1306 if (cv && CvCLONE(cv))
1307 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
1308
a0d0e21e
LW		 1309 ENTER;
1310 SAVETMPS;
1311
146174a9 1312 PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
10067d9a 1313 PUSHFORMAT(cx, retop);
fd617465
DM		 1314 SAVECOMPPAD();
1315 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
a0d0e21e 1316
4633a7c4 1317 setdefout(gv); /* locally select filehandle so $% et al work */
a0d0e21e
LW		 1318 return CvSTART(cv);
1319}
1320
1321PP(pp_enterwrite)
1322{
97aff369 1323 dVAR;
39644a26 1324 dSP;
a0d0e21e
LW		 1325 register GV *gv;
1326 register IO *io;
1327 GV *fgv;
07822e36
JH		 1328 CV *cv = NULL;
1329 SV *tmpsv = NULL;
a0d0e21e 1330
2addaaf3 1331 if (MAXARG == 0) {
3280af22 1332 gv = PL_defoutgv;
2addaaf3
NC		 1333 EXTEND(SP, 1);
1334 }
a0d0e21e 1335 else {
159b6efe 1336 gv = MUTABLE_GV(POPs);
a0d0e21e 1337 if (!gv)
3280af22 1338 gv = PL_defoutgv;
a0d0e21e 1339 }
a0d0e21e
LW		 1340 io = GvIO(gv);
1341 if (!io) {
1342 RETPUSHNO;
1343 }
1344 if (IoFMT_GV(io))
1345 fgv = IoFMT_GV(io);
1346 else
1347 fgv = gv;
1348
a79db61d
AL		 1349 if (!fgv)
1350 goto not_a_format_reference;
1351
a0d0e21e 1352 cv = GvFORM(fgv);
a0d0e21e 1353 if (!cv) {
f4a7049d 1354 const char *name;
10edeb5d 1355 tmpsv = sv_newmortal();
f4a7049d
NC		 1356 gv_efullname4(tmpsv, fgv, NULL, FALSE);
1357 name = SvPV_nolen_const(tmpsv);
1358 if (name && *name)
1359 DIE(aTHX_ "Undefined format \"%s\" called", name);
a79db61d
AL		 1360
1361 not_a_format_reference:
cea2e8a9 1362 DIE(aTHX_ "Not a format reference");
a0d0e21e 1363 }
44a8e56a 1364 IoFLAGS(io) &= ~IOf_DIDTOP;
533c011a 1365 return doform(cv,gv,PL_op->op_next);
a0d0e21e
LW		 1366}
1367
1368PP(pp_leavewrite)
1369{
27da23d5 1370 dVAR; dSP;
f9c764c5 1371 GV * const gv = cxstack[cxstack_ix].blk_format.gv;
1b6737cc 1372 register IO * const io = GvIOp(gv);
8b8cacda 1373 PerlIO *ofp;
760ac839 1374 PerlIO *fp;
8772537c
AL		 1375 SV **newsp;
1376 I32 gimme;
c09156bb 1377 register PERL_CONTEXT *cx;
8f89e5a9 1378 OP *retop;
a0d0e21e 1379
8b8cacda
B		 1380 if (!io || !(ofp = IoOFP(io)))
1381 goto forget_top;
1382
760ac839 1383 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
3280af22 1384 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
8b8cacda 1385
3280af22
NIS		 1386 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1387 PL_formtarget != PL_toptarget)
a0d0e21e 1388 {
4633a7c4
LW		 1389 GV *fgv;
1390 CV *cv;
a0d0e21e
LW		 1391 if (!IoTOP_GV(io)) {
1392 GV *topgv;
a0d0e21e
LW		 1393
1394 if (!IoTOP_NAME(io)) {
1b6737cc 1395 SV *topname;
a0d0e21e
LW		 1396 if (!IoFMT_NAME(io))
1397 IoFMT_NAME(io) = savepv(GvNAME(gv));
0bd0581c 1398 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%s_TOP", GvNAME(gv)));
f776e3cd 1399 topgv = gv_fetchsv(topname, 0, SVt_PVFM);
748a9306 1400 if ((topgv && GvFORM(topgv)) ||
fafc274c 1401 !gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM))
2e0de35c 1402 IoTOP_NAME(io) = savesvpv(topname);
a0d0e21e 1403 else
89529cee 1404 IoTOP_NAME(io) = savepvs("top");
a0d0e21e 1405 }
f776e3cd 1406 topgv = gv_fetchpv(IoTOP_NAME(io), 0, SVt_PVFM);
a0d0e21e 1407 if (!topgv || !GvFORM(topgv)) {
b929a54b 1408 IoLINES_LEFT(io) = IoPAGE_LEN(io);
a0d0e21e
LW		 1409 goto forget_top;
1410 }
1411 IoTOP_GV(io) = topgv;
1412 }
748a9306
LW		 1413 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1414 I32 lines = IoLINES_LEFT(io);
504618e9 1415 const char *s = SvPVX_const(PL_formtarget);
8e07c86e
AD		 1416 if (lines <= 0) /* Yow, header didn't even fit!!! */
1417 goto forget_top;
748a9306
LW		 1418 while (lines-- > 0) {
1419 s = strchr(s, '\n');
1420 if (!s)
1421 break;
1422 s++;
1423 }
1424 if (s) {
f54cb97a 1425 const STRLEN save = SvCUR(PL_formtarget);
aa07b2f6 1426 SvCUR_set(PL_formtarget, s - SvPVX_const(PL_formtarget));
d75029d0
NIS		 1427 do_print(PL_formtarget, ofp);
1428 SvCUR_set(PL_formtarget, save);
3280af22
NIS		 1429 sv_chop(PL_formtarget, s);
1430 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
748a9306
LW		 1431 }
1432 }
a0d0e21e 1433 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
d75029d0 1434 do_print(PL_formfeed, ofp);
a0d0e21e
LW		 1435 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1436 IoPAGE(io)++;
3280af22 1437 PL_formtarget = PL_toptarget;
748a9306 1438 IoFLAGS(io) |= IOf_DIDTOP;
4633a7c4
LW		 1439 fgv = IoTOP_GV(io);
1440 if (!fgv)
cea2e8a9 1441 DIE(aTHX_ "bad top format reference");
4633a7c4 1442 cv = GvFORM(fgv);
1df70142
AL		 1443 if (!cv) {
1444 SV * const sv = sv_newmortal();
b464bac0 1445 const char *name;
bd61b366 1446 gv_efullname4(sv, fgv, NULL, FALSE);
e62f0680 1447 name = SvPV_nolen_const(sv);
2dd78f96 1448 if (name && *name)
0e528f24
JH		 1449 DIE(aTHX_ "Undefined top format \"%s\" called", name);
1450 else
1451 DIE(aTHX_ "Undefined top format called");
4633a7c4 1452 }
0e528f24 1453 return doform(cv, gv, PL_op);
a0d0e21e
LW		 1454 }
1455
1456 forget_top:
3280af22 1457 POPBLOCK(cx,PL_curpm);
a0d0e21e 1458 POPFORMAT(cx);
8f89e5a9 1459 retop = cx->blk_sub.retop;
a0d0e21e
LW		 1460 LEAVE;
1461
1462 fp = IoOFP(io);
1463 if (!fp) {
7716c5c5
NC		 1464 if (IoIFP(io))
1465 report_wrongway_fh(gv, '<');
c521cf7c 1466 else
7716c5c5 1467 report_evil_fh(gv);
3280af22 1468 PUSHs(&PL_sv_no);
a0d0e21e
LW		 1469 }
1470 else {
3280af22 1471 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
a2a5de95 1472 Perl_ck_warner(aTHX_ packWARN(WARN_IO), "page overflow");
a0d0e21e 1473 }
d75029d0 1474 if (!do_print(PL_formtarget, fp))
3280af22 1475 PUSHs(&PL_sv_no);
a0d0e21e 1476 else {
3280af22
NIS		 1477 FmLINES(PL_formtarget) = 0;
1478 SvCUR_set(PL_formtarget, 0);
1479 *SvEND(PL_formtarget) = '\0';
a0d0e21e 1480 if (IoFLAGS(io) & IOf_FLUSH)
760ac839 1481 (void)PerlIO_flush(fp);
3280af22 1482 PUSHs(&PL_sv_yes);
a0d0e21e
LW		 1483 }
1484 }
9cbac4c7 1485 /* bad_ofp: */
3280af22 1486 PL_formtarget = PL_bodytarget;
a0d0e21e 1487 PUTBACK;
29033a8a
SH		 1488 PERL_UNUSED_VAR(newsp);
1489 PERL_UNUSED_VAR(gimme);
8f89e5a9 1490 return retop;
a0d0e21e
LW		 1491}
1492
1493PP(pp_prtf)
1494{
27da23d5 1495 dVAR; dSP; dMARK; dORIGMARK;
760ac839 1496 PerlIO *fp;
26db47c4 1497 SV *sv;
a0d0e21e 1498
159b6efe
NC		 1499 GV * const gv
1500 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
9c9f25b8 1501 IO *const io = GvIO(gv);
46fc3d4c 1502
9c9f25b8 1503 if (io) {
a5e1d062 1504 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
a79db61d
AL		 1505 if (mg) {
1506 if (MARK == ORIGMARK) {
1507 MEXTEND(SP, 1);
1508 ++MARK;
1509 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1510 ++SP;
1511 }
d682515d
NC		 1512 return Perl_tied_method(aTHX_ "PRINTF", mark - 1, MUTABLE_SV(io),
1513 mg,
1514 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1515 sp - mark);
a79db61d 1516 }
46fc3d4c 1517 }
1518
561b68a9 1519 sv = newSV(0);
9c9f25b8 1520 if (!io) {
51087808 1521 report_evil_fh(gv);
93189314 1522 SETERRNO(EBADF,RMS_IFI);
a0d0e21e
LW		 1523 goto just_say_no;
1524 }
1525 else if (!(fp = IoOFP(io))) {
7716c5c5
NC		 1526 if (IoIFP(io))
1527 report_wrongway_fh(gv, '<');
1528 else if (ckWARN(WARN_CLOSED))
1529 report_evil_fh(gv);
93189314 1530 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
a0d0e21e
LW		 1531 goto just_say_no;
1532 }
1533 else {
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 2836 mPUSHi(PL_statcache.st_dev);
8d8cba88
TC		 2837#if ST_INO_SIZE > IVSIZE
2838 mPUSHn(PL_statcache.st_ino);
2839#else
2840# if ST_INO_SIGN <= 0
6e449a3a 2841 mPUSHi(PL_statcache.st_ino);
8d8cba88
TC		 2842# else
2843 mPUSHu(PL_statcache.st_ino);
2844# endif
2845#endif
6e449a3a
MHM		 2846 mPUSHu(PL_statcache.st_mode);
2847 mPUSHu(PL_statcache.st_nlink);
146174a9 2848#if Uid_t_size > IVSIZE
6e449a3a 2849 mPUSHn(PL_statcache.st_uid);
146174a9 2850#else
23dcd6c8 2851# if Uid_t_sign <= 0
6e449a3a 2852 mPUSHi(PL_statcache.st_uid);
23dcd6c8 2853# else
6e449a3a 2854 mPUSHu(PL_statcache.st_uid);
23dcd6c8 2855# endif
146174a9 2856#endif
301e8125 2857#if Gid_t_size > IVSIZE
6e449a3a 2858 mPUSHn(PL_statcache.st_gid);
146174a9 2859#else
23dcd6c8 2860# if Gid_t_sign <= 0
6e449a3a 2861 mPUSHi(PL_statcache.st_gid);
23dcd6c8 2862# else
6e449a3a 2863 mPUSHu(PL_statcache.st_gid);
23dcd6c8 2864# endif
146174a9 2865#endif
cbdc8872 2866#ifdef USE_STAT_RDEV
6e449a3a 2867 mPUSHi(PL_statcache.st_rdev);
cbdc8872 2868#else
84bafc02 2869 PUSHs(newSVpvs_flags("", SVs_TEMP));
cbdc8872 2870#endif
146174a9 2871#if Off_t_size > IVSIZE
6e449a3a 2872 mPUSHn(PL_statcache.st_size);
146174a9 2873#else
6e449a3a 2874 mPUSHi(PL_statcache.st_size);
146174a9 2875#endif
cbdc8872 2876#ifdef BIG_TIME
6e449a3a
MHM		 2877 mPUSHn(PL_statcache.st_atime);
2878 mPUSHn(PL_statcache.st_mtime);
2879 mPUSHn(PL_statcache.st_ctime);
cbdc8872 2880#else
6e449a3a
MHM		 2881 mPUSHi(PL_statcache.st_atime);
2882 mPUSHi(PL_statcache.st_mtime);
2883 mPUSHi(PL_statcache.st_ctime);
cbdc8872 2884#endif
a0d0e21e 2885#ifdef USE_STAT_BLOCKS
6e449a3a
MHM		 2886 mPUSHu(PL_statcache.st_blksize);
2887 mPUSHu(PL_statcache.st_blocks);
a0d0e21e 2888#else
84bafc02
NC		 2889 PUSHs(newSVpvs_flags("", SVs_TEMP));
2890 PUSHs(newSVpvs_flags("", SVs_TEMP));
a0d0e21e
LW		 2891#endif
2892 }
2893 RETURN;
2894}
2895
6f1401dc
DM		 2896#define tryAMAGICftest_MG(chr) STMT_START { \
2897 if ( (SvFLAGS(TOPs) & (SVf_ROK|SVs_GMG)) \
2898 && S_try_amagic_ftest(aTHX_ chr)) \
2899 return NORMAL; \
2900 } STMT_END
2901
2902STATIC bool
2903S_try_amagic_ftest(pTHX_ char chr) {
2904 dVAR;
2905 dSP;
2906 SV* const arg = TOPs;
2907
2908 assert(chr != '?');
2909 SvGETMAGIC(arg);
2910
2911 if ((PL_op->op_flags & OPf_KIDS)
2912 && SvAMAGIC(TOPs))
2913 {
2914 const char tmpchr = chr;
6f1401dc
DM		 2915 SV * const tmpsv = amagic_call(arg,
2916 newSVpvn_flags(&tmpchr, 1, SVs_TEMP),
2917 ftest_amg, AMGf_unary);
2918
2919 if (!tmpsv)
2920 return FALSE;
2921
2922 SPAGAIN;
2923
bbd91306 2924 if (PL_op->op_private & OPpFT_STACKING) {
6f1401dc
DM		 2925 if (SvTRUE(tmpsv))
2926 /* leave the object alone */
2927 return TRUE;
2928 }
2929
2930 SETs(tmpsv);
2931 PUTBACK;
2932 return TRUE;
2933 }
2934 return FALSE;
2935}
2936
2937
fbb0b3b3
RGS		 2938/* This macro is used by the stacked filetest operators :
2939 * if the previous filetest failed, short-circuit and pass its value.
2940 * Else, discard it from the stack and continue. --rgs
2941 */
2942#define STACKED_FTEST_CHECK if (PL_op->op_private & OPpFT_STACKED) { \
d724f706 2943 if (!SvTRUE(TOPs)) { RETURN; } \
fbb0b3b3
RGS		 2944 else { (void)POPs; PUTBACK; } \
2945 }
2946
a0d0e21e
LW		 2947PP(pp_ftrread)
2948{
97aff369 2949 dVAR;
9cad6237 2950 I32 result;
af9e49b4
NC		 2951 /* Not const, because things tweak this below. Not bool, because there's
2952 no guarantee that OPp_FT_ACCESS is <= CHAR_MAX */
2953#if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
2954 I32 use_access = PL_op->op_private & OPpFT_ACCESS;
2955 /* Giving some sort of initial value silences compilers. */
2956# ifdef R_OK
2957 int access_mode = R_OK;
2958# else
2959 int access_mode = 0;
2960# endif
5ff3f7a4 2961#else
af9e49b4
NC		 2962 /* access_mode is never used, but leaving use_access in makes the
2963 conditional compiling below much clearer. */
2964 I32 use_access = 0;
5ff3f7a4 2965#endif
2dcac756 2966 Mode_t stat_mode = S_IRUSR;
a0d0e21e 2967
af9e49b4 2968 bool effective = FALSE;
07fe7c6a 2969 char opchar = '?';
2a3ff820 2970 dSP;
af9e49b4 2971
7fb13887
BM		 2972 switch (PL_op->op_type) {
2973 case OP_FTRREAD: opchar = 'R'; break;
2974 case OP_FTRWRITE: opchar = 'W'; break;
2975 case OP_FTREXEC: opchar = 'X'; break;
2976 case OP_FTEREAD: opchar = 'r'; break;
2977 case OP_FTEWRITE: opchar = 'w'; break;
2978 case OP_FTEEXEC: opchar = 'x'; break;
2979 }
6f1401dc 2980 tryAMAGICftest_MG(opchar);
7fb13887 2981
fbb0b3b3 2982 STACKED_FTEST_CHECK;
af9e49b4
NC		 2983
2984 switch (PL_op->op_type) {
2985 case OP_FTRREAD:
2986#if !(defined(HAS_ACCESS) && defined(R_OK))
2987 use_access = 0;
2988#endif
2989 break;
2990
2991 case OP_FTRWRITE:
5ff3f7a4 2992#if defined(HAS_ACCESS) && defined(W_OK)
af9e49b4 2993 access_mode = W_OK;
5ff3f7a4 2994#else
af9e49b4 2995 use_access = 0;
5ff3f7a4 2996#endif
af9e49b4
NC		 2997 stat_mode = S_IWUSR;
2998 break;
a0d0e21e 2999
af9e49b4 3000 case OP_FTREXEC:
5ff3f7a4 3001#if defined(HAS_ACCESS) && defined(X_OK)
af9e49b4 3002 access_mode = X_OK;
5ff3f7a4 3003#else
af9e49b4 3004 use_access = 0;
5ff3f7a4 3005#endif
af9e49b4
NC		 3006 stat_mode = S_IXUSR;
3007 break;
a0d0e21e 3008
af9e49b4 3009 case OP_FTEWRITE:
faee0e31 3010#ifdef PERL_EFF_ACCESS
af9e49b4 3011 access_mode = W_OK;
5ff3f7a4 3012#endif
af9e49b4 3013 stat_mode = S_IWUSR;
7fb13887 3014 /* fall through */
a0d0e21e 3015
af9e49b4
NC		 3016 case OP_FTEREAD:
3017#ifndef PERL_EFF_ACCESS
3018 use_access = 0;
3019#endif
3020 effective = TRUE;
3021 break;
3022
af9e49b4 3023 case OP_FTEEXEC:
faee0e31 3024#ifdef PERL_EFF_ACCESS
b376053d 3025 access_mode = X_OK;
5ff3f7a4 3026#else
af9e49b4 3027 use_access = 0;
5ff3f7a4 3028#endif
af9e49b4
NC		 3029 stat_mode = S_IXUSR;
3030 effective = TRUE;
3031 break;
3032 }
a0d0e21e 3033
af9e49b4
NC		 3034 if (use_access) {
3035#if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
2c2f35ab 3036 const char *name = POPpx;
af9e49b4
NC		 3037 if (effective) {
3038# ifdef PERL_EFF_ACCESS
3039 result = PERL_EFF_ACCESS(name, access_mode);
3040# else
3041 DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3042 OP_NAME(PL_op));
3043# endif
3044 }
3045 else {
3046# ifdef HAS_ACCESS
3047 result = access(name, access_mode);
3048# else
3049 DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3050# endif
3051 }
5ff3f7a4
GS		 3052 if (result == 0)
3053 RETPUSHYES;
3054 if (result < 0)
3055 RETPUSHUNDEF;
3056 RETPUSHNO;
af9e49b4 3057#endif
22865c03 3058 }
af9e49b4 3059
40c852de 3060 result = my_stat_flags(0);
22865c03 3061 SPAGAIN;
a0d0e21e
LW		 3062 if (result < 0)
3063 RETPUSHUNDEF;
af9e49b4 3064 if (cando(stat_mode, effective, &PL_statcache))
a0d0e21e
LW		 3065 RETPUSHYES;
3066 RETPUSHNO;
3067}
3068
3069PP(pp_ftis)
3070{
97aff369 3071 dVAR;
fbb0b3b3 3072 I32 result;
d7f0a2f4 3073 const int op_type = PL_op->op_type;
07fe7c6a 3074 char opchar = '?';
2a3ff820 3075 dSP;
07fe7c6a
BM		 3076
3077 switch (op_type) {
3078 case OP_FTIS: opchar = 'e'; break;
3079 case OP_FTSIZE: opchar = 's'; break;
3080 case OP_FTMTIME: opchar = 'M'; break;
3081 case OP_FTCTIME: opchar = 'C'; break;
3082 case OP_FTATIME: opchar = 'A'; break;
3083 }
6f1401dc 3084 tryAMAGICftest_MG(opchar);
07fe7c6a 3085
fbb0b3b3 3086 STACKED_FTEST_CHECK;
7fb13887 3087
40c852de 3088 result = my_stat_flags(0);
fbb0b3b3 3089 SPAGAIN;
a0d0e21e
LW		 3090 if (result < 0)
3091 RETPUSHUNDEF;
d7f0a2f4
NC		 3092 if (op_type == OP_FTIS)
3093 RETPUSHYES;
957b0e1d 3094 {
d7f0a2f4
NC		 3095 /* You can't dTARGET inside OP_FTIS, because you'll get
3096 "panic: pad_sv po" - the op is not flagged to have a target. */
957b0e1d 3097 dTARGET;
d7f0a2f4 3098 switch (op_type) {
957b0e1d
NC		 3099 case OP_FTSIZE:
3100#if Off_t_size > IVSIZE
3101 PUSHn(PL_statcache.st_size);
3102#else
3103 PUSHi(PL_statcache.st_size);
3104#endif
3105 break;
3106 case OP_FTMTIME:
3107 PUSHn( (((NV)PL_basetime - PL_statcache.st_mtime)) / 86400.0 );
3108 break;
3109 case OP_FTATIME:
3110 PUSHn( (((NV)PL_basetime - PL_statcache.st_atime)) / 86400.0 );
3111 break;
3112 case OP_FTCTIME:
3113 PUSHn( (((NV)PL_basetime - PL_statcache.st_ctime)) / 86400.0 );
3114 break;
3115 }
3116 }
3117 RETURN;
a0d0e21e
LW		 3118}
3119
a0d0e21e
LW		 3120PP(pp_ftrowned)
3121{
97aff369 3122 dVAR;
fbb0b3b3 3123 I32 result;
07fe7c6a 3124 char opchar = '?';
2a3ff820 3125 dSP;
17ad201a 3126
7fb13887
BM		 3127 switch (PL_op->op_type) {
3128 case OP_FTROWNED: opchar = 'O'; break;
3129 case OP_FTEOWNED: opchar = 'o'; break;
3130 case OP_FTZERO: opchar = 'z'; break;
3131 case OP_FTSOCK: opchar = 'S'; break;
3132 case OP_FTCHR: opchar = 'c'; break;
3133 case OP_FTBLK: opchar = 'b'; break;
3134 case OP_FTFILE: opchar = 'f'; break;
3135 case OP_FTDIR: opchar = 'd'; break;
3136 case OP_FTPIPE: opchar = 'p'; break;
3137 case OP_FTSUID: opchar = 'u'; break;
3138 case OP_FTSGID: opchar = 'g'; break;
3139 case OP_FTSVTX: opchar = 'k'; break;
3140 }
6f1401dc 3141 tryAMAGICftest_MG(opchar);
7fb13887 3142
1b0124a7
JD		 3143 STACKED_FTEST_CHECK;
3144
17ad201a
NC		 3145 /* I believe that all these three are likely to be defined on most every
3146 system these days. */
3147#ifndef S_ISUID
c410dd6a 3148 if(PL_op->op_type == OP_FTSUID) {
1b0124a7
JD		 3149 if ((PL_op->op_flags & OPf_REF) == 0 && (PL_op->op_private & OPpFT_STACKED) == 0)
3150 (void) POPs;
17ad201a 3151 RETPUSHNO;
c410dd6a 3152 }
17ad201a
NC		 3153#endif
3154#ifndef S_ISGID
c410dd6a 3155 if(PL_op->op_type == OP_FTSGID) {
1b0124a7
JD		 3156 if ((PL_op->op_flags & OPf_REF) == 0 && (PL_op->op_private & OPpFT_STACKED) == 0)
3157 (void) POPs;
17ad201a 3158 RETPUSHNO;
c410dd6a 3159 }
17ad201a
NC		 3160#endif
3161#ifndef S_ISVTX
c410dd6a 3162 if(PL_op->op_type == OP_FTSVTX) {
1b0124a7
JD		 3163 if ((PL_op->op_flags & OPf_REF) == 0 && (PL_op->op_private & OPpFT_STACKED) == 0)
3164 (void) POPs;
17ad201a 3165 RETPUSHNO;
c410dd6a 3166 }
17ad201a
NC		 3167#endif
3168
40c852de 3169 result = my_stat_flags(0);
fbb0b3b3 3170 SPAGAIN;
a0d0e21e
LW		 3171 if (result < 0)
3172 RETPUSHUNDEF;
f1cb2d48
NC		 3173 switch (PL_op->op_type) {
3174 case OP_FTROWNED:
9ab9fa88 3175 if (PL_statcache.st_uid == PL_uid)
f1cb2d48
NC		 3176 RETPUSHYES;
3177 break;
3178 case OP_FTEOWNED:
3179 if (PL_statcache.st_uid == PL_euid)
3180 RETPUSHYES;
3181 break;
3182 case OP_FTZERO:
3183 if (PL_statcache.st_size == 0)
3184 RETPUSHYES;
3185 break;
3186 case OP_FTSOCK:
3187 if (S_ISSOCK(PL_statcache.st_mode))
3188 RETPUSHYES;
3189 break;
3190 case OP_FTCHR:
3191 if (S_ISCHR(PL_statcache.st_mode))
3192 RETPUSHYES;
3193 break;
3194 case OP_FTBLK:
3195 if (S_ISBLK(PL_statcache.st_mode))
3196 RETPUSHYES;
3197 break;
3198 case OP_FTFILE:
3199 if (S_ISREG(PL_statcache.st_mode))
3200 RETPUSHYES;
3201 break;
3202 case OP_FTDIR:
3203 if (S_ISDIR(PL_statcache.st_mode))
3204 RETPUSHYES;
3205 break;
3206 case OP_FTPIPE:
3207 if (S_ISFIFO(PL_statcache.st_mode))
3208 RETPUSHYES;
3209 break;
a0d0e21e 3210#ifdef S_ISUID
17ad201a
NC		 3211 case OP_FTSUID:
3212 if (PL_statcache.st_mode & S_ISUID)
3213 RETPUSHYES;
3214 break;
a0d0e21e 3215#endif
a0d0e21e 3216#ifdef S_ISGID
17ad201a
NC		 3217 case OP_FTSGID:
3218 if (PL_statcache.st_mode & S_ISGID)
3219 RETPUSHYES;
3220 break;
3221#endif
3222#ifdef S_ISVTX
3223 case OP_FTSVTX:
3224 if (PL_statcache.st_mode & S_ISVTX)
3225 RETPUSHYES;
3226 break;
a0d0e21e 3227#endif
17ad201a 3228 }
a0d0e21e
LW		 3229 RETPUSHNO;
3230}
3231
17ad201a 3232PP(pp_ftlink)
a0d0e21e 3233{
97aff369 3234 dVAR;
39644a26 3235 dSP;
500ff13f 3236 I32 result;
07fe7c6a 3237
6f1401dc 3238 tryAMAGICftest_MG('l');
40c852de 3239 result = my_lstat_flags(0);
500ff13f
BM		 3240 SPAGAIN;
3241
a0d0e21e
LW		 3242 if (result < 0)
3243 RETPUSHUNDEF;
17ad201a 3244 if (S_ISLNK(PL_statcache.st_mode))
a0d0e21e 3245 RETPUSHYES;
a0d0e21e
LW		 3246 RETPUSHNO;
3247}
3248
3249PP(pp_fttty)
3250{
97aff369 3251 dVAR;
39644a26 3252 dSP;
a0d0e21e
LW		 3253 int fd;
3254 GV *gv;
a0714e2c 3255 SV *tmpsv = NULL;
0784aae0 3256 char *name = NULL;
40c852de 3257 STRLEN namelen;
fb73857a 3258
6f1401dc 3259 tryAMAGICftest_MG('t');
07fe7c6a 3260
fbb0b3b3
RGS		 3261 STACKED_FTEST_CHECK;
3262
533c011a 3263 if (PL_op->op_flags & OPf_REF)
146174a9 3264 gv = cGVOP_gv;
13be902c 3265 else if (isGV_with_GP(TOPs))
159b6efe 3266 gv = MUTABLE_GV(POPs);
fb73857a 3267 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
159b6efe 3268 gv = MUTABLE_GV(SvRV(POPs));
40c852de
DM		 3269 else {
3270 tmpsv = POPs;
3271 name = SvPV_nomg(tmpsv, namelen);
3272 gv = gv_fetchpvn_flags(name, namelen, SvUTF8(tmpsv), SVt_PVIO);
3273 }
fb73857a 3274
a0d0e21e 3275 if (GvIO(gv) && IoIFP(GvIOp(gv)))
760ac839 3276 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
7a5fd60d 3277 else if (tmpsv && SvOK(tmpsv)) {
40c852de
DM		 3278 if (isDIGIT(*name))
3279 fd = atoi(name);
7a5fd60d
NC		 3280 else
3281 RETPUSHUNDEF;
3282 }
a0d0e21e
LW		 3283 else
3284 RETPUSHUNDEF;
6ad3d225 3285 if (PerlLIO_isatty(fd))
a0d0e21e
LW		 3286 RETPUSHYES;
3287 RETPUSHNO;
3288}
3289
16d20bd9
AD		 3290#if defined(atarist) /* this will work with atariST. Configure will
3291 make guesses for other systems. */
3292# define FILE_base(f) ((f)->_base)
3293# define FILE_ptr(f) ((f)->_ptr)
3294# define FILE_cnt(f) ((f)->_cnt)
3295# define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
a0d0e21e
LW		 3296#endif
3297
3298PP(pp_fttext)
3299{
97aff369 3300 dVAR;
39644a26 3301 dSP;
a0d0e21e
LW		 3302 I32 i;
3303 I32 len;
3304 I32 odd = 0;
3305 STDCHAR tbuf[512];
3306 register STDCHAR *s;
3307 register IO *io;
5f05dabc 3308 register SV *sv;
3309 GV *gv;
146174a9 3310 PerlIO *fp;
a0d0e21e 3311
6f1401dc 3312 tryAMAGICftest_MG(PL_op->op_type == OP_FTTEXT ? 'T' : 'B');
07fe7c6a 3313
fbb0b3b3
RGS		 3314 STACKED_FTEST_CHECK;
3315
533c011a 3316 if (PL_op->op_flags & OPf_REF)
146174a9 3317 gv = cGVOP_gv;
13be902c 3318 else if (isGV_with_GP(TOPs))
159b6efe 3319 gv = MUTABLE_GV(POPs);
5f05dabc 3320 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
159b6efe 3321 gv = MUTABLE_GV(SvRV(POPs));
5f05dabc 3322 else
a0714e2c 3323 gv = NULL;
5f05dabc 3324
3325 if (gv) {
a0d0e21e 3326 EXTEND(SP, 1);
3280af22
NIS		 3327 if (gv == PL_defgv) {
3328 if (PL_statgv)
3329 io = GvIO(PL_statgv);
a0d0e21e 3330 else {
3280af22 3331 sv = PL_statname;
a0d0e21e
LW		 3332 goto really_filename;
3333 }
3334 }
3335 else {
3280af22
NIS		 3336 PL_statgv = gv;
3337 PL_laststatval = -1;
76f68e9b 3338 sv_setpvs(PL_statname, "");
3280af22 3339 io = GvIO(PL_statgv);
a0d0e21e
LW		 3340 }
3341 if (io && IoIFP(io)) {
5f05dabc 3342 if (! PerlIO_has_base(IoIFP(io)))
cea2e8a9 3343 DIE(aTHX_ "-T and -B not implemented on filehandles");
3280af22
NIS		 3344 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3345 if (PL_laststatval < 0)
5f05dabc 3346 RETPUSHUNDEF;
9cbac4c7 3347 if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
533c011a 3348 if (PL_op->op_type == OP_FTTEXT)
a0d0e21e
LW		 3349 RETPUSHNO;
3350 else
3351 RETPUSHYES;
9cbac4c7 3352 }
a20bf0c3 3353 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
760ac839 3354 i = PerlIO_getc(IoIFP(io));
a0d0e21e 3355 if (i != EOF)
760ac839 3356 (void)PerlIO_ungetc(IoIFP(io),i);
a0d0e21e 3357 }
a20bf0c3 3358 if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
a0d0e21e 3359 RETPUSHYES;
a20bf0c3
JH		 3360 len = PerlIO_get_bufsiz(IoIFP(io));
3361 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
760ac839
LW		 3362 /* sfio can have large buffers - limit to 512 */
3363 if (len > 512)
3364 len = 512;
a0d0e21e
LW		 3365 }
3366 else {
51087808 3367 report_evil_fh(cGVOP_gv);
93189314 3368 SETERRNO(EBADF,RMS_IFI);
a0d0e21e
LW		 3369 RETPUSHUNDEF;
3370 }
3371 }
3372 else {
3373 sv = POPs;
5f05dabc 3374 really_filename:
a0714e2c 3375 PL_statgv = NULL;
5c9aa243 3376 PL_laststype = OP_STAT;
40c852de 3377 sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
aa07b2f6 3378 if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) {
349d4f2f
NC		 3379 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname),
3380 '\n'))
9014280d 3381 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
a0d0e21e
LW		 3382 RETPUSHUNDEF;
3383 }
146174a9
CB		 3384 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3385 if (PL_laststatval < 0) {
3386 (void)PerlIO_close(fp);
5f05dabc 3387 RETPUSHUNDEF;
146174a9 3388 }
bd61b366 3389 PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
146174a9
CB		 3390 len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3391 (void)PerlIO_close(fp);
a0d0e21e 3392 if (len <= 0) {
533c011a 3393 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
a0d0e21e
LW		 3394 RETPUSHNO; /* special case NFS directories */
3395 RETPUSHYES; /* null file is anything */
3396 }
3397 s = tbuf;
3398 }
3399
3400 /* now scan s to look for textiness */
4633a7c4 3401 /* XXX ASCII dependent code */
a0d0e21e 3402
146174a9
CB		 3403#if defined(DOSISH) || defined(USEMYBINMODE)
3404 /* ignore trailing ^Z on short files */
58c0efa5 3405 if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26)
146174a9
CB		 3406 --len;
3407#endif
3408
a0d0e21e
LW		 3409 for (i = 0; i < len; i++, s++) {
3410 if (!*s) { /* null never allowed in text */
3411 odd += len;
3412 break;
3413 }
9d116dd7 3414#ifdef EBCDIC
301e8125 3415 else if (!(isPRINT(*s) || isSPACE(*s)))
9d116dd7
JH		 3416 odd++;
3417#else
146174a9
CB		 3418 else if (*s & 128) {
3419#ifdef USE_LOCALE
2de3dbcc 3420 if (IN_LOCALE_RUNTIME && isALPHA_LC(*s))
b3f66c68
GS		 3421 continue;
3422#endif
3423 /* utf8 characters don't count as odd */
fd400ab9 3424 if (UTF8_IS_START(*s)) {
b3f66c68
GS		 3425 int ulen = UTF8SKIP(s);
3426 if (ulen < len - i) {
3427 int j;
3428 for (j = 1; j < ulen; j++) {
fd400ab9 3429 if (!UTF8_IS_CONTINUATION(s[j]))
b3f66c68
GS		 3430 goto not_utf8;
3431 }
3432 --ulen; /* loop does extra increment */
3433 s += ulen;
3434 i += ulen;
3435 continue;
3436 }
3437 }
3438 not_utf8:
3439 odd++;
146174a9 3440 }
a0d0e21e
LW		 3441 else if (*s < 32 &&
3442 *s != '\n' && *s != '\r' && *s != '\b' &&
3443 *s != '\t' && *s != '\f' && *s != 27)
3444 odd++;
9d116dd7 3445#endif
a0d0e21e
LW		 3446 }
3447
533c011a 3448 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
a0d0e21e
LW		 3449 RETPUSHNO;
3450 else
3451 RETPUSHYES;
3452}
3453
a0d0e21e
LW		 3454/* File calls. */
3455
3456PP(pp_chdir)
3457{
97aff369 3458 dVAR; dSP; dTARGET;
c445ea15 3459 const char *tmps = NULL;
9a957fbc 3460 GV *gv = NULL;
a0d0e21e 3461
c4aca7d0 3462 if( MAXARG == 1 ) {
9a957fbc 3463 SV * const sv = POPs;
d4ac975e
GA		 3464 if (PL_op->op_flags & OPf_SPECIAL) {
3465 gv = gv_fetchsv(sv, 0, SVt_PVIO);
3466 }
6e592b3a 3467 else if (isGV_with_GP(sv)) {
159b6efe 3468 gv = MUTABLE_GV(sv);
c4aca7d0 3469 }
6e592b3a 3470 else if (SvROK(sv) && isGV_with_GP(SvRV(sv))) {
159b6efe 3471 gv = MUTABLE_GV(SvRV(sv));
c4aca7d0
GA		 3472 }
3473 else {
4ea561bc 3474 tmps = SvPV_nolen_const(sv);
c4aca7d0
GA		 3475 }
3476 }
35ae6b54 3477
c4aca7d0 3478 if( !gv && (!tmps || !*tmps) ) {
9a957fbc
AL		 3479 HV * const table = GvHVn(PL_envgv);
3480 SV **svp;
3481
a4fc7abc
AL		 3482 if ( (svp = hv_fetchs(table, "HOME", FALSE))
3483 || (svp = hv_fetchs(table, "LOGDIR", FALSE))
491527d0 3484#ifdef VMS
a4fc7abc 3485 || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
491527d0 3486#endif
35ae6b54
MS		 3487 )
3488 {
3489 if( MAXARG == 1 )
9014280d 3490 deprecate("chdir('') or chdir(undef) as chdir()");
8c074e2a 3491 tmps = SvPV_nolen_const(*svp);
35ae6b54 3492 }
72f496dc 3493 else {
389ec635 3494 PUSHi(0);
b7ab37f8 3495 TAINT_PROPER("chdir");
389ec635
MS		 3496 RETURN;
3497 }
8ea155d1 3498 }
8ea155d1 3499
a0d0e21e 3500 TAINT_PROPER("chdir");
c4aca7d0
GA		 3501 if (gv) {
3502#ifdef HAS_FCHDIR
9a957fbc 3503 IO* const io = GvIO(gv);
c4aca7d0 3504 if (io) {
c08d6937 3505 if (IoDIRP(io)) {
3497a01f 3506 PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
c08d6937
SP		 3507 } else if (IoIFP(io)) {
3508 PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
c4aca7d0
GA		 3509 }
3510 else {
51087808 3511 report_evil_fh(gv);
4dc171f0 3512 SETERRNO(EBADF, RMS_IFI);
c4aca7d0
GA		 3513 PUSHi(0);
3514 }
3515 }
3516 else {
51087808 3517 report_evil_fh(gv);
4dc171f0 3518 SETERRNO(EBADF,RMS_IFI);
c4aca7d0
GA		 3519 PUSHi(0);
3520 }
3521#else
3522 DIE(aTHX_ PL_no_func, "fchdir");
3523#endif
3524 }
3525 else
b8ffc8df 3526 PUSHi( PerlDir_chdir(tmps) >= 0 );
748a9306
LW		 3527#ifdef VMS
3528 /* Clear the DEFAULT element of ENV so we'll get the new value
3529 * in the future. */
6b88bc9c 3530 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
748a9306 3531#endif
a0d0e21e
LW		 3532 RETURN;
3533}
3534
3535PP(pp_chown)
3536{
97aff369 3537 dVAR; dSP; dMARK; dTARGET;
605b9385 3538 const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
76ffd3b9 3539
a0d0e21e 3540 SP = MARK;
b59aed67 3541 XPUSHi(value);
a0d0e21e 3542 RETURN;
a0d0e21e
LW		 3543}
3544
3545PP(pp_chroot)
3546{
a0d0e21e 3547#ifdef HAS_CHROOT
97aff369 3548 dVAR; dSP; dTARGET;
7452cf6a 3549 char * const tmps = POPpx;
a0d0e21e
LW		 3550 TAINT_PROPER("chroot");
3551 PUSHi( chroot(tmps) >= 0 );
3552 RETURN;
3553#else
cea2e8a9 3554 DIE(aTHX_ PL_no_func, "chroot");
a0d0e21e
LW		 3555#endif
3556}
3557
a0d0e21e
LW		 3558PP(pp_rename)
3559{
97aff369 3560 dVAR; dSP; dTARGET;
a0d0e21e 3561 int anum;
7452cf6a
AL		 3562 const char * const tmps2 = POPpconstx;
3563 const char * const tmps = SvPV_nolen_const(TOPs);
a0d0e21e
LW		 3564 TAINT_PROPER("rename");
3565#ifdef HAS_RENAME
baed7233 3566 anum = PerlLIO_rename(tmps, tmps2);
a0d0e21e 3567#else
6b88bc9c 3568 if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
ed969818
W		 3569 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3570 anum = 1;
3571 else {
3654eb6c 3572 if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
ed969818
W		 3573 (void)UNLINK(tmps2);
3574 if (!(anum = link(tmps, tmps2)))
3575 anum = UNLINK(tmps);
3576 }
a0d0e21e
LW		 3577 }
3578#endif
3579 SETi( anum >= 0 );
3580 RETURN;
3581}
3582
ce6987d0 3583#if defined(HAS_LINK) || defined(HAS_SYMLINK)
a0d0e21e
LW		 3584PP(pp_link)
3585{
97aff369 3586 dVAR; dSP; dTARGET;
ce6987d0
NC		 3587 const int op_type = PL_op->op_type;
3588 int result;
a0d0e21e 3589
ce6987d0
NC		 3590# ifndef HAS_LINK
3591 if (op_type == OP_LINK)
3592 DIE(aTHX_ PL_no_func, "link");
3593# endif
3594# ifndef HAS_SYMLINK
3595 if (op_type == OP_SYMLINK)
3596 DIE(aTHX_ PL_no_func, "symlink");
3597# endif
3598
3599 {
7452cf6a
AL		 3600 const char * const tmps2 = POPpconstx;
3601 const char * const tmps = SvPV_nolen_const(TOPs);
ce6987d0
NC		 3602 TAINT_PROPER(PL_op_desc[op_type]);
3603 result =
3604# if defined(HAS_LINK)
3605# if defined(HAS_SYMLINK)
3606 /* Both present - need to choose which. */
3607 (op_type == OP_LINK) ?
3608 PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3609# else
4a8ebb7f
SH		 3610 /* Only have link, so calls to pp_symlink will have DIE()d above. */
3611 PerlLIO_link(tmps, tmps2);
ce6987d0
NC		 3612# endif
3613# else
3614# if defined(HAS_SYMLINK)
4a8ebb7f
SH		 3615 /* Only have symlink, so calls to pp_link will have DIE()d above. */
3616 symlink(tmps, tmps2);
ce6987d0
NC		 3617# endif
3618# endif
3619 }
3620
3621 SETi( result >= 0 );
a0d0e21e 3622 RETURN;
ce6987d0 3623}
a0d0e21e 3624#else
ce6987d0
NC		 3625PP(pp_link)
3626{
3627 /* Have neither. */
3628 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
a0d0e21e 3629}
ce6987d0 3630#endif
a0d0e21e
LW		 3631
3632PP(pp_readlink)
3633{
97aff369 3634 dVAR;
76ffd3b9 3635 dSP;
a0d0e21e 3636#ifdef HAS_SYMLINK
76ffd3b9 3637 dTARGET;
10516c54 3638 const char *tmps;
46fc3d4c 3639 char buf[MAXPATHLEN];
a0d0e21e 3640 int len;
46fc3d4c 3641
fb73857a 3642#ifndef INCOMPLETE_TAINTS
3643 TAINT;
3644#endif
10516c54 3645 tmps = POPpconstx;
97dcea33 3646 len = readlink(tmps, buf, sizeof(buf) - 1);
a0d0e21e
LW		 3647 if (len < 0)
3648 RETPUSHUNDEF;
3649 PUSHp(buf, len);
3650 RETURN;
3651#else
3652 EXTEND(SP, 1);
3653 RETSETUNDEF; /* just pretend it's a normal file */
3654#endif
3655}
3656
3657#if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
ba106d47 3658STATIC int
b464bac0 3659S_dooneliner(pTHX_ const char *cmd, const char *filename)
a0d0e21e 3660{
b464bac0 3661 char * const save_filename = filename;
1e422769 3662 char *cmdline;
3663 char *s;
760ac839 3664 PerlIO *myfp;
1e422769 3665 int anum = 1;
6fca0082 3666 Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
a0d0e21e 3667
7918f24d
NC		 3668 PERL_ARGS_ASSERT_DOONELINER;
3669
6fca0082
SP		 3670 Newx(cmdline, size, char);
3671 my_strlcpy(cmdline, cmd, size);
3672 my_strlcat(cmdline, " ", size);
1e422769 3673 for (s = cmdline + strlen(cmdline); *filename; ) {
a0d0e21e
LW		 3674 *s++ = '\\';
3675 *s++ = *filename++;
3676 }
d1307786
JH		 3677 if (s - cmdline < size)
3678 my_strlcpy(s, " 2>&1", size - (s - cmdline));
6ad3d225 3679 myfp = PerlProc_popen(cmdline, "r");
1e422769 3680 Safefree(cmdline);
3681
a0d0e21e 3682 if (myfp) {
0bcc34c2 3683 SV * const tmpsv = sv_newmortal();
6b88bc9c 3684 /* Need to save/restore 'PL_rs' ?? */
760ac839 3685 s = sv_gets(tmpsv, myfp, 0);
6ad3d225 3686 (void)PerlProc_pclose(myfp);
bd61b366 3687 if (s != NULL) {
1e422769 3688 int e;
3689 for (e = 1;
a0d0e21e 3690#ifdef HAS_SYS_ERRLIST
1e422769 3691 e <= sys_nerr
3692#endif
3693 ; e++)
3694 {
3695 /* you don't see this */
6136c704 3696 const char * const errmsg =
1e422769 3697#ifdef HAS_SYS_ERRLIST
3698 sys_errlist[e]
a0d0e21e 3699#else
1e422769 3700 strerror(e)
a0d0e21e 3701#endif
1e422769 3702 ;
3703 if (!errmsg)
3704 break;
3705 if (instr(s, errmsg)) {
3706 SETERRNO(e,0);
3707 return 0;
3708 }
a0d0e21e 3709 }
748a9306 3710 SETERRNO(0,0);
a0d0e21e
LW		 3711#ifndef EACCES
3712#define EACCES EPERM
3713#endif
1e422769 3714 if (instr(s, "cannot make"))
93189314 3715 SETERRNO(EEXIST,RMS_FEX);
1e422769 3716 else if (instr(s, "existing file"))
93189314 3717 SETERRNO(EEXIST,RMS_FEX);
1e422769 3718 else if (instr(s, "ile exists"))
93189314 3719 SETERRNO(EEXIST,RMS_FEX);
1e422769 3720 else if (instr(s, "non-exist"))
93189314 3721 SETERRNO(ENOENT,RMS_FNF);
1e422769 3722 else if (instr(s, "does not exist"))
93189314 3723 SETERRNO(ENOENT,RMS_FNF);
1e422769 3724 else if (instr(s, "not empty"))
93189314 3725 SETERRNO(EBUSY,SS_DEVOFFLINE);
1e422769 3726 else if (instr(s, "cannot access"))
93189314 3727 SETERRNO(EACCES,RMS_PRV);
a0d0e21e 3728 else
93189314 3729 SETERRNO(EPERM,RMS_PRV);
a0d0e21e
LW		 3730 return 0;
3731 }
3732 else { /* some mkdirs return no failure indication */
6b88bc9c 3733 anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
911d147d 3734 if (PL_op->op_type == OP_RMDIR)
a0d0e21e
LW		 3735 anum = !anum;
3736 if (anum)
748a9306 3737 SETERRNO(0,0);
a0d0e21e 3738 else
93189314 3739 SETERRNO(EACCES,RMS_PRV); /* a guess */
a0d0e21e
LW		 3740 }
3741 return anum;
3742 }
3743 else
3744 return 0;
3745}
3746#endif
3747
0c54f65b
RGS		 3748/* This macro removes trailing slashes from a directory name.
3749 * Different operating and file systems take differently to
3750 * trailing slashes. According to POSIX 1003.1 1996 Edition
3751 * any number of trailing slashes should be allowed.
3752 * Thusly we snip them away so that even non-conforming
3753 * systems are happy.
3754 * We should probably do this "filtering" for all
3755 * the functions that expect (potentially) directory names:
3756 * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3757 * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3758
5c144d81 3759#define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
0c54f65b
RGS		 3760 if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3761 do { \
3762 (len)--; \
3763 } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3764 (tmps) = savepvn((tmps), (len)); \
3765 (copy) = TRUE; \
3766 }
3767
a0d0e21e
LW		 3768PP(pp_mkdir)
3769{
97aff369 3770 dVAR; dSP; dTARGET;
df25ddba 3771 STRLEN len;
5c144d81 3772 const char *tmps;
df25ddba 3773 bool copy = FALSE;
7452cf6a 3774 const int mode = (MAXARG > 1) ? POPi : 0777;
5a211162 3775
0c54f65b 3776 TRIMSLASHES(tmps,len,copy);
a0d0e21e
LW		 3777
3778 TAINT_PROPER("mkdir");
3779#ifdef HAS_MKDIR
b8ffc8df 3780 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
a0d0e21e 3781#else
0bcc34c2
AL		 3782 {
3783 int oldumask;
a0d0e21e 3784 SETi( dooneliner("mkdir", tmps) );
6ad3d225
GS		 3785 oldumask = PerlLIO_umask(0);
3786 PerlLIO_umask(oldumask);
3787 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
0bcc34c2 3788 }
a0d0e21e 3789#endif
df25ddba
JH		 3790 if (copy)
3791 Safefree(tmps);
a0d0e21e
LW		 3792 RETURN;
3793}
3794
3795PP(pp_rmdir)
3796{
97aff369 3797 dVAR; dSP; dTARGET;
0c54f65b 3798 STRLEN len;
5c144d81 3799 const char *tmps;
0c54f65b 3800 bool copy = FALSE;
a0d0e21e 3801
0c54f65b 3802 TRIMSLASHES(tmps,len,copy);
a0d0e21e
LW		 3803 TAINT_PROPER("rmdir");
3804#ifdef HAS_RMDIR
b8ffc8df 3805 SETi( PerlDir_rmdir(tmps) >= 0 );
a0d0e21e 3806#else
0c54f65b 3807 SETi( dooneliner("rmdir", tmps) );
a0d0e21e 3808#endif
0c54f65b
RGS		 3809 if (copy)
3810 Safefree(tmps);
a0d0e21e
LW		 3811 RETURN;
3812}
3813
3814/* Directory calls. */
3815
3816PP(pp_open_dir)
3817{
a0d0e21e 3818#if defined(Direntry_t) && defined(HAS_READDIR)
97aff369 3819 dVAR; dSP;
7452cf6a 3820 const char * const dirname = POPpconstx;
159b6efe 3821 GV * const gv = MUTABLE_GV(POPs);
7452cf6a 3822 register IO * const io = GvIOn(gv);
a0d0e21e
LW		 3823
3824 if (!io)
3825 goto nope;
3826
a2a5de95 3827 if ((IoIFP(io) || IoOFP(io)))
d1d15184
NC		 3828 Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
3829 "Opening filehandle %s also as a directory",
3830 GvENAME(gv));
a0d0e21e 3831 if (IoDIRP(io))
6ad3d225 3832 PerlDir_close(IoDIRP(io));
b8ffc8df 3833 if (!(IoDIRP(io) = PerlDir_open(dirname)))
a0d0e21e
LW		 3834 goto nope;
3835
3836 RETPUSHYES;
3837nope:
3838 if (!errno)
93189314 3839 SETERRNO(EBADF,RMS_DIR);
a0d0e21e
LW		 3840 RETPUSHUNDEF;
3841#else
cea2e8a9 3842 DIE(aTHX_ PL_no_dir_func, "opendir");
a0d0e21e
LW		 3843#endif
3844}
3845
3846PP(pp_readdir)
3847{
34b7f128
AMS		 3848#if !defined(Direntry_t) || !defined(HAS_READDIR)
3849 DIE(aTHX_ PL_no_dir_func, "readdir");
3850#else
fd8cd3a3 3851#if !defined(I_DIRENT) && !defined(VMS)
20ce7b12 3852 Direntry_t *readdir (DIR *);
a0d0e21e 3853#endif
97aff369 3854 dVAR;
34b7f128
AMS		 3855 dSP;
3856
3857 SV *sv;
f54cb97a 3858 const I32 gimme = GIMME;
159b6efe 3859 GV * const gv = MUTABLE_GV(POPs);
7452cf6a
AL		 3860 register const Direntry_t *dp;
3861 register IO * const io = GvIOn(gv);
a0d0e21e 3862
3b7fbd4a 3863 if (!io || !IoDIRP(io)) {
a2a5de95
NC		 3864 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3865 "readdir() attempted on invalid dirhandle %s", GvENAME(gv));
3b7fbd4a
SP		 3866 goto nope;
3867 }
a0d0e21e 3868
34b7f128
AMS		 3869 do {
3870 dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
3871 if (!dp)
3872 break;
a0d0e21e 3873#ifdef DIRNAMLEN
34b7f128 3874 sv = newSVpvn(dp->d_name, dp->d_namlen);
a0d0e21e 3875#else
34b7f128 3876 sv = newSVpv(dp->d_name, 0);
fb73857a 3877#endif
3878#ifndef INCOMPLETE_TAINTS
34b7f128
AMS		 3879 if (!(IoFLAGS(io) & IOf_UNTAINT))
3880 SvTAINTED_on(sv);
a0d0e21e 3881#endif
6e449a3a 3882 mXPUSHs(sv);
a79db61d 3883 } while (gimme == G_ARRAY);
34b7f128
AMS		 3884
3885 if (!dp && gimme != G_ARRAY)
3886 goto nope;
3887
a0d0e21e
LW		 3888 RETURN;
3889
3890nope:
3891 if (!errno)
93189314 3892 SETERRNO(EBADF,RMS_ISI);
a0d0e21e
LW		 3893 if (GIMME == G_ARRAY)
3894 RETURN;
3895 else
3896 RETPUSHUNDEF;
a0d0e21e
LW		 3897#endif
3898}
3899
3900PP(pp_telldir)
3901{
a0d0e21e 3902#if defined(HAS_TELLDIR) || defined(telldir)
27da23d5 3903 dVAR; dSP; dTARGET;
968dcd91
JH		 3904 /* XXX does _anyone_ need this? --AD 2/20/1998 */
3905 /* XXX netbsd still seemed to.
3906 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3907 --JHI 1999-Feb-02 */
3908# if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
20ce7b12 3909 long telldir (DIR *);
dfe9444c 3910# endif
159b6efe 3911 GV * const gv = MUTABLE_GV(POPs);
7452cf6a 3912 register IO * const io = GvIOn(gv);
a0d0e21e 3913
abc7ecad 3914 if (!io || !IoDIRP(io)) {
a2a5de95
NC		 3915 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3916 "telldir() attempted on invalid dirhandle %s", GvENAME(gv));
abc7ecad
SP		 3917 goto nope;
3918 }
a0d0e21e 3919
6ad3d225 3920 PUSHi( PerlDir_tell(IoDIRP(io)) );
a0d0e21e
LW		 3921 RETURN;
3922nope:
3923 if (!errno)
93189314 3924 SETERRNO(EBADF,RMS_ISI);
a0d0e21e
LW		 3925 RETPUSHUNDEF;
3926#else
cea2e8a9 3927 DIE(aTHX_ PL_no_dir_func, "telldir");
a0d0e21e
LW		 3928#endif
3929}
3930
3931PP(pp_seekdir)
3932{
a0d0e21e 3933#if defined(HAS_SEEKDIR) || defined(seekdir)
97aff369 3934 dVAR; dSP;
7452cf6a 3935 const long along = POPl;
159b6efe 3936 GV * const gv = MUTABLE_GV(POPs);
7452cf6a 3937 register IO * const io = GvIOn(gv);
a0d0e21e 3938
abc7ecad 3939 if (!io || !IoDIRP(io)) {
a2a5de95
NC		 3940 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3941 "seekdir() attempted on invalid dirhandle %s", GvENAME(gv));
abc7ecad
SP		 3942 goto nope;
3943 }
6ad3d225 3944 (void)PerlDir_seek(IoDIRP(io), along);
a0d0e21e
LW		 3945
3946 RETPUSHYES;
3947nope:
3948 if (!errno)
93189314 3949 SETERRNO(EBADF,RMS_ISI);
a0d0e21e
LW		 3950 RETPUSHUNDEF;
3951#else
cea2e8a9 3952 DIE(aTHX_ PL_no_dir_func, "seekdir");
a0d0e21e
LW		 3953#endif
3954}
3955
3956PP(pp_rewinddir)
3957{
a0d0e21e 3958#if defined(HAS_REWINDDIR) || defined(rewinddir)
97aff369 3959 dVAR; dSP;
159b6efe 3960 GV * const gv = MUTABLE_GV(POPs);
7452cf6a 3961 register IO * const io = GvIOn(gv);
a0d0e21e 3962
abc7ecad 3963 if (!io || !IoDIRP(io)) {
a2a5de95
NC		 3964 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3965 "rewinddir() attempted on invalid dirhandle %s", GvENAME(gv));
a0d0e21e 3966 goto nope;
abc7ecad 3967 }
6ad3d225 3968 (void)PerlDir_rewind(IoDIRP(io));
a0d0e21e
LW		 3969 RETPUSHYES;
3970nope:
3971 if (!errno)
93189314 3972 SETERRNO(EBADF,RMS_ISI);
a0d0e21e
LW		 3973 RETPUSHUNDEF;
3974#else
cea2e8a9 3975 DIE(aTHX_ PL_no_dir_func, "rewinddir");
a0d0e21e
LW		 3976#endif
3977}
3978
3979PP(pp_closedir)
3980{
a0d0e21e 3981#if defined(Direntry_t) && defined(HAS_READDIR)
97aff369 3982 dVAR; dSP;
159b6efe 3983 GV * const gv = MUTABLE_GV(POPs);
7452cf6a 3984 register IO * const io = GvIOn(gv);
a0d0e21e 3985
abc7ecad 3986 if (!io || !IoDIRP(io)) {
a2a5de95
NC		 3987 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3988 "closedir() attempted on invalid dirhandle %s", GvENAME(gv));
abc7ecad
SP		 3989 goto nope;
3990 }
a0d0e21e 3991#ifdef VOID_CLOSEDIR
6ad3d225 3992 PerlDir_close(IoDIRP(io));
a0d0e21e 3993#else
6ad3d225 3994 if (PerlDir_close(IoDIRP(io)) < 0) {
748a9306 3995 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
a0d0e21e 3996 goto nope;
748a9306 3997 }
a0d0e21e
LW		 3998#endif
3999 IoDIRP(io) = 0;
4000
4001 RETPUSHYES;
4002nope:
4003 if (!errno)
93189314 4004 SETERRNO(EBADF,RMS_IFI);
a0d0e21e
LW		 4005 RETPUSHUNDEF;
4006#else
cea2e8a9 4007 DIE(aTHX_ PL_no_dir_func, "closedir");
a0d0e21e
LW		 4008#endif
4009}
4010
4011/* Process control. */
4012
4013PP(pp_fork)
4014{
44a8e56a 4015#ifdef HAS_FORK
97aff369 4016 dVAR; dSP; dTARGET;
761237fe 4017 Pid_t childpid;
a0d0e21e
LW		 4018
4019 EXTEND(SP, 1);
45bc9206 4020 PERL_FLUSHALL_FOR_CHILD;
52e18b1f 4021 childpid = PerlProc_fork();
a0d0e21e
LW		 4022 if (childpid < 0)
4023 RETSETUNDEF;
4024 if (!childpid) {
4d76a344
RGS		 4025#ifdef THREADS_HAVE_PIDS
4026 PL_ppid = (IV)getppid();
4027#endif
ca0c25f6 4028#ifdef PERL_USES_PL_PIDSTATUS
3280af22 4029 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
ca0c25f6 4030#endif
a0d0e21e
LW		 4031 }
4032 PUSHi(childpid);
4033 RETURN;
4034#else
146174a9 4035# if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
39644a26 4036 dSP; dTARGET;
146174a9
CB		 4037 Pid_t childpid;
4038
4039 EXTEND(SP, 1);
4040 PERL_FLUSHALL_FOR_CHILD;
4041 childpid = PerlProc_fork();
60fa28ff
GS		 4042 if (childpid == -1)
4043 RETSETUNDEF;
146174a9
CB		 4044 PUSHi(childpid);
4045 RETURN;
4046# else
0322a713 4047 DIE(aTHX_ PL_no_func, "fork");
146174a9 4048# endif
a0d0e21e
LW		 4049#endif
4050}
4051
4052PP(pp_wait)
4053{
e37778c2 4054#if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
97aff369 4055 dVAR; dSP; dTARGET;
761237fe 4056 Pid_t childpid;
a0d0e21e 4057 int argflags;
a0d0e21e 4058
4ffa73a3
JH		 4059 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4060 childpid = wait4pid(-1, &argflags, 0);
4061 else {
4062 while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4063 errno == EINTR) {
4064 PERL_ASYNC_CHECK();
4065 }
0a0ada86 4066 }
68a29c53
GS		 4067# if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4068 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
2fbb330f 4069 STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
68a29c53 4070# else
2fbb330f 4071 STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
68a29c53 4072# endif
44a8e56a 4073 XPUSHi(childpid);
a0d0e21e
LW		 4074 RETURN;
4075#else
0322a713 4076 DIE(aTHX_ PL_no_func, "wait");
a0d0e21e
LW		 4077#endif
4078}
4079
4080PP(pp_waitpid)
4081{
e37778c2 4082#if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
97aff369 4083 dVAR; dSP; dTARGET;
0bcc34c2
AL		 4084 const int optype = POPi;
4085 const Pid_t pid = TOPi;
2ec0bfb3 4086 Pid_t result;
a0d0e21e 4087 int argflags;
a0d0e21e 4088
4ffa73a3 4089 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2ec0bfb3 4090 result = wait4pid(pid, &argflags, optype);
4ffa73a3 4091 else {
2ec0bfb3 4092 while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4ffa73a3
JH		 4093 errno == EINTR) {
4094 PERL_ASYNC_CHECK();
4095 }
0a0ada86 4096 }
68a29c53
GS		 4097# if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4098 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
2fbb330f 4099 STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
68a29c53 4100# else
2fbb330f 4101 STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
68a29c53 4102# endif
2ec0bfb3 4103 SETi(result);
a0d0e21e
LW		 4104 RETURN;
4105#else
0322a713 4106 DIE(aTHX_ PL_no_func, "waitpid");
a0d0e21e
LW		 4107#endif
4108}
4109
4110PP(pp_system)
4111{
97aff369 4112 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
9c12f1e5
RGS		 4113#if defined(__LIBCATAMOUNT__)
4114 PL_statusvalue = -1;
4115 SP = ORIGMARK;
4116 XPUSHi(-1);
4117#else
a0d0e21e 4118 I32 value;
76ffd3b9 4119 int result;
a0d0e21e 4120
bbd7eb8a
RD		 4121 if (PL_tainting) {
4122 TAINT_ENV();
4123 while (++MARK <= SP) {
10516c54 4124 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
5a445156 4125 if (PL_tainted)
bbd7eb8a
RD		 4126 break;
4127 }
4128 MARK = ORIGMARK;
5a445156 4129 TAINT_PROPER("system");
a0d0e21e 4130 }
45bc9206 4131 PERL_FLUSHALL_FOR_CHILD;
273b0206 4132#if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
d7e492a4 4133 {
eb160463
GS		 4134 Pid_t childpid;
4135 int pp[2];
27da23d5 4136 I32 did_pipes = 0;
eb160463
GS		 4137
4138 if (PerlProc_pipe(pp) >= 0)
4139 did_pipes = 1;
4140 while ((childpid = PerlProc_fork()) == -1) {
4141 if (errno != EAGAIN) {
4142 value = -1;
4143 SP = ORIGMARK;
b59aed67 4144 XPUSHi(value);
eb160463
GS		 4145 if (did_pipes) {
4146 PerlLIO_close(pp[0]);
4147 PerlLIO_close(pp[1]);
4148 }
4149 RETURN;
4150 }
4151 sleep(5);
4152 }
4153 if (childpid > 0) {
4154 Sigsave_t ihand,qhand; /* place to save signals during system() */
4155 int status;
4156
4157 if (did_pipes)
4158 PerlLIO_close(pp[1]);
64ca3a65 4159#ifndef PERL_MICRO
8aad04aa
JH		 4160 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &ihand);
4161 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
64ca3a65 4162#endif
eb160463
GS		 4163 do {
4164 result = wait4pid(childpid, &status, 0);
4165 } while (result == -1 && errno == EINTR);
64ca3a65 4166#ifndef PERL_MICRO
eb160463
GS		 4167 (void)rsignal_restore(SIGINT, &ihand);
4168 (void)rsignal_restore(SIGQUIT, &qhand);
4169#endif
37038d91 4170 STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
eb160463
GS		 4171 do_execfree(); /* free any memory child malloced on fork */
4172 SP = ORIGMARK;
4173 if (did_pipes) {
4174 int errkid;
bb7a0f54
MHM		 4175 unsigned n = 0;
4176 SSize_t n1;
eb160463
GS		 4177
4178 while (n < sizeof(int)) {
4179 n1 = PerlLIO_read(pp[0],
4180 (void*)(((char*)&errkid)+n),
4181 (sizeof(int)) - n);
4182 if (n1 <= 0)
4183 break;
4184 n += n1;
4185 }
4186 PerlLIO_close(pp[0]);
4187 if (n) { /* Error */
4188 if (n != sizeof(int))
4189 DIE(aTHX_ "panic: kid popen errno read");
4190 errno = errkid; /* Propagate errno from kid */
37038d91 4191 STATUS_NATIVE_CHILD_SET(-1);
eb160463
GS		 4192 }
4193 }
b59aed67 4194 XPUSHi(STATUS_CURRENT);
eb160463
GS		 4195 RETURN;
4196 }
4197 if (did_pipes) {
4198 PerlLIO_close(pp[0]);
d5a9bfb0 4199#if defined(HAS_FCNTL) && defined(F_SETFD)
eb160463 4200 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
d5a9bfb0 4201#endif
eb160463 4202 }
e0a1f643 4203 if (PL_op->op_flags & OPf_STACKED) {
0bcc34c2 4204 SV * const really = *++MARK;
e0a1f643
JH		 4205 value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4206 }
4207 else if (SP - MARK != 1)
a0714e2c 4208 value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
e0a1f643 4209 else {
8c074e2a 4210 value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
e0a1f643
JH		 4211 }
4212 PerlProc__exit(-1);
d5a9bfb0 4213 }
c3293030 4214#else /* ! FORK or VMS or OS/2 */
922b1888
GS		 4215 PL_statusvalue = 0;
4216 result = 0;
911d147d 4217 if (PL_op->op_flags & OPf_STACKED) {
0bcc34c2 4218 SV * const really = *++MARK;
9ec7171b 4219# if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
54725af6
GS		 4220 value = (I32)do_aspawn(really, MARK, SP);
4221# else
c5be433b 4222 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
54725af6 4223# endif
a0d0e21e 4224 }
54725af6 4225 else if (SP - MARK != 1) {
9ec7171b 4226# if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
a0714e2c 4227 value = (I32)do_aspawn(NULL, MARK, SP);
54725af6 4228# else
a0714e2c 4229 value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
54725af6
GS		 4230# endif
4231 }
a0d0e21e 4232 else {
8c074e2a 4233 value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
a0d0e21e 4234 }
922b1888
GS		 4235 if (PL_statusvalue == -1) /* hint that value must be returned as is */
4236 result = 1;
2fbb330f 4237 STATUS_NATIVE_CHILD_SET(value);
a0d0e21e
LW		 4238 do_execfree();
4239 SP = ORIGMARK;
b59aed67 4240 XPUSHi(result ? value : STATUS_CURRENT);
9c12f1e5
RGS		 4241#endif /* !FORK or VMS or OS/2 */
4242#endif
a0d0e21e
LW		 4243 RETURN;
4244}
4245
4246PP(pp_exec)
4247{
97aff369 4248 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW		 4249 I32 value;
4250
bbd7eb8a
RD		 4251 if (PL_tainting) {
4252 TAINT_ENV();
4253 while (++MARK <= SP) {
10516c54 4254 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
5a445156 4255 if (PL_tainted)
bbd7eb8a
RD		 4256 break;
4257 }
4258 MARK = ORIGMARK;
5a445156 4259 TAINT_PROPER("exec");
bbd7eb8a 4260 }
45bc9206 4261 PERL_FLUSHALL_FOR_CHILD;
533c011a 4262 if (PL_op->op_flags & OPf_STACKED) {
0bcc34c2 4263 SV * const really = *++MARK;
a0d0e21e
LW		 4264 value = (I32)do_aexec(really, MARK, SP);
4265 }
4266 else if (SP - MARK != 1)
4267#ifdef VMS
a0714e2c 4268 value = (I32)vms_do_aexec(NULL, MARK, SP);
a0d0e21e 4269#else
092bebab
JH		 4270# ifdef __OPEN_VM
4271 {
a0714e2c 4272 (void ) do_aspawn(NULL, MARK, SP);
092bebab
JH		 4273 value = 0;
4274 }
4275# else
a0714e2c 4276 value = (I32)do_aexec(NULL, MARK, SP);
092bebab 4277# endif
a0d0e21e
LW		 4278#endif
4279 else {
a0d0e21e 4280#ifdef VMS
8c074e2a 4281 value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
a0d0e21e 4282#else
092bebab 4283# ifdef __OPEN_VM
8c074e2a 4284 (void) do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
092bebab
JH		 4285 value = 0;
4286# else
5dd60a52 4287 value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
092bebab 4288# endif
a0d0e21e
LW		 4289#endif
4290 }
146174a9 4291
a0d0e21e 4292 SP = ORIGMARK;
b59aed67 4293 XPUSHi(value);
a0d0e21e
LW		 4294 RETURN;
4295}
4296
a0d0e21e
LW		 4297PP(pp_getppid)
4298{
4299#ifdef HAS_GETPPID
97aff369 4300 dVAR; dSP; dTARGET;
4d76a344 4301# ifdef THREADS_HAVE_PIDS
e39f92a7
RGS		 4302 if (PL_ppid != 1 && getppid() == 1)
4303 /* maybe the parent process has died. Refresh ppid cache */
4304 PL_ppid = 1;
4d76a344
RGS		 4305 XPUSHi( PL_ppid );
4306# else
a0d0e21e 4307 XPUSHi( getppid() );
4d76a344 4308# endif
a0d0e21e
LW		 4309 RETURN;
4310#else
cea2e8a9 4311 DIE(aTHX_ PL_no_func, "getppid");
a0d0e21e
LW		 4312#endif
4313}
4314
4315PP(pp_getpgrp)
4316{
4317#ifdef HAS_GETPGRP
97aff369 4318 dVAR; dSP; dTARGET;
9853a804 4319 Pid_t pgrp;
0bcc34c2 4320 const Pid_t pid = (MAXARG < 1) ? 0 : SvIVx(POPs);
a0d0e21e 4321
c3293030 4322#ifdef BSD_GETPGRP
9853a804 4323 pgrp = (I32)BSD_GETPGRP(pid);
a0d0e21e 4324#else
146174a9 4325 if (pid != 0 && pid != PerlProc_getpid())
cea2e8a9 4326 DIE(aTHX_ "POSIX getpgrp can't take an argument");
9853a804 4327 pgrp = getpgrp();
a0d0e21e 4328#endif
9853a804 4329 XPUSHi(pgrp);
a0d0e21e
LW		 4330 RETURN;
4331#else
cea2e8a9 4332 DIE(aTHX_ PL_no_func, "getpgrp()");
a0d0e21e
LW		 4333#endif
4334}
4335
4336PP(pp_setpgrp)
4337{
4338#ifdef HAS_SETPGRP
97aff369 4339 dVAR; dSP; dTARGET;
d8a83dd3
JH		 4340 Pid_t pgrp;
4341 Pid_t pid;
a0d0e21e
LW		 4342 if (MAXARG < 2) {
4343 pgrp = 0;
4344 pid = 0;
1f200948 4345 XPUSHi(-1);
a0d0e21e
LW		 4346 }
4347 else {
4348 pgrp = POPi;
4349 pid = TOPi;
4350 }
4351
4352 TAINT_PROPER("setpgrp");
c3293030
IZ		 4353#ifdef BSD_SETPGRP
4354 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
a0d0e21e 4355#else
146174a9
CB		 4356 if ((pgrp != 0 && pgrp != PerlProc_getpid())
4357 || (pid != 0 && pid != PerlProc_getpid()))
4358 {
4359 DIE(aTHX_ "setpgrp can't take arguments");
4360 }
a0d0e21e
LW		 4361 SETi( setpgrp() >= 0 );
4362#endif /* USE_BSDPGRP */
4363 RETURN;
4364#else
cea2e8a9 4365 DIE(aTHX_ PL_no_func, "setpgrp()");
a0d0e21e
LW		 4366#endif
4367}
4368
8b079db6 4369#if defined(__GLIBC__) && ((__GLIBC__ == 2 && __GLIBC_MINOR__ >= 3) || (__GLIBC__ > 2))
5baa2e4f
RB		 4370# define PRIORITY_WHICH_T(which) (__priority_which_t)which
4371#else
4372# define PRIORITY_WHICH_T(which) which
4373#endif
4374
a0d0e21e
LW		 4375PP(pp_getpriority)
4376{
a0d0e21e 4377#ifdef HAS_GETPRIORITY
97aff369 4378 dVAR; dSP; dTARGET;
0bcc34c2
AL		 4379 const int who = POPi;
4380 const int which = TOPi;
5baa2e4f 4381 SETi( getpriority(PRIORITY_WHICH_T(which), who) );
a0d0e21e
LW		 4382 RETURN;
4383#else
cea2e8a9 4384 DIE(aTHX_ PL_no_func, "getpriority()");
a0d0e21e
LW		 4385#endif
4386}
4387
4388PP(pp_setpriority)
4389{
a0d0e21e 4390#ifdef HAS_SETPRIORITY
97aff369 4391 dVAR; dSP; dTARGET;
0bcc34c2
AL		 4392 const int niceval = POPi;
4393 const int who = POPi;
4394 const int which = TOPi;
a0d0e21e 4395 TAINT_PROPER("setpriority");
5baa2e4f 4396 SETi( setpriority(PRIORITY_WHICH_T(which), who, niceval) >= 0 );
a0d0e21e
LW		 4397 RETURN;
4398#else
cea2e8a9 4399 DIE(aTHX_ PL_no_func, "setpriority()");
a0d0e21e
LW		 4400#endif
4401}
4402
5baa2e4f
RB		 4403#undef PRIORITY_WHICH_T
4404
a0d0e21e
LW		 4405/* Time calls. */
4406
4407PP(pp_time)
4408{
97aff369 4409 dVAR; dSP; dTARGET;
cbdc8872 4410#ifdef BIG_TIME
4608196e 4411 XPUSHn( time(NULL) );
cbdc8872 4412#else
4608196e 4413 XPUSHi( time(NULL) );
cbdc8872 4414#endif
a0d0e21e
LW		 4415 RETURN;
4416}
4417
a0d0e21e
LW		 4418PP(pp_tms)
4419{
9cad6237 4420#ifdef HAS_TIMES
97aff369 4421 dVAR;
39644a26 4422 dSP;
a0d0e21e 4423 EXTEND(SP, 4);
a0d0e21e 4424#ifndef VMS
3280af22 4425 (void)PerlProc_times(&PL_timesbuf);
a0d0e21e 4426#else
6b88bc9c 4427 (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */
76e3520e
GS		 4428 /* struct tms, though same data */
4429 /* is returned. */
a0d0e21e
LW		 4430#endif
4431
6e449a3a 4432 mPUSHn(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick);
a0d0e21e 4433 if (GIMME == G_ARRAY) {
6e449a3a
MHM		 4434 mPUSHn(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick);
4435 mPUSHn(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick);
4436 mPUSHn(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick);
a0d0e21e
LW		 4437 }
4438 RETURN;
9cad6237 4439#else
2f42fcb0
JH		 4440# ifdef PERL_MICRO
4441 dSP;
6e449a3a 4442 mPUSHn(0.0);
2f42fcb0
JH		 4443 EXTEND(SP, 4);
4444 if (GIMME == G_ARRAY) {
6e449a3a
MHM		 4445 mPUSHn(0.0);
4446 mPUSHn(0.0);
4447 mPUSHn(0.0);
2f42fcb0
JH		 4448 }
4449 RETURN;
4450# else
9cad6237 4451 DIE(aTHX_ "times not implemented");
2f42fcb0 4452# endif
55497cff 4453#endif /* HAS_TIMES */
a0d0e21e
LW		 4454}
4455
fc003d4b
MS		 4456/* The 32 bit int year limits the times we can represent to these
4457 boundaries with a few days wiggle room to account for time zone
4458 offsets
4459*/
4460/* Sat Jan 3 00:00:00 -2147481748 */
4461#define TIME_LOWER_BOUND -67768100567755200.0
4462/* Sun Dec 29 12:00:00 2147483647 */
4463#define TIME_UPPER_BOUND 67767976233316800.0
4464
a0d0e21e
LW		 4465PP(pp_gmtime)
4466{
97aff369 4467 dVAR;
39644a26 4468 dSP;
a272e669 4469 Time64_T when;
806a119a
MS		 4470 struct TM tmbuf;
4471 struct TM *err;
a8cb0261 4472 const char *opname = PL_op->op_type == OP_LOCALTIME ? "localtime" : "gmtime";
27da23d5
JH		 4473 static const char * const dayname[] =
4474 {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4475 static const char * const monname[] =
4476 {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4477 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
a0d0e21e 4478
a272e669
MS		 4479 if (MAXARG < 1) {
4480 time_t now;
4481 (void)time(&now);
4482 when = (Time64_T)now;
4483 }
7315c673 4484 else {
7eb4f9b7 4485 NV input = Perl_floor(POPn);
8efababc 4486 when = (Time64_T)input;
a2a5de95
NC		 4487 if (when != input) {
4488 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
7eb4f9b7 4489 "%s(%.0" NVff ") too large", opname, input);
7315c673
MS		 4490 }
4491 }
a0d0e21e 4492
fc003d4b
MS		 4493 if ( TIME_LOWER_BOUND > when ) {
4494 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
7eb4f9b7 4495 "%s(%.0" NVff ") too small", opname, when);
fc003d4b
MS		 4496 err = NULL;
4497 }
4498 else if( when > TIME_UPPER_BOUND ) {
4499 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
7eb4f9b7 4500 "%s(%.0" NVff ") too large", opname, when);
fc003d4b
MS		 4501 err = NULL;
4502 }
4503 else {
4504 if (PL_op->op_type == OP_LOCALTIME)
4505 err = S_localtime64_r(&when, &tmbuf);
4506 else
4507 err = S_gmtime64_r(&when, &tmbuf);
4508 }
a0d0e21e 4509
a2a5de95 4510 if (err == NULL) {
8efababc 4511 /* XXX %lld broken for quads */
a2a5de95 4512 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
7eb4f9b7 4513 "%s(%.0" NVff ") failed", opname, when);
5b6366c2 4514 }
a0d0e21e 4515
a272e669 4516 if (GIMME != G_ARRAY) { /* scalar context */
46fc3d4c 4517 SV *tsv;
8efababc
MS		 4518 /* XXX newSVpvf()'s %lld type is broken, so cheat with a double */
4519 double year = (double)tmbuf.tm_year + 1900;
4520
9a5ff6d9
AB		 4521 EXTEND(SP, 1);
4522 EXTEND_MORTAL(1);
a272e669 4523 if (err == NULL)
a0d0e21e 4524 RETPUSHUNDEF;
a272e669 4525
8efababc 4526 tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %.0f",
a272e669
MS		 4527 dayname[tmbuf.tm_wday],
4528 monname[tmbuf.tm_mon],
4529 tmbuf.tm_mday,
4530 tmbuf.tm_hour,
4531 tmbuf.tm_min,
4532 tmbuf.tm_sec,
8efababc 4533 year);
6e449a3a 4534 mPUSHs(tsv);
a0d0e21e 4535 }
a272e669
MS		 4536 else { /* list context */
4537 if ( err == NULL )
4538 RETURN;
4539
9a5ff6d9
AB		 4540 EXTEND(SP, 9);
4541 EXTEND_MORTAL(9);
a272e669
MS		 4542 mPUSHi(tmbuf.tm_sec);
4543 mPUSHi(tmbuf.tm_min);
4544 mPUSHi(tmbuf.tm_hour);
4545 mPUSHi(tmbuf.tm_mday);
4546 mPUSHi(tmbuf.tm_mon);
7315c673 4547 mPUSHn(tmbuf.tm_year);
a272e669
MS		 4548 mPUSHi(tmbuf.tm_wday);
4549 mPUSHi(tmbuf.tm_yday);
4550 mPUSHi(tmbuf.tm_isdst);
a0d0e21e
LW		 4551 }
4552 RETURN;
4553}
4554
4555PP(pp_alarm)
4556{
9cad6237 4557#ifdef HAS_ALARM
97aff369 4558 dVAR; dSP; dTARGET;
a0d0e21e 4559 int anum;
a0d0e21e
LW		 4560 anum = POPi;
4561 anum = alarm((unsigned int)anum);
a0d0e21e
LW		 4562 if (anum < 0)
4563 RETPUSHUNDEF;
c6419e06 4564 PUSHi(anum);
a0d0e21e
LW		 4565 RETURN;
4566#else
0322a713 4567 DIE(aTHX_ PL_no_func, "alarm");
a0d0e21e
LW		 4568#endif
4569}
4570
4571PP(pp_sleep)
4572{
97aff369 4573 dVAR; dSP; dTARGET;
a0d0e21e
LW		 4574 I32 duration;
4575 Time_t lasttime;
4576 Time_t when;
4577
4578 (void)time(&lasttime);
4579 if (MAXARG < 1)
76e3520e 4580 PerlProc_pause();
a0d0e21e
LW		 4581 else {
4582 duration = POPi;
76e3520e 4583 PerlProc_sleep((unsigned int)duration);
a0d0e21e
LW		 4584 }
4585 (void)time(&when);
4586 XPUSHi(when - lasttime);
4587 RETURN;
4588}
4589
4590/* Shared memory. */
c9f7ac20 4591/* Merged with some message passing. */
a0d0e21e 4592
a0d0e21e
LW		 4593PP(pp_shmwrite)
4594{
4595#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
97aff369 4596 dVAR; dSP; dMARK; dTARGET;
c9f7ac20
NC		 4597 const int op_type = PL_op->op_type;
4598 I32 value;
a0d0e21e 4599
c9f7ac20
NC		 4600 switch (op_type) {
4601 case OP_MSGSND:
4602 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4603 break;
4604 case OP_MSGRCV:
4605 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4606 break;
ca563b4e
NC		 4607 case OP_SEMOP:
4608 value = (I32)(do_semop(MARK, SP) >= 0);
4609 break;
c9f7ac20
NC		 4610 default:
4611 value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4612 break;
4613 }
a0d0e21e 4614
a0d0e21e
LW		 4615 SP = MARK;
4616 PUSHi(value);
4617 RETURN;
4618#else
897d3989 4619 return Perl_pp_semget(aTHX);
a0d0e21e
LW		 4620#endif
4621}
4622
4623/* Semaphores. */
4624
4625PP(pp_semget)
4626{
4627#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
97aff369 4628 dVAR; dSP; dMARK; dTARGET;
0bcc34c2 4629 const int anum = do_ipcget(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 4630 SP = MARK;
4631 if (anum == -1)
4632 RETPUSHUNDEF;
4633 PUSHi(anum);
4634 RETURN;
4635#else
cea2e8a9 4636 DIE(aTHX_ "System V IPC is not implemented on this machine");
a0d0e21e
LW		 4637#endif
4638}
4639
4640PP(pp_semctl)
4641{
4642#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
97aff369 4643 dVAR; dSP; dMARK; dTARGET;
0bcc34c2 4644 const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 4645 SP = MARK;
4646 if (anum == -1)
4647 RETSETUNDEF;
4648 if (anum != 0) {
4649 PUSHi(anum);
4650 }
4651 else {
8903cb82 4652 PUSHp(zero_but_true, ZBTLEN);
a0d0e21e
LW		 4653 }
4654 RETURN;
4655#else
897d3989 4656 return Perl_pp_semget(aTHX);
a0d0e21e
LW		 4657#endif
4658}
4659
5cdc4e88
NC		 4660/* I can't const this further without getting warnings about the types of
4661 various arrays passed in from structures. */
4662static SV *
4663S_space_join_names_mortal(pTHX_ char *const *array)
4664{
7c58897d 4665 SV *target;
5cdc4e88 4666
7918f24d
NC		 4667 PERL_ARGS_ASSERT_SPACE_JOIN_NAMES_MORTAL;
4668
5cdc4e88 4669 if (array && *array) {
84bafc02 4670 target = newSVpvs_flags("", SVs_TEMP);
5cdc4e88
NC		 4671 while (1) {
4672 sv_catpv(target, *array);
4673 if (!*++array)
4674 break;
4675 sv_catpvs(target, " ");
4676 }
7c58897d
NC		 4677 } else {
4678 target = sv_mortalcopy(&PL_sv_no);
5cdc4e88
NC		 4679 }
4680 return target;
4681}
4682
a0d0e21e
LW		 4683/* Get system info. */
4684
a0d0e21e
LW		 4685PP(pp_ghostent)
4686{
693762b4 4687#if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
97aff369 4688 dVAR; dSP;
533c011a 4689 I32 which = PL_op->op_type;
a0d0e21e
LW		 4690 register char **elem;
4691 register SV *sv;
dc45a647 4692#ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
1d88b533
JH		 4693 struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4694 struct hostent *gethostbyname(Netdb_name_t);
4695 struct hostent *gethostent(void);
a0d0e21e 4696#endif
07822e36 4697 struct hostent *hent = NULL;
a0d0e21e
LW		 4698 unsigned long len;
4699
4700 EXTEND(SP, 10);
edd309b7 4701 if (which == OP_GHBYNAME) {
dc45a647 4702#ifdef HAS_GETHOSTBYNAME
0bcc34c2 4703 const char* const name = POPpbytex;
edd309b7 4704 hent = PerlSock_gethostbyname(name);
dc45a647 4705#else
cea2e8a9 4706 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
dc45a647 4707#endif
edd309b7 4708 }
a0d0e21e 4709 else if (which == OP_GHBYADDR) {
dc45a647 4710#ifdef HAS_GETHOSTBYADDR
0bcc34c2
AL		 4711 const int addrtype = POPi;
4712 SV * const addrsv = POPs;
a0d0e21e 4713 STRLEN addrlen;
48fc4736 4714 const char *addr = (char *)SvPVbyte(addrsv, addrlen);
a0d0e21e 4715
48fc4736 4716 hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
dc45a647 4717#else
cea2e8a9 4718 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
dc45a647 4719#endif
a0d0e21e
LW		 4720 }
4721 else
4722#ifdef HAS_GETHOSTENT
6ad3d225 4723 hent = PerlSock_gethostent();
a0d0e21e 4724#else
cea2e8a9 4725 DIE(aTHX_ PL_no_sock_func, "gethostent");
a0d0e21e
LW		 4726#endif
4727
4728#ifdef HOST_NOT_FOUND
10bc17b6
JH		 4729 if (!hent) {
4730#ifdef USE_REENTRANT_API
4731# ifdef USE_GETHOSTENT_ERRNO
4732 h_errno = PL_reentrant_buffer->_gethostent_errno;
4733# endif
4734#endif
37038d91 4735 STATUS_UNIX_SET(h_errno);
10bc17b6 4736 }
a0d0e21e
LW		 4737#endif
4738
4739 if (GIMME != G_ARRAY) {
4740 PUSHs(sv = sv_newmortal());
4741 if (hent) {
4742 if (which == OP_GHBYNAME) {
fd0af264 4743 if (hent->h_addr)
4744 sv_setpvn(sv, hent->h_addr, hent->h_length);
a0d0e21e
LW		 4745 }
4746 else
4747 sv_setpv(sv, (char*)hent->h_name);
4748 }
4749 RETURN;
4750 }
4751
4752 if (hent) {
6e449a3a 4753 mPUSHs(newSVpv((char*)hent->h_name, 0));
931e0695 4754 PUSHs(space_join_names_mortal(hent->h_aliases));
6e449a3a 4755 mPUSHi(hent->h_addrtype);
a0d0e21e 4756 len = hent->h_length;
6e449a3a 4757 mPUSHi(len);
a0d0e21e
LW		 4758#ifdef h_addr
4759 for (elem = hent->h_addr_list; elem && *elem; elem++) {
6e449a3a 4760 mXPUSHp(*elem, len);
a0d0e21e
LW		 4761 }
4762#else
fd0af264 4763 if (hent->h_addr)
22f1178f 4764 mPUSHp(hent->h_addr, len);
7c58897d
NC		 4765 else
4766 PUSHs(sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 4767#endif /* h_addr */
4768 }
4769 RETURN;
4770#else
7844cc62 4771 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
a0d0e21e
LW		 4772#endif
4773}
4774
a0d0e21e
LW		 4775PP(pp_gnetent)
4776{
693762b4 4777#if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
97aff369 4778 dVAR; dSP;
533c011a 4779 I32 which = PL_op->op_type;
a0d0e21e 4780 register SV *sv;
dc45a647 4781#ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
1d88b533
JH		 4782 struct netent *getnetbyaddr(Netdb_net_t, int);
4783 struct netent *getnetbyname(Netdb_name_t);
4784 struct netent *getnetent(void);
8ac85365 4785#endif
a0d0e21e
LW		 4786 struct netent *nent;
4787
edd309b7 4788 if (which == OP_GNBYNAME){
dc45a647 4789#ifdef HAS_GETNETBYNAME
0bcc34c2 4790 const char * const name = POPpbytex;
edd309b7 4791 nent = PerlSock_getnetbyname(name);
dc45a647 4792#else
cea2e8a9 4793 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
dc45a647 4794#endif
edd309b7 4795 }
a0d0e21e 4796 else if (which == OP_GNBYADDR) {
dc45a647 4797#ifdef HAS_GETNETBYADDR
0bcc34c2
AL		 4798 const int addrtype = POPi;
4799 const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
76e3520e 4800 nent = PerlSock_getnetbyaddr(addr, addrtype);
dc45a647 4801#else
cea2e8a9 4802 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
dc45a647 4803#endif
a0d0e21e
LW		 4804 }
4805 else
dc45a647 4806#ifdef HAS_GETNETENT
76e3520e 4807 nent = PerlSock_getnetent();
dc45a647 4808#else
cea2e8a9 4809 DIE(aTHX_ PL_no_sock_func, "getnetent");
dc45a647 4810#endif
a0d0e21e 4811
10bc17b6
JH		 4812#ifdef HOST_NOT_FOUND
4813 if (!nent) {
4814#ifdef USE_REENTRANT_API
4815# ifdef USE_GETNETENT_ERRNO
4816 h_errno = PL_reentrant_buffer->_getnetent_errno;
4817# endif
4818#endif
37038d91 4819 STATUS_UNIX_SET(h_errno);
10bc17b6
JH		 4820 }
4821#endif
4822
a0d0e21e
LW		 4823 EXTEND(SP, 4);
4824 if (GIMME != G_ARRAY) {
4825 PUSHs(sv = sv_newmortal());
4826 if (nent) {
4827 if (which == OP_GNBYNAME)
1e422769 4828 sv_setiv(sv, (IV)nent->n_net);
a0d0e21e
LW		 4829 else
4830 sv_setpv(sv, nent->n_name);
4831 }
4832 RETURN;
4833 }
4834
4835 if (nent) {
6e449a3a 4836 mPUSHs(newSVpv(nent->n_name, 0));
931e0695 4837 PUSHs(space_join_names_mortal(nent->n_aliases));
6e449a3a
MHM		 4838 mPUSHi(nent->n_addrtype);
4839 mPUSHi(nent->n_net);
a0d0e21e
LW		 4840 }
4841
4842 RETURN;
4843#else
7844cc62 4844 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
a0d0e21e
LW		 4845#endif
4846}
4847
a0d0e21e
LW		 4848PP(pp_gprotoent)
4849{
693762b4 4850#if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
97aff369 4851 dVAR; dSP;
533c011a 4852 I32 which = PL_op->op_type;
301e8125 4853 register SV *sv;
dc45a647 4854#ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
1d88b533
JH		 4855 struct protoent *getprotobyname(Netdb_name_t);
4856 struct protoent *getprotobynumber(int);
4857 struct protoent *getprotoent(void);
8ac85365 4858#endif
a0d0e21e
LW		 4859 struct protoent *pent;
4860
edd309b7 4861 if (which == OP_GPBYNAME) {
e5c9fcd0 4862#ifdef HAS_GETPROTOBYNAME
0bcc34c2 4863 const char* const name = POPpbytex;
edd309b7 4864 pent = PerlSock_getprotobyname(name);
e5c9fcd0 4865#else
cea2e8a9 4866 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
e5c9fcd0 4867#endif
edd309b7
JH		 4868 }
4869 else if (which == OP_GPBYNUMBER) {
e5c9fcd0 4870#ifdef HAS_GETPROTOBYNUMBER
0bcc34c2 4871 const int number = POPi;
edd309b7 4872 pent = PerlSock_getprotobynumber(number);
e5c9fcd0 4873#else
edd309b7 4874 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
e5c9fcd0 4875#endif
edd309b7 4876 }
a0d0e21e 4877 else
e5c9fcd0 4878#ifdef HAS_GETPROTOENT
6ad3d225 4879 pent = PerlSock_getprotoent();
e5c9fcd0 4880#else
cea2e8a9 4881 DIE(aTHX_ PL_no_sock_func, "getprotoent");
e5c9fcd0 4882#endif
a0d0e21e
LW		 4883
4884 EXTEND(SP, 3);
4885 if (GIMME != G_ARRAY) {
4886 PUSHs(sv = sv_newmortal());
4887 if (pent) {
4888 if (which == OP_GPBYNAME)
1e422769 4889 sv_setiv(sv, (IV)pent->p_proto);
a0d0e21e
LW		 4890 else
4891 sv_setpv(sv, pent->p_name);
4892 }
4893 RETURN;
4894 }
4895
4896 if (pent) {
6e449a3a 4897 mPUSHs(newSVpv(pent->p_name, 0));
931e0695 4898 PUSHs(space_join_names_mortal(pent->p_aliases));
6e449a3a 4899 mPUSHi(pent->p_proto);
a0d0e21e
LW		 4900 }
4901
4902 RETURN;
4903#else
7844cc62 4904 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
a0d0e21e
LW		 4905#endif
4906}
4907
a0d0e21e
LW		 4908PP(pp_gservent)
4909{
693762b4 4910#if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
97aff369 4911 dVAR; dSP;
533c011a 4912 I32 which = PL_op->op_type;
a0d0e21e 4913 register SV *sv;
dc45a647 4914#ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
1d88b533
JH		 4915 struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
4916 struct servent *getservbyport(int, Netdb_name_t);
4917 struct servent *getservent(void);
8ac85365 4918#endif
a0d0e21e
LW		 4919 struct servent *sent;
4920
4921 if (which == OP_GSBYNAME) {
dc45a647 4922#ifdef HAS_GETSERVBYNAME
0bcc34c2
AL		 4923 const char * const proto = POPpbytex;
4924 const char * const name = POPpbytex;
bd61b366 4925 sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
dc45a647 4926#else
cea2e8a9 4927 DIE(aTHX_ PL_no_sock_func, "getservbyname");
dc45a647 4928#endif
a0d0e21e
LW		 4929 }
4930 else if (which == OP_GSBYPORT) {
dc45a647 4931#ifdef HAS_GETSERVBYPORT
0bcc34c2 4932 const char * const proto = POPpbytex;
eb160463 4933 unsigned short port = (unsigned short)POPu;
36477c24 4934#ifdef HAS_HTONS
6ad3d225 4935 port = PerlSock_htons(port);
36477c24 4936#endif
bd61b366 4937 sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
dc45a647 4938#else
cea2e8a9 4939 DIE(aTHX_ PL_no_sock_func, "getservbyport");
dc45a647 4940#endif
a0d0e21e
LW		 4941 }
4942 else
e5c9fcd0 4943#ifdef HAS_GETSERVENT
6ad3d225 4944 sent = PerlSock_getservent();
e5c9fcd0 4945#else
cea2e8a9 4946 DIE(aTHX_ PL_no_sock_func, "getservent");
e5c9fcd0 4947#endif
a0d0e21e
LW		 4948
4949 EXTEND(SP, 4);
4950 if (GIMME != G_ARRAY) {
4951 PUSHs(sv = sv_newmortal());
4952 if (sent) {
4953 if (which == OP_GSBYNAME) {
4954#ifdef HAS_NTOHS
6ad3d225 4955 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
a0d0e21e 4956#else
1e422769 4957 sv_setiv(sv, (IV)(sent->s_port));
a0d0e21e
LW		 4958#endif
4959 }
4960 else
4961 sv_setpv(sv, sent->s_name);
4962 }
4963 RETURN;
4964 }
4965
4966 if (sent) {
6e449a3a 4967 mPUSHs(newSVpv(sent->s_name, 0));
931e0695 4968 PUSHs(space_join_names_mortal(sent->s_aliases));
a0d0e21e 4969#ifdef HAS_NTOHS
6e449a3a 4970 mPUSHi(PerlSock_ntohs(sent->s_port));
a0d0e21e 4971#else
6e449a3a 4972 mPUSHi(sent->s_port);
a0d0e21e 4973#endif
6e449a3a 4974 mPUSHs(newSVpv(sent->s_proto, 0));
a0d0e21e
LW		 4975 }
4976
4977 RETURN;
4978#else
7844cc62 4979 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
a0d0e21e
LW		 4980#endif
4981}
4982
4983PP(pp_shostent)
4984{
97aff369 4985 dVAR; dSP;
396166e1
NC		 4986 const int stayopen = TOPi;
4987 switch(PL_op->op_type) {
4988 case OP_SHOSTENT:
4989#ifdef HAS_SETHOSTENT
4990 PerlSock_sethostent(stayopen);
a0d0e21e 4991#else
396166e1 4992 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
a0d0e21e 4993#endif
396166e1 4994 break;
693762b4 4995#ifdef HAS_SETNETENT
396166e1
NC		 4996 case OP_SNETENT:
4997 PerlSock_setnetent(stayopen);
a0d0e21e 4998#else
396166e1 4999 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
a0d0e21e 5000#endif
396166e1
NC		 5001 break;
5002 case OP_SPROTOENT:
693762b4 5003#ifdef HAS_SETPROTOENT
396166e1 5004 PerlSock_setprotoent(stayopen);
a0d0e21e 5005#else
396166e1 5006 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
a0d0e21e 5007#endif
396166e1
NC		 5008 break;
5009 case OP_SSERVENT:
693762b4 5010#ifdef HAS_SETSERVENT
396166e1 5011 PerlSock_setservent(stayopen);
a0d0e21e 5012#else
396166e1 5013 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
a0d0e21e 5014#endif
396166e1
NC		 5015 break;
5016 }
5017 RETSETYES;
a0d0e21e
LW		 5018}
5019
5020PP(pp_ehostent)
5021{
97aff369 5022 dVAR; dSP;
d8ef1fcd
NC		 5023 switch(PL_op->op_type) {
5024 case OP_EHOSTENT:
5025#ifdef HAS_ENDHOSTENT
5026 PerlSock_endhostent();
a0d0e21e 5027#else
d8ef1fcd 5028 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
a0d0e21e 5029#endif
d8ef1fcd
NC		 5030 break;
5031 case OP_ENETENT:
693762b4 5032#ifdef HAS_ENDNETENT
d8ef1fcd 5033 PerlSock_endnetent();
a0d0e21e 5034#else
d8ef1fcd 5035 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
a0d0e21e 5036#endif
d8ef1fcd
NC		 5037 break;
5038 case OP_EPROTOENT:
693762b4 5039#ifdef HAS_ENDPROTOENT
d8ef1fcd 5040 PerlSock_endprotoent();
a0d0e21e 5041#else
d8ef1fcd 5042 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
a0d0e21e 5043#endif
d8ef1fcd
NC		 5044 break;
5045 case OP_ESERVENT:
693762b4 5046#ifdef HAS_ENDSERVENT
d8ef1fcd 5047 PerlSock_endservent();
a0d0e21e 5048#else
d8ef1fcd 5049 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
a0d0e21e 5050#endif
d8ef1fcd 5051 break;
720d5dbf
NC		 5052 case OP_SGRENT:
5053#if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5054 setgrent();
5055#else
5056 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5057#endif
5058 break;
5059 case OP_EGRENT:
5060#if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5061 endgrent();
5062#else
5063 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5064#endif
5065 break;
5066 case OP_SPWENT:
5067#if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5068 setpwent();
5069#else
5070 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5071#endif
5072 break;
5073 case OP_EPWENT:
5074#if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5075 endpwent();
5076#else
5077 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5078#endif
5079 break;
d8ef1fcd
NC		 5080 }
5081 EXTEND(SP,1);
5082 RETPUSHYES;
a0d0e21e
LW		 5083}
5084
a0d0e21e
LW		 5085PP(pp_gpwent)
5086{
0994c4d0 5087#ifdef HAS_PASSWD
97aff369 5088 dVAR; dSP;
533c011a 5089 I32 which = PL_op->op_type;
a0d0e21e 5090 register SV *sv;
e3aefe8d 5091 struct passwd *pwent = NULL;
301e8125 5092 /*
bcf53261
JH		 5093 * We currently support only the SysV getsp* shadow password interface.
5094 * The interface is declared in <shadow.h> and often one needs to link
5095 * with -lsecurity or some such.
5096 * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5097 * (and SCO?)
5098 *
5099 * AIX getpwnam() is clever enough to return the encrypted password
5100 * only if the caller (euid?) is root.
5101 *
e549f1c5 5102 * There are at least three other shadow password APIs. Many platforms
bcf53261
JH		 5103 * seem to contain more than one interface for accessing the shadow
5104 * password databases, possibly for compatibility reasons.
3813c136 5105 * The getsp*() is by far he simplest one, the other two interfaces
bcf53261
JH		 5106 * are much more complicated, but also very similar to each other.
5107 *
5108 * <sys/types.h>
5109 * <sys/security.h>
5110 * <prot.h>
5111 * struct pr_passwd *getprpw*();
5112 * The password is in
3813c136
JH		 5113 * char getprpw*(...).ufld.fd_encrypt[]
5114 * Mention HAS_GETPRPWNAM here so that Configure probes for it.
bcf53261
JH		 5115 *
5116 * <sys/types.h>
5117 * <sys/security.h>
5118 * <prot.h>
5119 * struct es_passwd *getespw*();
5120 * The password is in
5121 * char *(getespw*(...).ufld.fd_encrypt)
3813c136 5122 * Mention HAS_GETESPWNAM here so that Configure probes for it.
bcf53261 5123 *
e1920a95 5124 * <userpw.h> (AIX)
e549f1c5
JH		 5125 * struct userpw *getuserpw();
5126 * The password is in
5127 * char *(getuserpw(...)).spw_upw_passwd
5128 * (but the de facto standard getpwnam() should work okay)
5129 *
3813c136 5130 * Mention I_PROT here so that Configure probes for it.
bcf53261
JH		 5131 *
5132 * In HP-UX for getprpw*() the manual page claims that one should include
5133 * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5134 * if one includes <shadow.h> as that includes <hpsecurity.h>,
5135 * and pp_sys.c already includes <shadow.h> if there is such.
3813c136
JH		 5136 *
5137 * Note that <sys/security.h> is already probed for, but currently
5138 * it is only included in special cases.
301e8125 5139 *
bcf53261
JH		 5140 * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5141 * be preferred interface, even though also the getprpw*() interface
5142 * is available) one needs to link with -lsecurity -ldb -laud -lm.
3813c136
JH		 5143 * One also needs to call set_auth_parameters() in main() before
5144 * doing anything else, whether one is using getespw*() or getprpw*().
5145 *
5146 * Note that accessing the shadow databases can be magnitudes
5147 * slower than accessing the standard databases.
bcf53261
JH		 5148 *
5149 * --jhi
5150 */
a0d0e21e 5151
9e5f0c48
JH		 5152# if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5153 /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5154 * the pw_comment is left uninitialized. */
5155 PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5156# endif
5157
e3aefe8d
JH		 5158 switch (which) {
5159 case OP_GPWNAM:
edd309b7 5160 {
0bcc34c2 5161 const char* const name = POPpbytex;
edd309b7
JH		 5162 pwent = getpwnam(name);
5163 }
5164 break;
e3aefe8d 5165 case OP_GPWUID:
edd309b7
JH		 5166 {
5167 Uid_t uid = POPi;
5168 pwent = getpwuid(uid);
5169 }
e3aefe8d
JH		 5170 break;
5171 case OP_GPWENT:
1883634f 5172# ifdef HAS_GETPWENT
e3aefe8d 5173 pwent = getpwent();
faea9016
IRC		 5174#ifdef POSIX_BC /* In some cases pw_passwd has invalid addresses */
5175 if (pwent) pwent = getpwnam(pwent->pw_name);
5176#endif
1883634f 5177# else
a45d1c96 5178 DIE(aTHX_ PL_no_func, "getpwent");
1883634f 5179# endif
e3aefe8d
JH		 5180 break;
5181 }
8c0bfa08 5182
a0d0e21e
LW		 5183 EXTEND(SP, 10);
5184 if (GIMME != G_ARRAY) {
5185 PUSHs(sv = sv_newmortal());
5186 if (pwent) {
5187 if (which == OP_GPWNAM)
1883634f 5188# if Uid_t_sign <= 0
1e422769 5189 sv_setiv(sv, (IV)pwent->pw_uid);
1883634f 5190# else
23dcd6c8 5191 sv_setuv(sv, (UV)pwent->pw_uid);
1883634f 5192# endif
a0d0e21e
LW		 5193 else
5194 sv_setpv(sv, pwent->pw_name);
5195 }
5196 RETURN;
5197 }
5198
5199 if (pwent) {
6e449a3a 5200 mPUSHs(newSVpv(pwent->pw_name, 0));
6ee623d5 5201
6e449a3a
MHM		 5202 sv = newSViv(0);
5203 mPUSHs(sv);
3813c136
JH		 5204 /* If we have getspnam(), we try to dig up the shadow
5205 * password. If we are underprivileged, the shadow
5206 * interface will set the errno to EACCES or similar,
5207 * and return a null pointer. If this happens, we will
5208 * use the dummy password (usually "*" or "x") from the
5209 * standard password database.
5210 *
5211 * In theory we could skip the shadow call completely
5212 * if euid != 0 but in practice we cannot know which
5213 * security measures are guarding the shadow databases
5214 * on a random platform.
5215 *
5216 * Resist the urge to use additional shadow interfaces.
5217 * Divert the urge to writing an extension instead.
5218 *
5219 * --jhi */
e549f1c5
JH		 5220 /* Some AIX setups falsely(?) detect some getspnam(), which
5221 * has a different API than the Solaris/IRIX one. */
5222# if defined(HAS_GETSPNAM) && !defined(_AIX)
3813c136 5223 {
4ee39169 5224 dSAVE_ERRNO;
0bcc34c2
AL		 5225 const struct spwd * const spwent = getspnam(pwent->pw_name);
5226 /* Save and restore errno so that
3813c136 5227 * underprivileged attempts seem
486ec47a 5228 * to have never made the unsuccessful
3813c136 5229 * attempt to retrieve the shadow password. */
4ee39169 5230 RESTORE_ERRNO;
3813c136
JH		 5231 if (spwent && spwent->sp_pwdp)
5232 sv_setpv(sv, spwent->sp_pwdp);
5233 }
f1066039 5234# endif
e020c87d 5235# ifdef PWPASSWD
3813c136
JH		 5236 if (!SvPOK(sv)) /* Use the standard password, then. */
5237 sv_setpv(sv, pwent->pw_passwd);
e020c87d 5238# endif
3813c136 5239
1883634f 5240# ifndef INCOMPLETE_TAINTS
3813c136
JH		 5241 /* passwd is tainted because user himself can diddle with it.
5242 * admittedly not much and in a very limited way, but nevertheless. */
2959b6e3 5243 SvTAINTED_on(sv);
1883634f 5244# endif
6ee623d5 5245
1883634f 5246# if Uid_t_sign <= 0
6e449a3a 5247 mPUSHi(pwent->pw_uid);
1883634f 5248# else
6e449a3a 5249 mPUSHu(pwent->pw_uid);
1883634f 5250# endif
6ee623d5 5251
1883634f 5252# if Uid_t_sign <= 0
6e449a3a 5253 mPUSHi(pwent->pw_gid);
1883634f 5254# else
6e449a3a 5255 mPUSHu(pwent->pw_gid);
1883634f 5256# endif
3813c136
JH		 5257 /* pw_change, pw_quota, and pw_age are mutually exclusive--
5258 * because of the poor interface of the Perl getpw*(),
5259 * not because there's some standard/convention saying so.
5260 * A better interface would have been to return a hash,
5261 * but we are accursed by our history, alas. --jhi. */
1883634f 5262# ifdef PWCHANGE
6e449a3a 5263 mPUSHi(pwent->pw_change);
6ee623d5 5264# else
1883634f 5265# ifdef PWQUOTA
6e449a3a 5266 mPUSHi(pwent->pw_quota);
1883634f 5267# else
a1757be1 5268# ifdef PWAGE
6e449a3a 5269 mPUSHs(newSVpv(pwent->pw_age, 0));
7c58897d
NC		 5270# else
5271 /* I think that you can never get this compiled, but just in case. */
5272 PUSHs(sv_mortalcopy(&PL_sv_no));
a1757be1 5273# endif
6ee623d5
GS		 5274# endif
5275# endif
6ee623d5 5276
3813c136
JH		 5277 /* pw_class and pw_comment are mutually exclusive--.
5278 * see the above note for pw_change, pw_quota, and pw_age. */
1883634f 5279# ifdef PWCLASS
6e449a3a 5280 mPUSHs(newSVpv(pwent->pw_class, 0));
1883634f
JH		 5281# else
5282# ifdef PWCOMMENT
6e449a3a 5283 mPUSHs(newSVpv(pwent->pw_comment, 0));
7c58897d
NC		 5284# else
5285 /* I think that you can never get this compiled, but just in case. */
5286 PUSHs(sv_mortalcopy(&PL_sv_no));
1883634f 5287# endif
6ee623d5 5288# endif
6ee623d5 5289
1883634f 5290# ifdef PWGECOS
7c58897d
NC		 5291 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
5292# else
c4c533cb 5293 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1883634f
JH		 5294# endif
5295# ifndef INCOMPLETE_TAINTS
d2719217 5296 /* pw_gecos is tainted because user himself can diddle with it. */
fb73857a 5297 SvTAINTED_on(sv);
1883634f 5298# endif
6ee623d5 5299
6e449a3a 5300 mPUSHs(newSVpv(pwent->pw_dir, 0));
6ee623d5 5301
7c58897d 5302 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
1883634f 5303# ifndef INCOMPLETE_TAINTS
4602f195
JH		 5304 /* pw_shell is tainted because user himself can diddle with it. */
5305 SvTAINTED_on(sv);
1883634f 5306# endif
6ee623d5 5307
1883634f 5308# ifdef PWEXPIRE
6e449a3a 5309 mPUSHi(pwent->pw_expire);
1883634f 5310# endif
a0d0e21e
LW		 5311 }
5312 RETURN;
5313#else
af51a00e 5314 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
a0d0e21e
LW		 5315#endif
5316}
5317
a0d0e21e
LW		 5318PP(pp_ggrent)
5319{
0994c4d0 5320#ifdef HAS_GROUP
97aff369 5321 dVAR; dSP;
6136c704
AL		 5322 const I32 which = PL_op->op_type;
5323 const struct group *grent;
a0d0e21e 5324
edd309b7 5325 if (which == OP_GGRNAM) {
0bcc34c2 5326 const char* const name = POPpbytex;
6136c704 5327 grent = (const struct group *)getgrnam(name);
edd309b7
JH		 5328 }
5329 else if (which == OP_GGRGID) {
0bcc34c2 5330 const Gid_t gid = POPi;
6136c704 5331 grent = (const struct group *)getgrgid(gid);
edd309b7 5332 }
a0d0e21e 5333 else
0994c4d0 5334#ifdef HAS_GETGRENT
a0d0e21e 5335 grent = (struct group *)getgrent();
0994c4d0
JH		 5336#else
5337 DIE(aTHX_ PL_no_func, "getgrent");
5338#endif
a0d0e21e
LW		 5339
5340 EXTEND(SP, 4);
5341 if (GIMME != G_ARRAY) {
6136c704
AL		 5342 SV * const sv = sv_newmortal();
5343
5344 PUSHs(sv);
a0d0e21e
LW		 5345 if (grent) {
5346 if (which == OP_GGRNAM)
f325df1b 5347#if Gid_t_sign <= 0
1e422769 5348 sv_setiv(sv, (IV)grent->gr_gid);
f325df1b
DS		 5349#else
5350 sv_setuv(sv, (UV)grent->gr_gid);
5351#endif
a0d0e21e
LW		 5352 else
5353 sv_setpv(sv, grent->gr_name);
5354 }
5355 RETURN;
5356 }
5357
5358 if (grent) {
6e449a3a 5359 mPUSHs(newSVpv(grent->gr_name, 0));
28e8609d 5360
28e8609d 5361#ifdef GRPASSWD
6e449a3a 5362 mPUSHs(newSVpv(grent->gr_passwd, 0));
7c58897d
NC		 5363#else
5364 PUSHs(sv_mortalcopy(&PL_sv_no));
28e8609d
JH		 5365#endif
5366
f325df1b 5367#if Gid_t_sign <= 0
6e449a3a 5368 mPUSHi(grent->gr_gid);
f325df1b
DS		 5369#else
5370 mPUSHu(grent->gr_gid);
5371#endif
28e8609d 5372
5b56e7c5 5373#if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
3d7e8424
JH		 5374 /* In UNICOS/mk (_CRAYMPP) the multithreading
5375 * versions (getgrnam_r, getgrgid_r)
5376 * seem to return an illegal pointer
5377 * as the group members list, gr_mem.
5378 * getgrent() doesn't even have a _r version
5379 * but the gr_mem is poisonous anyway.
5380 * So yes, you cannot get the list of group
5381 * members if building multithreaded in UNICOS/mk. */
931e0695 5382 PUSHs(space_join_names_mortal(grent->gr_mem));
3d7e8424 5383#endif
a0d0e21e
LW		 5384 }
5385
5386 RETURN;
5387#else
af51a00e 5388 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
a0d0e21e
LW		 5389#endif
5390}
5391
a0d0e21e
LW		 5392PP(pp_getlogin)
5393{
a0d0e21e 5394#ifdef HAS_GETLOGIN
97aff369 5395 dVAR; dSP; dTARGET;
a0d0e21e
LW		 5396 char *tmps;
5397 EXTEND(SP, 1);
76e3520e 5398 if (!(tmps = PerlProc_getlogin()))
a0d0e21e 5399 RETPUSHUNDEF;
bee8aa44
NC		 5400 sv_setpv_mg(TARG, tmps);
5401 PUSHs(TARG);
a0d0e21e
LW		 5402 RETURN;
5403#else
cea2e8a9 5404 DIE(aTHX_ PL_no_func, "getlogin");
a0d0e21e
LW		 5405#endif
5406}
5407
5408/* Miscellaneous. */
5409
5410PP(pp_syscall)
5411{
d2719217 5412#ifdef HAS_SYSCALL
97aff369 5413 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW		 5414 register I32 items = SP - MARK;
5415 unsigned long a[20];
5416 register I32 i = 0;
5417 I32 retval = -1;
5418
3280af22 5419 if (PL_tainting) {
a0d0e21e 5420 while (++MARK <= SP) {
bbce6d69 5421 if (SvTAINTED(*MARK)) {
5422 TAINT;
5423 break;
5424 }
a0d0e21e
LW		 5425 }
5426 MARK = ORIGMARK;
5427 TAINT_PROPER("syscall");
5428 }
5429
5430 /* This probably won't work on machines where sizeof(long) != sizeof(int)
5431 * or where sizeof(long) != sizeof(char*). But such machines will
5432 * not likely have syscall implemented either, so who cares?
5433 */
5434 while (++MARK <= SP) {
5435 if (SvNIOK(*MARK) || !i)
5436 a[i++] = SvIV(*MARK);
3280af22 5437 else if (*MARK == &PL_sv_undef)
748a9306 5438 a[i++] = 0;
301e8125 5439 else
8b6b16e7 5440 a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
a0d0e21e
LW		 5441 if (i > 15)
5442 break;
5443 }
5444 switch (items) {
5445 default:
cea2e8a9 5446 DIE(aTHX_ "Too many args to syscall");
a0d0e21e 5447 case 0:
cea2e8a9 5448 DIE(aTHX_ "Too few args to syscall");
a0d0e21e
LW		 5449 case 1:
5450 retval = syscall(a[0]);
5451 break;
5452 case 2:
5453 retval = syscall(a[0],a[1]);
5454 break;
5455 case 3:
5456 retval = syscall(a[0],a[1],a[2]);
5457 break;
5458 case 4:
5459 retval = syscall(a[0],a[1],a[2],a[3]);
5460 break;
5461 case 5:
5462 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5463 break;
5464 case 6:
5465 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5466 break;
5467 case 7:
5468 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5469 break;
5470 case 8:
5471 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5472 break;
5473#ifdef atarist
5474 case 9:
5475 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5476 break;
5477 case 10:
5478 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
5479 break;
5480 case 11:
5481 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5482 a[10]);
5483 break;
5484 case 12:
5485 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5486 a[10],a[11]);
5487 break;
5488 case 13:
5489 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5490 a[10],a[11],a[12]);
5491 break;
5492 case 14:
5493 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5494 a[10],a[11],a[12],a[13]);
5495 break;
5496#endif /* atarist */
5497 }
5498 SP = ORIGMARK;
5499 PUSHi(retval);
5500 RETURN;
5501#else
cea2e8a9 5502 DIE(aTHX_ PL_no_func, "syscall");
a0d0e21e
LW		 5503#endif
5504}
5505
ff68c719 5506#ifdef FCNTL_EMULATE_FLOCK
301e8125 5507
ff68c719 5508/* XXX Emulate flock() with fcntl().
5509 What's really needed is a good file locking module.
5510*/
5511
cea2e8a9
GS		 5512static int
5513fcntl_emulate_flock(int fd, int operation)
ff68c719 5514{
fd9e8b45 5515 int res;
ff68c719 5516 struct flock flock;
301e8125 5517
ff68c719 5518 switch (operation & ~LOCK_NB) {
5519 case LOCK_SH:
5520 flock.l_type = F_RDLCK;
5521 break;
5522 case LOCK_EX:
5523 flock.l_type = F_WRLCK;
5524 break;
5525 case LOCK_UN:
5526 flock.l_type = F_UNLCK;
5527 break;
5528 default:
5529 errno = EINVAL;
5530 return -1;
5531 }
5532 flock.l_whence = SEEK_SET;
d9b3e12d 5533 flock.l_start = flock.l_len = (Off_t)0;
301e8125 5534
fd9e8b45
JD		 5535 res = fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5536 if (res == -1 && ((errno == EAGAIN) || (errno == EACCES)))
5537 errno = EWOULDBLOCK;
5538 return res;
ff68c719 5539}
5540
5541#endif /* FCNTL_EMULATE_FLOCK */
5542
5543#ifdef LOCKF_EMULATE_FLOCK
16d20bd9
AD		 5544
5545/* XXX Emulate flock() with lockf(). This is just to increase
5546 portability of scripts. The calls are not completely
5547 interchangeable. What's really needed is a good file
5548 locking module.
5549*/
5550
76c32331 5551/* The lockf() constants might have been defined in <unistd.h>.
5552 Unfortunately, <unistd.h> causes troubles on some mixed
5553 (BSD/POSIX) systems, such as SunOS 4.1.3.
16d20bd9
AD		 5554
5555 Further, the lockf() constants aren't POSIX, so they might not be
5556 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
5557 just stick in the SVID values and be done with it. Sigh.
5558*/
5559
5560# ifndef F_ULOCK
5561# define F_ULOCK 0 /* Unlock a previously locked region */
5562# endif
5563# ifndef F_LOCK
5564# define F_LOCK 1 /* Lock a region for exclusive use */
5565# endif
5566# ifndef F_TLOCK
5567# define F_TLOCK 2 /* Test and lock a region for exclusive use */
5568# endif
5569# ifndef F_TEST
5570# define F_TEST 3 /* Test a region for other processes locks */
5571# endif
5572
cea2e8a9
GS		 5573static int
5574lockf_emulate_flock(int fd, int operation)
16d20bd9
AD		 5575{
5576 int i;
84902520 5577 Off_t pos;
4ee39169 5578 dSAVE_ERRNO;
84902520
TB		 5579
5580 /* flock locks entire file so for lockf we need to do the same */
6ad3d225 5581 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
84902520 5582 if (pos > 0) /* is seekable and needs to be repositioned */
6ad3d225 5583 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
08b714dd 5584 pos = -1; /* seek failed, so don't seek back afterwards */
4ee39169 5585 RESTORE_ERRNO;
84902520 5586
16d20bd9
AD		 5587 switch (operation) {
5588
5589 /* LOCK_SH - get a shared lock */
5590 case LOCK_SH:
5591 /* LOCK_EX - get an exclusive lock */
5592 case LOCK_EX:
5593 i = lockf (fd, F_LOCK, 0);
5594 break;
5595
5596 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5597 case LOCK_SH|LOCK_NB:
5598 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5599 case LOCK_EX|LOCK_NB:
5600 i = lockf (fd, F_TLOCK, 0);
5601 if (i == -1)
5602 if ((errno == EAGAIN) || (errno == EACCES))
5603 errno = EWOULDBLOCK;
5604 break;
5605
ff68c719 5606 /* LOCK_UN - unlock (non-blocking is a no-op) */
16d20bd9 5607 case LOCK_UN:
ff68c719 5608 case LOCK_UN|LOCK_NB:
16d20bd9
AD		 5609 i = lockf (fd, F_ULOCK, 0);
5610 break;
5611
5612 /* Default - can't decipher operation */
5613 default:
5614 i = -1;
5615 errno = EINVAL;
5616 break;
5617 }
84902520
TB		 5618
5619 if (pos > 0) /* need to restore position of the handle */
6ad3d225 5620 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
84902520 5621
16d20bd9
AD		 5622 return (i);
5623}
ff68c719 5624
5625#endif /* LOCKF_EMULATE_FLOCK */
241d1a3b
NC		 5626
5627/*
5628 * Local variables:
5629 * c-indentation-style: bsd
5630 * c-basic-offset: 4
5631 * indent-tabs-mode: t
5632 * End:
5633 *
37442d52
RGS		 5634 * ex: set ts=8 sts=4 sw=4 noet:
5635 */
Unnamed repository; edit this file 'description' to name the repository.