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