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