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