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