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