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