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