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