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