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