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