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