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