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
cflags.SH: 30327 wasn't portable Bourne (avoid '!: not found')
[perl5.git] / pp_sys.c
CommitLineData
a0d0e21e
LW		 1/* pp_sys.c
2 *
fdf8c088
RGS		 3 * Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
4 * 2004, 2005, 2006, 2007 by Larry Wall and others
a0d0e21e
LW		 5 *
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
8 *
9 */
10
11/*
12 * But only a short way ahead its floor and the walls on either side were
13 * cloven by a great fissure, out of which the red glare came, now leaping
14 * up, now dying down into darkness; and all the while far below there was
15 * a rumour and a trouble as of great engines throbbing and labouring.
16 */
17
166f8a29
DM		 18/* This file contains system pp ("push/pop") functions that
19 * execute the opcodes that make up a perl program. A typical pp function
20 * expects to find its arguments on the stack, and usually pushes its
21 * results onto the stack, hence the 'pp' terminology. Each OP structure
22 * contains a pointer to the relevant pp_foo() function.
23 *
24 * By 'system', we mean ops which interact with the OS, such as pp_open().
25 */
26
a0d0e21e 27#include "EXTERN.h"
864dbfa3 28#define PERL_IN_PP_SYS_C
a0d0e21e
LW		 29#include "perl.h"
30
f1066039
JH		 31#ifdef I_SHADOW
32/* Shadow password support for solaris - pdo@cs.umd.edu
33 * Not just Solaris: at least HP-UX, IRIX, Linux.
3813c136
JH		 34 * The API is from SysV.
35 *
36 * There are at least two more shadow interfaces,
37 * see the comments in pp_gpwent().
38 *
39 * --jhi */
40# ifdef __hpux__
c529f79d 41/* There is a MAXINT coming from <shadow.h> <- <hpsecurity.h> <- <values.h>
301e8125 42 * and another MAXINT from "perl.h" <- <sys/param.h>. */
3813c136
JH		 43# undef MAXINT
44# endif
45# include <shadow.h>
8c0bfa08
PB		 46#endif
47
76c32331 48#ifdef I_SYS_WAIT
49# include <sys/wait.h>
50#endif
51
52#ifdef I_SYS_RESOURCE
53# include <sys/resource.h>
16d20bd9 54#endif
a0d0e21e 55
2986a63f
JH		 56#ifdef NETWARE
57NETDB_DEFINE_CONTEXT
58#endif
59
a0d0e21e 60#ifdef HAS_SELECT
1e743fda
JH		 61# ifdef I_SYS_SELECT
62# include <sys/select.h>
63# endif
a0d0e21e 64#endif
a0d0e21e 65
dc45a647
MB		 66/* XXX Configure test needed.
67 h_errno might not be a simple 'int', especially for multi-threaded
5ff3f7a4
GS		 68 applications, see "extern int errno in perl.h". Creating such
69 a test requires taking into account the differences between
70 compiling multithreaded and singlethreaded ($ccflags et al).
71 HOST_NOT_FOUND is typically defined in <netdb.h>.
dc45a647 72*/
cb50131a 73#if defined(HOST_NOT_FOUND) && !defined(h_errno) && !defined(__CYGWIN__)
a0d0e21e
LW		 74extern int h_errno;
75#endif
76
77#ifdef HAS_PASSWD
78# ifdef I_PWD
79# include <pwd.h>
80# else
fd8cd3a3 81# if !defined(VMS)
20ce7b12
GS		 82 struct passwd *getpwnam (char *);
83 struct passwd *getpwuid (Uid_t);
fd8cd3a3 84# endif
a0d0e21e 85# endif
28e8609d 86# ifdef HAS_GETPWENT
10bc17b6 87#ifndef getpwent
20ce7b12 88 struct passwd *getpwent (void);
c2a8f790 89#elif defined (VMS) && defined (my_getpwent)
9fa802f3 90 struct passwd *Perl_my_getpwent (pTHX);
10bc17b6 91#endif
28e8609d 92# endif
a0d0e21e
LW		 93#endif
94
95#ifdef HAS_GROUP
96# ifdef I_GRP
97# include <grp.h>
98# else
20ce7b12
GS		 99 struct group *getgrnam (char *);
100 struct group *getgrgid (Gid_t);
a0d0e21e 101# endif
28e8609d 102# ifdef HAS_GETGRENT
10bc17b6 103#ifndef getgrent
20ce7b12 104 struct group *getgrent (void);
10bc17b6 105#endif
28e8609d 106# endif
a0d0e21e
LW		 107#endif
108
109#ifdef I_UTIME
3730b96e 110# if defined(_MSC_VER) || defined(__MINGW32__)
3fe9a6f1 111# include <sys/utime.h>
112# else
113# include <utime.h>
114# endif
a0d0e21e 115#endif
a0d0e21e 116
cbdc8872 117#ifdef HAS_CHSIZE
cd52b7b2 118# ifdef my_chsize /* Probably #defined to Perl_my_chsize in embed.h */
119# undef my_chsize
120# endif
72cc7e2a 121# define my_chsize PerlLIO_chsize
27da23d5
JH		 122#else
123# ifdef HAS_TRUNCATE
124# define my_chsize PerlLIO_chsize
125# else
126I32 my_chsize(int fd, Off_t length);
127# endif
cbdc8872 128#endif
129
ff68c719 130#ifdef HAS_FLOCK
131# define FLOCK flock
132#else /* no flock() */
133
36477c24 134 /* fcntl.h might not have been included, even if it exists, because
135 the current Configure only sets I_FCNTL if it's needed to pick up
136 the *_OK constants. Make sure it has been included before testing
137 the fcntl() locking constants. */
138# if defined(HAS_FCNTL) && !defined(I_FCNTL)
139# include <fcntl.h>
140# endif
141
9d9004a9 142# if defined(HAS_FCNTL) && defined(FCNTL_CAN_LOCK)
ff68c719 143# define FLOCK fcntl_emulate_flock
144# define FCNTL_EMULATE_FLOCK
145# else /* no flock() or fcntl(F_SETLK,...) */
146# ifdef HAS_LOCKF
147# define FLOCK lockf_emulate_flock
148# define LOCKF_EMULATE_FLOCK
149# endif /* lockf */
150# endif /* no flock() or fcntl(F_SETLK,...) */
151
152# ifdef FLOCK
20ce7b12 153 static int FLOCK (int, int);
ff68c719 154
155 /*
156 * These are the flock() constants. Since this sytems doesn't have
157 * flock(), the values of the constants are probably not available.
158 */
159# ifndef LOCK_SH
160# define LOCK_SH 1
161# endif
162# ifndef LOCK_EX
163# define LOCK_EX 2
164# endif
165# ifndef LOCK_NB
166# define LOCK_NB 4
167# endif
168# ifndef LOCK_UN
169# define LOCK_UN 8
170# endif
171# endif /* emulating flock() */
172
173#endif /* no flock() */
55497cff 174
85ab1d1d 175#define ZBTLEN 10
27da23d5 176static const char zero_but_true[ZBTLEN + 1] = "0 but true";
85ab1d1d 177
5ff3f7a4
GS		 178#if defined(I_SYS_ACCESS) && !defined(R_OK)
179# include <sys/access.h>
180#endif
181
c529f79d
CB		 182#if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
183# define FD_CLOEXEC 1 /* NeXT needs this */
184#endif
185
a4af207c
JH		 186#include "reentr.h"
187
9cffb111
OS		 188#ifdef __Lynx__
189/* Missing protos on LynxOS */
190void sethostent(int);
191void endhostent(void);
192void setnetent(int);
193void endnetent(void);
194void setprotoent(int);
195void endprotoent(void);
196void setservent(int);
197void endservent(void);
198#endif
199
faee0e31 200#undef PERL_EFF_ACCESS /* EFFective uid/gid ACCESS */
5ff3f7a4 201
a4323dee
MB		 202/* AIX 5.2 and below use mktime for localtime, and defines the edge case
203 * for time 0x7fffffff to be valid only in UTC. AIX 5.3 provides localtime64
204 * available in the 32bit environment, which could warrant Configure
205 * checks in the future.
206 */
207#ifdef _AIX
208#define LOCALTIME_EDGECASE_BROKEN
209#endif
210
5ff3f7a4
GS		 211/* F_OK unused: if stat() cannot find it... */
212
d7558cad 213#if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) && defined(EFF_ONLY_OK) && !defined(NO_EFF_ONLY_OK)
c955f117 214 /* Digital UNIX (when the EFF_ONLY_OK gets fixed), UnixWare */
d7558cad 215# define PERL_EFF_ACCESS(p,f) (access((p), (f) | EFF_ONLY_OK))
5ff3f7a4
GS		 216#endif
217
d7558cad 218#if !defined(PERL_EFF_ACCESS) && defined(HAS_EACCESS)
3813c136 219# ifdef I_SYS_SECURITY
5ff3f7a4
GS		 220# include <sys/security.h>
221# endif
c955f117
JH		 222# ifdef ACC_SELF
223 /* HP SecureWare */
d7558cad 224# define PERL_EFF_ACCESS(p,f) (eaccess((p), (f), ACC_SELF))
c955f117
JH		 225# else
226 /* SCO */
d7558cad 227# define PERL_EFF_ACCESS(p,f) (eaccess((p), (f)))
c955f117 228# endif
5ff3f7a4
GS		 229#endif
230
d7558cad 231#if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESSX) && defined(ACC_SELF)
c955f117 232 /* AIX */
d7558cad 233# define PERL_EFF_ACCESS(p,f) (accessx((p), (f), ACC_SELF))
5ff3f7a4
GS		 234#endif
235
d7558cad
NC		 236
237#if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) \
327c3667
GS		 238 && (defined(HAS_SETREUID) || defined(HAS_SETRESUID) \
239 || defined(HAS_SETREGID) || defined(HAS_SETRESGID))
5ff3f7a4 240/* The Hard Way. */
327c3667 241STATIC int
7f4774ae 242S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
ba106d47 243{
c4420975
AL		 244 const Uid_t ruid = getuid();
245 const Uid_t euid = geteuid();
246 const Gid_t rgid = getgid();
247 const Gid_t egid = getegid();
5ff3f7a4
GS		 248 int res;
249
146174a9 250 LOCK_CRED_MUTEX;
5ff3f7a4 251#if !defined(HAS_SETREUID) && !defined(HAS_SETRESUID)
cea2e8a9 252 Perl_croak(aTHX_ "switching effective uid is not implemented");
5ff3f7a4
GS		 253#else
254#ifdef HAS_SETREUID
255 if (setreuid(euid, ruid))
256#else
257#ifdef HAS_SETRESUID
258 if (setresuid(euid, ruid, (Uid_t)-1))
259#endif
260#endif
cea2e8a9 261 Perl_croak(aTHX_ "entering effective uid failed");
5ff3f7a4
GS		 262#endif
263
264#if !defined(HAS_SETREGID) && !defined(HAS_SETRESGID)
cea2e8a9 265 Perl_croak(aTHX_ "switching effective gid is not implemented");
5ff3f7a4
GS		 266#else
267#ifdef HAS_SETREGID
268 if (setregid(egid, rgid))
269#else
270#ifdef HAS_SETRESGID
271 if (setresgid(egid, rgid, (Gid_t)-1))
272#endif
273#endif
cea2e8a9 274 Perl_croak(aTHX_ "entering effective gid failed");
5ff3f7a4
GS		 275#endif
276
277 res = access(path, mode);
278
279#ifdef HAS_SETREUID
280 if (setreuid(ruid, euid))
281#else
282#ifdef HAS_SETRESUID
283 if (setresuid(ruid, euid, (Uid_t)-1))
284#endif
285#endif
cea2e8a9 286 Perl_croak(aTHX_ "leaving effective uid failed");
5ff3f7a4
GS		 287
288#ifdef HAS_SETREGID
289 if (setregid(rgid, egid))
290#else
291#ifdef HAS_SETRESGID
292 if (setresgid(rgid, egid, (Gid_t)-1))
293#endif
294#endif
cea2e8a9 295 Perl_croak(aTHX_ "leaving effective gid failed");
146174a9 296 UNLOCK_CRED_MUTEX;
5ff3f7a4
GS		 297
298 return res;
299}
d7558cad 300# define PERL_EFF_ACCESS(p,f) (emulate_eaccess((p), (f)))
5ff3f7a4
GS		 301#endif
302
faee0e31 303#if !defined(PERL_EFF_ACCESS)
76ffd3b9
IZ		 304/* With it or without it: anyway you get a warning: either that
305 it is unused, or it is declared static and never defined.
306 */
327c3667 307STATIC int
7f4774ae 308S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
ba106d47 309{
294a48e9
AL		 310 PERL_UNUSED_ARG(path);
311 PERL_UNUSED_ARG(mode);
cea2e8a9 312 Perl_croak(aTHX_ "switching effective uid is not implemented");
5ff3f7a4
GS		 313 /*NOTREACHED*/
314 return -1;
315}
316#endif
317
a0d0e21e
LW		 318PP(pp_backtick)
319{
97aff369 320 dVAR; dSP; dTARGET;
760ac839 321 PerlIO *fp;
1b6737cc 322 const char * const tmps = POPpconstx;
f54cb97a 323 const I32 gimme = GIMME_V;
e1ec3a88 324 const char *mode = "r";
54310121 325
a0d0e21e 326 TAINT_PROPER("``");
16fe6d59
GS		 327 if (PL_op->op_private & OPpOPEN_IN_RAW)
328 mode = "rb";
329 else if (PL_op->op_private & OPpOPEN_IN_CRLF)
330 mode = "rt";
2fbb330f 331 fp = PerlProc_popen(tmps, mode);
a0d0e21e 332 if (fp) {
11bcd5da 333 const char * const type = Perl_PerlIO_context_layers(aTHX_ NULL);
ac27b0f5
NIS		 334 if (type && *type)
335 PerlIO_apply_layers(aTHX_ fp,mode,type);
336
54310121 337 if (gimme == G_VOID) {
96827780
MB		 338 char tmpbuf[256];
339 while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0)
a79db61d 340 NOOP;
54310121 341 }
342 else if (gimme == G_SCALAR) {
75af1a9c
DM		 343 ENTER;
344 SAVESPTR(PL_rs);
fa326138 345 PL_rs = &PL_sv_undef;
c69006e4 346 sv_setpvn(TARG, "", 0); /* note that this preserves previous buffer */
bd61b366 347 while (sv_gets(TARG, fp, SvCUR(TARG)) != NULL)
a79db61d 348 NOOP;
75af1a9c 349 LEAVE;
a0d0e21e 350 XPUSHs(TARG);
aa689395 351 SvTAINTED_on(TARG);
a0d0e21e
LW		 352 }
353 else {
a0d0e21e 354 for (;;) {
561b68a9 355 SV * const sv = newSV(79);
bd61b366 356 if (sv_gets(sv, fp, 0) == NULL) {
a0d0e21e
LW		 357 SvREFCNT_dec(sv);
358 break;
359 }
360 XPUSHs(sv_2mortal(sv));
361 if (SvLEN(sv) - SvCUR(sv) > 20) {
1da4ca5f 362 SvPV_shrink_to_cur(sv);
a0d0e21e 363 }
aa689395 364 SvTAINTED_on(sv);
a0d0e21e
LW		 365 }
366 }
2fbb330f 367 STATUS_NATIVE_CHILD_SET(PerlProc_pclose(fp));
aa689395 368 TAINT; /* "I believe that this is not gratuitous!" */
a0d0e21e
LW		 369 }
370 else {
37038d91 371 STATUS_NATIVE_CHILD_SET(-1);
54310121 372 if (gimme == G_SCALAR)
a0d0e21e
LW		 373 RETPUSHUNDEF;
374 }
375
376 RETURN;
377}
378
379PP(pp_glob)
380{
27da23d5 381 dVAR;
a0d0e21e 382 OP *result;
f5284f61
IZ		 383 tryAMAGICunTARGET(iter, -1);
384
71686f12
GS		 385 /* Note that we only ever get here if File::Glob fails to load
386 * without at the same time croaking, for some reason, or if
387 * perl was built with PERL_EXTERNAL_GLOB */
388
a0d0e21e 389 ENTER;
a0d0e21e 390
c90c0ff4 391#ifndef VMS
3280af22 392 if (PL_tainting) {
7bac28a0 393 /*
394 * The external globbing program may use things we can't control,
395 * so for security reasons we must assume the worst.
396 */
397 TAINT;
22c35a8c 398 taint_proper(PL_no_security, "glob");
7bac28a0 399 }
c90c0ff4 400#endif /* !VMS */
7bac28a0 401
3280af22
NIS		 402 SAVESPTR(PL_last_in_gv); /* We don't want this to be permanent. */
403 PL_last_in_gv = (GV*)*PL_stack_sp--;
a0d0e21e 404
3280af22 405 SAVESPTR(PL_rs); /* This is not permanent, either. */
396482e1 406 PL_rs = sv_2mortal(newSVpvs("\000"));
c07a80fd 407#ifndef DOSISH
408#ifndef CSH
6b88bc9c 409 *SvPVX(PL_rs) = '\n';
a0d0e21e 410#endif /* !CSH */
55497cff 411#endif /* !DOSISH */
c07a80fd 412
a0d0e21e
LW		 413 result = do_readline();
414 LEAVE;
415 return result;
416}
417
a0d0e21e
LW		 418PP(pp_rcatline)
419{
97aff369 420 dVAR;
146174a9 421 PL_last_in_gv = cGVOP_gv;
a0d0e21e
LW		 422 return do_readline();
423}
424
425PP(pp_warn)
426{
97aff369 427 dVAR; dSP; dMARK;
06bf62c7 428 SV *tmpsv;
e1ec3a88 429 const char *tmps;
06bf62c7 430 STRLEN len;
b59aed67 431 if (SP - MARK > 1) {
a0d0e21e 432 dTARGET;
3280af22 433 do_join(TARG, &PL_sv_no, MARK, SP);
06bf62c7 434 tmpsv = TARG;
a0d0e21e
LW		 435 SP = MARK + 1;
436 }
b59aed67
TS		 437 else if (SP == MARK) {
438 tmpsv = &PL_sv_no;
439 EXTEND(SP, 1);
83f957ec 440 SP = MARK + 1;
b59aed67 441 }
a0d0e21e 442 else {
06bf62c7 443 tmpsv = TOPs;
a0d0e21e 444 }
e62f0680 445 tmps = SvPV_const(tmpsv, len);
7b102d90 446 if ((!tmps || !len) && PL_errgv) {
1b6737cc 447 SV * const error = ERRSV;
862a34c6 448 SvUPGRADE(error, SVt_PV);
4e6ea2c3 449 if (SvPOK(error) && SvCUR(error))
396482e1 450 sv_catpvs(error, "\t...caught");
06bf62c7 451 tmpsv = error;
e62f0680 452 tmps = SvPV_const(tmpsv, len);
a0d0e21e 453 }
06bf62c7 454 if (!tmps || !len)
396482e1 455 tmpsv = sv_2mortal(newSVpvs("Warning: something's wrong"));
06bf62c7 456
be2597df 457 Perl_warn(aTHX_ "%"SVf, SVfARG(tmpsv));
a0d0e21e
LW		 458 RETSETYES;
459}
460
461PP(pp_die)
462{
97aff369 463 dVAR; dSP; dMARK;
e1ec3a88 464 const char *tmps;
06bf62c7
GS		 465 SV *tmpsv;
466 STRLEN len;
467 bool multiarg = 0;
96e176bf
CL		 468#ifdef VMS
469 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
470#endif
a0d0e21e
LW		 471 if (SP - MARK != 1) {
472 dTARGET;
3280af22 473 do_join(TARG, &PL_sv_no, MARK, SP);
06bf62c7 474 tmpsv = TARG;
5c144d81 475 tmps = SvPV_const(tmpsv, len);
06bf62c7 476 multiarg = 1;
a0d0e21e
LW		 477 SP = MARK + 1;
478 }
479 else {
4e6ea2c3 480 tmpsv = TOPs;
bd61b366 481 tmps = SvROK(tmpsv) ? NULL : SvPV_const(tmpsv, len);
a0d0e21e 482 }
06bf62c7 483 if (!tmps || !len) {
0bcc34c2 484 SV * const error = ERRSV;
862a34c6 485 SvUPGRADE(error, SVt_PV);
06bf62c7
GS		 486 if (multiarg ? SvROK(error) : SvROK(tmpsv)) {
487 if (!multiarg)
4e6ea2c3 488 SvSetSV(error,tmpsv);
06bf62c7 489 else if (sv_isobject(error)) {
7452cf6a
AL		 490 HV * const stash = SvSTASH(SvRV(error));
491 GV * const gv = gv_fetchmethod(stash, "PROPAGATE");
05423cc9 492 if (gv) {
7452cf6a
AL		 493 SV * const file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0));
494 SV * const line = sv_2mortal(newSVuv(CopLINE(PL_curcop)));
05423cc9
GS		 495 EXTEND(SP, 3);
496 PUSHMARK(SP);
497 PUSHs(error);
498 PUSHs(file);
499 PUSHs(line);
500 PUTBACK;
864dbfa3
GS		 501 call_sv((SV*)GvCV(gv),
502 G_SCALAR|G_EVAL|G_KEEPERR);
3280af22 503 sv_setsv(error,*PL_stack_sp--);
05423cc9
GS		 504 }
505 }
bd61b366 506 DIE(aTHX_ NULL);
4e6ea2c3
GS		 507 }
508 else {
509 if (SvPOK(error) && SvCUR(error))
396482e1 510 sv_catpvs(error, "\t...propagated");
06bf62c7 511 tmpsv = error;
dc8d642c
DM		 512 if (SvOK(tmpsv))
513 tmps = SvPV_const(tmpsv, len);
514 else
bd61b366 515 tmps = NULL;
4e6ea2c3 516 }
a0d0e21e 517 }
06bf62c7 518 if (!tmps || !len)
396482e1 519 tmpsv = sv_2mortal(newSVpvs("Died"));
06bf62c7 520
be2597df 521 DIE(aTHX_ "%"SVf, SVfARG(tmpsv));
a0d0e21e
LW		 522}
523
524/* I/O. */
525
526PP(pp_open)
527{
27da23d5 528 dVAR; dSP;
a567e93b
NIS		 529 dMARK; dORIGMARK;
530 dTARGET;
a0d0e21e 531 SV *sv;
5b468f54 532 IO *io;
5c144d81 533 const char *tmps;
a0d0e21e 534 STRLEN len;
a567e93b 535 bool ok;
a0d0e21e 536
c4420975
AL		 537 GV * const gv = (GV *)*++MARK;
538
5f05dabc 539 if (!isGV(gv))
cea2e8a9 540 DIE(aTHX_ PL_no_usym, "filehandle");
a79db61d
AL		 541 if ((io = GvIOp(gv))) {
542 MAGIC *mg;
36477c24 543 IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
853846ea 544
a79db61d 545 mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
c4420975
AL		 546 if (mg) {
547 /* Method's args are same as ours ... */
548 /* ... except handle is replaced by the object */
549 *MARK-- = SvTIED_obj((SV*)io, mg);
550 PUSHMARK(MARK);
551 PUTBACK;
552 ENTER;
553 call_method("OPEN", G_SCALAR);
554 LEAVE;
555 SPAGAIN;
556 RETURN;
557 }
4592e6ca
NIS		 558 }
559
a567e93b
NIS		 560 if (MARK < SP) {
561 sv = *++MARK;
562 }
563 else {
35a08ec7 564 sv = GvSVn(gv);
a567e93b
NIS		 565 }
566
5c144d81 567 tmps = SvPV_const(sv, len);
4608196e 568 ok = do_openn(gv, tmps, len, FALSE, O_RDONLY, 0, NULL, MARK+1, (SP-MARK));
a567e93b
NIS		 569 SP = ORIGMARK;
570 if (ok)
3280af22
NIS		 571 PUSHi( (I32)PL_forkprocess );
572 else if (PL_forkprocess == 0) /* we are a new child */
a0d0e21e
LW		 573 PUSHi(0);
574 else
575 RETPUSHUNDEF;
576 RETURN;
577}
578
579PP(pp_close)
580{
27da23d5 581 dVAR; dSP;
c4420975 582 GV * const gv = (MAXARG == 0) ? PL_defoutgv : (GV*)POPs;
1d603a67 583
a79db61d
AL		 584 if (gv) {
585 IO * const io = GvIO(gv);
586 if (io) {
587 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
588 if (mg) {
589 PUSHMARK(SP);
590 XPUSHs(SvTIED_obj((SV*)io, mg));
591 PUTBACK;
592 ENTER;
593 call_method("CLOSE", G_SCALAR);
594 LEAVE;
595 SPAGAIN;
596 RETURN;
597 }
598 }
1d603a67 599 }
a0d0e21e 600 EXTEND(SP, 1);
54310121 601 PUSHs(boolSV(do_close(gv, TRUE)));
a0d0e21e
LW		 602 RETURN;
603}
604
605PP(pp_pipe_op)
606{
a0d0e21e 607#ifdef HAS_PIPE
97aff369 608 dVAR;
9cad6237 609 dSP;
a0d0e21e
LW		 610 register IO *rstio;
611 register IO *wstio;
612 int fd[2];
613
c4420975
AL		 614 GV * const wgv = (GV*)POPs;
615 GV * const rgv = (GV*)POPs;
a0d0e21e
LW		 616
617 if (!rgv || !wgv)
618 goto badexit;
619
4633a7c4 620 if (SvTYPE(rgv) != SVt_PVGV || SvTYPE(wgv) != SVt_PVGV)
cea2e8a9 621 DIE(aTHX_ PL_no_usym, "filehandle");
a0d0e21e
LW		 622 rstio = GvIOn(rgv);
623 wstio = GvIOn(wgv);
624
625 if (IoIFP(rstio))
626 do_close(rgv, FALSE);
627 if (IoIFP(wstio))
628 do_close(wgv, FALSE);
629
6ad3d225 630 if (PerlProc_pipe(fd) < 0)
a0d0e21e
LW		 631 goto badexit;
632
460c8493
IZ		 633 IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"PIPE_OPEN_MODE);
634 IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"PIPE_OPEN_MODE);
b5ac89c3 635 IoOFP(rstio) = IoIFP(rstio);
a0d0e21e 636 IoIFP(wstio) = IoOFP(wstio);
50952442
JH		 637 IoTYPE(rstio) = IoTYPE_RDONLY;
638 IoTYPE(wstio) = IoTYPE_WRONLY;
a0d0e21e
LW		 639
640 if (!IoIFP(rstio) || !IoOFP(wstio)) {
a79db61d
AL		 641 if (IoIFP(rstio))
642 PerlIO_close(IoIFP(rstio));
643 else
644 PerlLIO_close(fd[0]);
645 if (IoOFP(wstio))
646 PerlIO_close(IoOFP(wstio));
647 else
648 PerlLIO_close(fd[1]);
a0d0e21e
LW		 649 goto badexit;
650 }
4771b018
GS		 651#if defined(HAS_FCNTL) && defined(F_SETFD)
652 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
653 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
654#endif
a0d0e21e
LW		 655 RETPUSHYES;
656
657badexit:
658 RETPUSHUNDEF;
659#else
cea2e8a9 660 DIE(aTHX_ PL_no_func, "pipe");
a0d0e21e
LW		 661#endif
662}
663
664PP(pp_fileno)
665{
27da23d5 666 dVAR; dSP; dTARGET;
a0d0e21e
LW		 667 GV *gv;
668 IO *io;
760ac839 669 PerlIO *fp;
4592e6ca
NIS		 670 MAGIC *mg;
671
a0d0e21e
LW		 672 if (MAXARG < 1)
673 RETPUSHUNDEF;
674 gv = (GV*)POPs;
4592e6ca 675
5b468f54
AMS		 676 if (gv && (io = GvIO(gv))
677 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
678 {
4592e6ca 679 PUSHMARK(SP);
5b468f54 680 XPUSHs(SvTIED_obj((SV*)io, mg));
4592e6ca
NIS		 681 PUTBACK;
682 ENTER;
864dbfa3 683 call_method("FILENO", G_SCALAR);
4592e6ca
NIS		 684 LEAVE;
685 SPAGAIN;
686 RETURN;
687 }
688
c289d2f7
JH		 689 if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io))) {
690 /* Can't do this because people seem to do things like
691 defined(fileno($foo)) to check whether $foo is a valid fh.
692 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
693 report_evil_fh(gv, io, PL_op->op_type);
694 */
a0d0e21e 695 RETPUSHUNDEF;
c289d2f7
JH		 696 }
697
760ac839 698 PUSHi(PerlIO_fileno(fp));
a0d0e21e
LW		 699 RETURN;
700}
701
702PP(pp_umask)
703{
97aff369 704 dVAR;
27da23d5 705 dSP;
d7e492a4 706#ifdef HAS_UMASK
27da23d5 707 dTARGET;
761237fe 708 Mode_t anum;
a0d0e21e 709
a0d0e21e 710 if (MAXARG < 1) {
b0b546b3
GA		 711 anum = PerlLIO_umask(022);
712 /* setting it to 022 between the two calls to umask avoids
713 * to have a window where the umask is set to 0 -- meaning
714 * that another thread could create world-writeable files. */
715 if (anum != 022)
716 (void)PerlLIO_umask(anum);
a0d0e21e
LW		 717 }
718 else
6ad3d225 719 anum = PerlLIO_umask(POPi);
a0d0e21e
LW		 720 TAINT_PROPER("umask");
721 XPUSHi(anum);
722#else
a0288114 723 /* Only DIE if trying to restrict permissions on "user" (self).
eec2d3df
GS		 724 * Otherwise it's harmless and more useful to just return undef
725 * since 'group' and 'other' concepts probably don't exist here. */
726 if (MAXARG >= 1 && (POPi & 0700))
cea2e8a9 727 DIE(aTHX_ "umask not implemented");
6b88bc9c 728 XPUSHs(&PL_sv_undef);
a0d0e21e
LW		 729#endif
730 RETURN;
731}
732
733PP(pp_binmode)
734{
27da23d5 735 dVAR; dSP;
a0d0e21e
LW		 736 GV *gv;
737 IO *io;
760ac839 738 PerlIO *fp;
a0714e2c 739 SV *discp = NULL;
a0d0e21e
LW		 740
741 if (MAXARG < 1)
742 RETPUSHUNDEF;
60382766 743 if (MAXARG > 1) {
16fe6d59 744 discp = POPs;
60382766 745 }
a0d0e21e 746
301e8125 747 gv = (GV*)POPs;
4592e6ca 748
a79db61d
AL		 749 if (gv && (io = GvIO(gv))) {
750 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
751 if (mg) {
752 PUSHMARK(SP);
753 XPUSHs(SvTIED_obj((SV*)io, mg));
754 if (discp)
755 XPUSHs(discp);
756 PUTBACK;
757 ENTER;
758 call_method("BINMODE", G_SCALAR);
759 LEAVE;
760 SPAGAIN;
761 RETURN;
762 }
4592e6ca 763 }
a0d0e21e
LW		 764
765 EXTEND(SP, 1);
50f846a7 766 if (!(io = GvIO(gv)) || !(fp = IoIFP(io))) {
c289d2f7
JH		 767 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
768 report_evil_fh(gv, io, PL_op->op_type);
b5fe5ca2 769 SETERRNO(EBADF,RMS_IFI);
50f846a7
SC		 770 RETPUSHUNDEF;
771 }
a0d0e21e 772
40d98b49 773 PUTBACK;
f0a78170
NC		 774 {
775 const int mode = mode_from_discipline(discp);
776 const char *const d = (discp ? SvPV_nolen_const(discp) : NULL);
777 if (PerlIO_binmode(aTHX_ fp, IoTYPE(io), mode, d)) {
778 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
779 if (!PerlIO_binmode(aTHX_ IoOFP(io), IoTYPE(io), mode, d)) {
780 SPAGAIN;
781 RETPUSHUNDEF;
782 }
783 }
784 SPAGAIN;
785 RETPUSHYES;
786 }
787 else {
788 SPAGAIN;
789 RETPUSHUNDEF;
38af81ff 790 }
40d98b49 791 }
a0d0e21e
LW		 792}
793
794PP(pp_tie)
795{
27da23d5 796 dVAR; dSP; dMARK;
a0d0e21e
LW		 797 HV* stash;
798 GV *gv;
a0d0e21e 799 SV *sv;
1df70142 800 const I32 markoff = MARK - PL_stack_base;
e1ec3a88 801 const char *methname;
14befaf4 802 int how = PERL_MAGIC_tied;
e336de0d 803 U32 items;
c4420975 804 SV *varsv = *++MARK;
a0d0e21e 805
6b05c17a
NIS		 806 switch(SvTYPE(varsv)) {
807 case SVt_PVHV:
808 methname = "TIEHASH";
bfcb3514 809 HvEITER_set((HV *)varsv, 0);
6b05c17a
NIS		 810 break;
811 case SVt_PVAV:
812 methname = "TIEARRAY";
813 break;
814 case SVt_PVGV:
7fb37951
AMS		 815#ifdef GV_UNIQUE_CHECK
816 if (GvUNIQUE((GV*)varsv)) {
817 Perl_croak(aTHX_ "Attempt to tie unique GV");
5bd07a3d
DM		 818 }
819#endif
6b05c17a 820 methname = "TIEHANDLE";
14befaf4 821 how = PERL_MAGIC_tiedscalar;
5b468f54
AMS		 822 /* For tied filehandles, we apply tiedscalar magic to the IO
823 slot of the GP rather than the GV itself. AMS 20010812 */
824 if (!GvIOp(varsv))
825 GvIOp(varsv) = newIO();
826 varsv = (SV *)GvIOp(varsv);
6b05c17a
NIS		 827 break;
828 default:
829 methname = "TIESCALAR";
14befaf4 830 how = PERL_MAGIC_tiedscalar;
6b05c17a
NIS		 831 break;
832 }
e336de0d
GS		 833 items = SP - MARK++;
834 if (sv_isobject(*MARK)) {
6b05c17a 835 ENTER;
e788e7d3 836 PUSHSTACKi(PERLSI_MAGIC);
e336de0d 837 PUSHMARK(SP);
eb160463 838 EXTEND(SP,(I32)items);
e336de0d
GS		 839 while (items--)
840 PUSHs(*MARK++);
841 PUTBACK;
864dbfa3 842 call_method(methname, G_SCALAR);
301e8125 843 }
6b05c17a 844 else {
864dbfa3 845 /* Not clear why we don't call call_method here too.
6b05c17a
NIS		 846 * perhaps to get different error message ?
847 */
da51bb9b 848 stash = gv_stashsv(*MARK, 0);
6b05c17a 849 if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
35c1215d 850 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"",
be2597df 851 methname, SVfARG(*MARK));
6b05c17a
NIS		 852 }
853 ENTER;
e788e7d3 854 PUSHSTACKi(PERLSI_MAGIC);
e336de0d 855 PUSHMARK(SP);
eb160463 856 EXTEND(SP,(I32)items);
e336de0d
GS		 857 while (items--)
858 PUSHs(*MARK++);
859 PUTBACK;
864dbfa3 860 call_sv((SV*)GvCV(gv), G_SCALAR);
6b05c17a 861 }
a0d0e21e
LW		 862 SPAGAIN;
863
864 sv = TOPs;
d3acc0f7 865 POPSTACK;
a0d0e21e 866 if (sv_isobject(sv)) {
33c27489 867 sv_unmagic(varsv, how);
ae21d580 868 /* Croak if a self-tie on an aggregate is attempted. */
b881518d 869 if (varsv == SvRV(sv) &&
d87ebaca
YST		 870 (SvTYPE(varsv) == SVt_PVAV ||
871 SvTYPE(varsv) == SVt_PVHV))
ae21d580
JH		 872 Perl_croak(aTHX_
873 "Self-ties of arrays and hashes are not supported");
a0714e2c 874 sv_magic(varsv, (SvRV(sv) == varsv ? NULL : sv), how, NULL, 0);
a0d0e21e
LW		 875 }
876 LEAVE;
3280af22 877 SP = PL_stack_base + markoff;
a0d0e21e
LW		 878 PUSHs(sv);
879 RETURN;
880}
881
882PP(pp_untie)
883{
27da23d5 884 dVAR; dSP;
5b468f54 885 MAGIC *mg;
33c27489 886 SV *sv = POPs;
1df70142 887 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
14befaf4 888 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
55497cff 889
5b468f54
AMS		 890 if (SvTYPE(sv) == SVt_PVGV && !(sv = (SV *)GvIOp(sv)))
891 RETPUSHYES;
892
65eba18f 893 if ((mg = SvTIED_mg(sv, how))) {
1b6737cc 894 SV * const obj = SvRV(SvTIED_obj(sv, mg));
fa2b88e0 895 if (obj) {
c4420975 896 GV * const gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE);
0bd48802 897 CV *cv;
c4420975 898 if (gv && isGV(gv) && (cv = GvCV(gv))) {
fa2b88e0
JS		 899 PUSHMARK(SP);
900 XPUSHs(SvTIED_obj((SV*)gv, mg));
901 XPUSHs(sv_2mortal(newSViv(SvREFCNT(obj)-1)));
902 PUTBACK;
903 ENTER;
904 call_sv((SV *)cv, G_VOID);
905 LEAVE;
906 SPAGAIN;
907 }
041457d9 908 else if (mg && SvREFCNT(obj) > 1 && ckWARN(WARN_UNTIE)) {
9014280d 909 Perl_warner(aTHX_ packWARN(WARN_UNTIE),
fa2b88e0
JS		 910 "untie attempted while %"UVuf" inner references still exist",
911 (UV)SvREFCNT(obj) - 1 ) ;
c4420975 912 }
cbdc8872 913 }
914 }
38193a09 915 sv_unmagic(sv, how) ;
55497cff 916 RETPUSHYES;
a0d0e21e
LW		 917}
918
c07a80fd 919PP(pp_tied)
920{
97aff369 921 dVAR;
39644a26 922 dSP;
1b6737cc 923 const MAGIC *mg;
33c27489 924 SV *sv = POPs;
1df70142 925 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
14befaf4 926 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
5b468f54
AMS		 927
928 if (SvTYPE(sv) == SVt_PVGV && !(sv = (SV *)GvIOp(sv)))
929 RETPUSHUNDEF;
c07a80fd 930
155aba94 931 if ((mg = SvTIED_mg(sv, how))) {
33c27489
GS		 932 SV *osv = SvTIED_obj(sv, mg);
933 if (osv == mg->mg_obj)
934 osv = sv_mortalcopy(osv);
935 PUSHs(osv);
936 RETURN;
c07a80fd 937 }
c07a80fd 938 RETPUSHUNDEF;
939}
940
a0d0e21e
LW		 941PP(pp_dbmopen)
942{
27da23d5 943 dVAR; dSP;
a0d0e21e
LW		 944 dPOPPOPssrl;
945 HV* stash;
946 GV *gv;
a0d0e21e 947
1b6737cc 948 HV * const hv = (HV*)POPs;
7c58897d 949 SV * const sv = sv_2mortal(newSVpvs("AnyDBM_File"));
da51bb9b 950 stash = gv_stashsv(sv, 0);
8ebc5c01 951 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
a0d0e21e 952 PUTBACK;
864dbfa3 953 require_pv("AnyDBM_File.pm");
a0d0e21e 954 SPAGAIN;
8ebc5c01 955 if (!(gv = gv_fetchmethod(stash, "TIEHASH")))
cea2e8a9 956 DIE(aTHX_ "No dbm on this machine");
a0d0e21e
LW		 957 }
958
57d3b86d 959 ENTER;
924508f0 960 PUSHMARK(SP);
6b05c17a 961
924508f0 962 EXTEND(SP, 5);
a0d0e21e
LW		 963 PUSHs(sv);
964 PUSHs(left);
965 if (SvIV(right))
b448e4fe 966 PUSHs(sv_2mortal(newSVuv(O_RDWR|O_CREAT)));
a0d0e21e 967 else
b448e4fe 968 PUSHs(sv_2mortal(newSVuv(O_RDWR)));
a0d0e21e 969 PUSHs(right);
57d3b86d 970 PUTBACK;
864dbfa3 971 call_sv((SV*)GvCV(gv), G_SCALAR);
a0d0e21e
LW		 972 SPAGAIN;
973
974 if (!sv_isobject(TOPs)) {
924508f0
GS		 975 SP--;
976 PUSHMARK(SP);
a0d0e21e
LW		 977 PUSHs(sv);
978 PUSHs(left);
b448e4fe 979 PUSHs(sv_2mortal(newSVuv(O_RDONLY)));
a0d0e21e 980 PUSHs(right);
a0d0e21e 981 PUTBACK;
864dbfa3 982 call_sv((SV*)GvCV(gv), G_SCALAR);
a0d0e21e
LW		 983 SPAGAIN;
984 }
985
6b05c17a 986 if (sv_isobject(TOPs)) {
14befaf4 987 sv_unmagic((SV *) hv, PERL_MAGIC_tied);
bd61b366 988 sv_magic((SV*)hv, TOPs, PERL_MAGIC_tied, NULL, 0);
6b05c17a 989 }
a0d0e21e
LW		 990 LEAVE;
991 RETURN;
992}
993
a0d0e21e
LW		 994PP(pp_sselect)
995{
a0d0e21e 996#ifdef HAS_SELECT
97aff369 997 dVAR; dSP; dTARGET;
a0d0e21e
LW		 998 register I32 i;
999 register I32 j;
1000 register char *s;
1001 register SV *sv;
65202027 1002 NV value;
a0d0e21e
LW		 1003 I32 maxlen = 0;
1004 I32 nfound;
1005 struct timeval timebuf;
1006 struct timeval *tbuf = &timebuf;
1007 I32 growsize;
1008 char *fd_sets[4];
1009#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1010 I32 masksize;
1011 I32 offset;
1012 I32 k;
1013
1014# if BYTEORDER & 0xf0000
1015# define ORDERBYTE (0x88888888 - BYTEORDER)
1016# else
1017# define ORDERBYTE (0x4444 - BYTEORDER)
1018# endif
1019
1020#endif
1021
1022 SP -= 4;
1023 for (i = 1; i <= 3; i++) {
c4420975 1024 SV * const sv = SP[i];
15547071
GA		 1025 if (!SvOK(sv))
1026 continue;
1027 if (SvREADONLY(sv)) {
729c079f
NC		 1028 if (SvIsCOW(sv))
1029 sv_force_normal_flags(sv, 0);
15547071 1030 if (SvREADONLY(sv) && !(SvPOK(sv) && SvCUR(sv) == 0))
729c079f
NC		 1031 DIE(aTHX_ PL_no_modify);
1032 }
4ef2275c
GA		 1033 if (!SvPOK(sv)) {
1034 if (ckWARN(WARN_MISC))
1035 Perl_warner(aTHX_ packWARN(WARN_MISC), "Non-string passed as bitmask");
1036 SvPV_force_nolen(sv); /* force string conversion */
1037 }
729c079f 1038 j = SvCUR(sv);
a0d0e21e
LW		 1039 if (maxlen < j)
1040 maxlen = j;
1041 }
1042
5ff3f7a4 1043/* little endians can use vecs directly */
e366b469 1044#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
5ff3f7a4 1045# ifdef NFDBITS
a0d0e21e 1046
5ff3f7a4
GS		 1047# ifndef NBBY
1048# define NBBY 8
1049# endif
a0d0e21e
LW		 1050
1051 masksize = NFDBITS / NBBY;
5ff3f7a4 1052# else
a0d0e21e 1053 masksize = sizeof(long); /* documented int, everyone seems to use long */
5ff3f7a4 1054# endif
a0d0e21e
LW		 1055 Zero(&fd_sets[0], 4, char*);
1056#endif
1057
ad517f75
MHM		 1058# if SELECT_MIN_BITS == 1
1059 growsize = sizeof(fd_set);
1060# else
1061# if defined(__GLIBC__) && defined(__FD_SETSIZE)
1062# undef SELECT_MIN_BITS
1063# define SELECT_MIN_BITS __FD_SETSIZE
1064# endif
e366b469
PG		 1065 /* If SELECT_MIN_BITS is greater than one we most probably will want
1066 * to align the sizes with SELECT_MIN_BITS/8 because for example
1067 * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
1068 * UNIX, Solaris, NeXT, Darwin) the smallest quantum select() operates
1069 * on (sets/tests/clears bits) is 32 bits. */
1070 growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
e366b469
PG		 1071# endif
1072
a0d0e21e
LW		 1073 sv = SP[4];
1074 if (SvOK(sv)) {
1075 value = SvNV(sv);
1076 if (value < 0.0)
1077 value = 0.0;
1078 timebuf.tv_sec = (long)value;
65202027 1079 value -= (NV)timebuf.tv_sec;
a0d0e21e
LW		 1080 timebuf.tv_usec = (long)(value * 1000000.0);
1081 }
1082 else
4608196e 1083 tbuf = NULL;
a0d0e21e
LW		 1084
1085 for (i = 1; i <= 3; i++) {
1086 sv = SP[i];
15547071 1087 if (!SvOK(sv) || SvCUR(sv) == 0) {
a0d0e21e
LW		 1088 fd_sets[i] = 0;
1089 continue;
1090 }
4ef2275c 1091 assert(SvPOK(sv));
a0d0e21e
LW		 1092 j = SvLEN(sv);
1093 if (j < growsize) {
1094 Sv_Grow(sv, growsize);
a0d0e21e 1095 }
c07a80fd 1096 j = SvCUR(sv);
1097 s = SvPVX(sv) + j;
1098 while (++j <= growsize) {
1099 *s++ = '\0';
1100 }
1101
a0d0e21e
LW		 1102#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1103 s = SvPVX(sv);
a02a5408 1104 Newx(fd_sets[i], growsize, char);
a0d0e21e
LW		 1105 for (offset = 0; offset < growsize; offset += masksize) {
1106 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1107 fd_sets[i][j+offset] = s[(k % masksize) + offset];
1108 }
1109#else
1110 fd_sets[i] = SvPVX(sv);
1111#endif
1112 }
1113
dc4c69d9
JH		 1114#ifdef PERL_IRIX5_SELECT_TIMEVAL_VOID_CAST
1115 /* Can't make just the (void*) conditional because that would be
1116 * cpp #if within cpp macro, and not all compilers like that. */
1117 nfound = PerlSock_select(
1118 maxlen * 8,
1119 (Select_fd_set_t) fd_sets[1],
1120 (Select_fd_set_t) fd_sets[2],
1121 (Select_fd_set_t) fd_sets[3],
1122 (void*) tbuf); /* Workaround for compiler bug. */
1123#else
6ad3d225 1124 nfound = PerlSock_select(
a0d0e21e
LW		 1125 maxlen * 8,
1126 (Select_fd_set_t) fd_sets[1],
1127 (Select_fd_set_t) fd_sets[2],
1128 (Select_fd_set_t) fd_sets[3],
1129 tbuf);
dc4c69d9 1130#endif
a0d0e21e
LW		 1131 for (i = 1; i <= 3; i++) {
1132 if (fd_sets[i]) {
1133 sv = SP[i];
1134#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1135 s = SvPVX(sv);
1136 for (offset = 0; offset < growsize; offset += masksize) {
1137 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1138 s[(k % masksize) + offset] = fd_sets[i][j+offset];
1139 }
1140 Safefree(fd_sets[i]);
1141#endif
1142 SvSETMAGIC(sv);
1143 }
1144 }
1145
4189264e 1146 PUSHi(nfound);
a0d0e21e 1147 if (GIMME == G_ARRAY && tbuf) {
65202027
DS		 1148 value = (NV)(timebuf.tv_sec) +
1149 (NV)(timebuf.tv_usec) / 1000000.0;
7c58897d 1150 PUSHs(sv_2mortal(newSVnv(value)));
a0d0e21e
LW		 1151 }
1152 RETURN;
1153#else
cea2e8a9 1154 DIE(aTHX_ "select not implemented");
a0d0e21e
LW		 1155#endif
1156}
1157
4633a7c4 1158void
864dbfa3 1159Perl_setdefout(pTHX_ GV *gv)
4633a7c4 1160{
97aff369 1161 dVAR;
b37c2d43 1162 SvREFCNT_inc_simple_void(gv);
3280af22
NIS		 1163 if (PL_defoutgv)
1164 SvREFCNT_dec(PL_defoutgv);
1165 PL_defoutgv = gv;
4633a7c4
LW		 1166}
1167
a0d0e21e
LW		 1168PP(pp_select)
1169{
97aff369 1170 dVAR; dSP; dTARGET;
4633a7c4 1171 HV *hv;
a79db61d 1172 GV * const newdefout = (PL_op->op_private > 0) ? ((GV *) POPs) : NULL;
7452cf6a 1173 GV * egv = GvEGV(PL_defoutgv);
4633a7c4 1174
4633a7c4 1175 if (!egv)
3280af22 1176 egv = PL_defoutgv;
4633a7c4
LW		 1177 hv = GvSTASH(egv);
1178 if (! hv)
3280af22 1179 XPUSHs(&PL_sv_undef);
4633a7c4 1180 else {
c4420975 1181 GV * const * const gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
f86702cc 1182 if (gvp && *gvp == egv) {
bd61b366 1183 gv_efullname4(TARG, PL_defoutgv, NULL, TRUE);
f86702cc 1184 XPUSHTARG;
1185 }
1186 else {
1187 XPUSHs(sv_2mortal(newRV((SV*)egv)));
1188 }
4633a7c4
LW		 1189 }
1190
1191 if (newdefout) {
ded8aa31
GS		 1192 if (!GvIO(newdefout))
1193 gv_IOadd(newdefout);
4633a7c4
LW		 1194 setdefout(newdefout);
1195 }
1196
a0d0e21e
LW		 1197 RETURN;
1198}
1199
1200PP(pp_getc)
1201{
27da23d5 1202 dVAR; dSP; dTARGET;
90133b69 1203 IO *io = NULL;
1b6737cc 1204 GV * const gv = (MAXARG==0) ? PL_stdingv : (GV*)POPs;
2ae324a7 1205
a79db61d
AL		 1206 if (gv && (io = GvIO(gv))) {
1207 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1208 if (mg) {
1209 const I32 gimme = GIMME_V;
1210 PUSHMARK(SP);
1211 XPUSHs(SvTIED_obj((SV*)io, mg));
1212 PUTBACK;
1213 ENTER;
1214 call_method("GETC", gimme);
1215 LEAVE;
1216 SPAGAIN;
1217 if (gimme == G_SCALAR)
1218 SvSetMagicSV_nosteal(TARG, TOPs);
1219 RETURN;
1220 }
2ae324a7 1221 }
90133b69 1222 if (!gv || do_eof(gv)) { /* make sure we have fp with something */
041457d9
DM		 1223 if ((!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY))
1224 && ckWARN2(WARN_UNOPENED,WARN_CLOSED))
90133b69 1225 report_evil_fh(gv, io, PL_op->op_type);
b5fe5ca2 1226 SETERRNO(EBADF,RMS_IFI);
a0d0e21e 1227 RETPUSHUNDEF;
90133b69 1228 }
bbce6d69 1229 TAINT;
c69006e4 1230 sv_setpvn(TARG, " ", 1);
9bc64814 1231 *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
7d59b7e4
NIS		 1232 if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) {
1233 /* Find out how many bytes the char needs */
aa07b2f6 1234 Size_t len = UTF8SKIP(SvPVX_const(TARG));
7d59b7e4
NIS		 1235 if (len > 1) {
1236 SvGROW(TARG,len+1);
1237 len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1);
1238 SvCUR_set(TARG,1+len);
1239 }
1240 SvUTF8_on(TARG);
1241 }
a0d0e21e
LW		 1242 PUSHTARG;
1243 RETURN;
1244}
1245
76e3520e 1246STATIC OP *
cea2e8a9 1247S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
a0d0e21e 1248{
27da23d5 1249 dVAR;
c09156bb 1250 register PERL_CONTEXT *cx;
f54cb97a 1251 const I32 gimme = GIMME_V;
a0d0e21e
LW		 1252
1253 ENTER;
1254 SAVETMPS;
1255
146174a9 1256 PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
a0d0e21e 1257 PUSHFORMAT(cx);
f39bc417 1258 cx->blk_sub.retop = retop;
fd617465
DM		 1259 SAVECOMPPAD();
1260 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
a0d0e21e 1261
4633a7c4 1262 setdefout(gv); /* locally select filehandle so $% et al work */
a0d0e21e
LW		 1263 return CvSTART(cv);
1264}
1265
1266PP(pp_enterwrite)
1267{
97aff369 1268 dVAR;
39644a26 1269 dSP;
a0d0e21e
LW		 1270 register GV *gv;
1271 register IO *io;
1272 GV *fgv;
1273 CV *cv;
10edeb5d 1274 SV * tmpsv = NULL;
a0d0e21e
LW		 1275
1276 if (MAXARG == 0)
3280af22 1277 gv = PL_defoutgv;
a0d0e21e
LW		 1278 else {
1279 gv = (GV*)POPs;
1280 if (!gv)
3280af22 1281 gv = PL_defoutgv;
a0d0e21e
LW		 1282 }
1283 EXTEND(SP, 1);
1284 io = GvIO(gv);
1285 if (!io) {
1286 RETPUSHNO;
1287 }
1288 if (IoFMT_GV(io))
1289 fgv = IoFMT_GV(io);
1290 else
1291 fgv = gv;
1292
a79db61d
AL		 1293 if (!fgv)
1294 goto not_a_format_reference;
1295
a0d0e21e 1296 cv = GvFORM(fgv);
a0d0e21e 1297 if (!cv) {
f4a7049d 1298 const char *name;
10edeb5d 1299 tmpsv = sv_newmortal();
f4a7049d
NC		 1300 gv_efullname4(tmpsv, fgv, NULL, FALSE);
1301 name = SvPV_nolen_const(tmpsv);
1302 if (name && *name)
1303 DIE(aTHX_ "Undefined format \"%s\" called", name);
a79db61d
AL		 1304
1305 not_a_format_reference:
cea2e8a9 1306 DIE(aTHX_ "Not a format reference");
a0d0e21e 1307 }
44a8e56a 1308 if (CvCLONE(cv))
1309 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
a0d0e21e 1310
44a8e56a 1311 IoFLAGS(io) &= ~IOf_DIDTOP;
533c011a 1312 return doform(cv,gv,PL_op->op_next);
a0d0e21e
LW		 1313}
1314
1315PP(pp_leavewrite)
1316{
27da23d5 1317 dVAR; dSP;
1b6737cc
AL		 1318 GV * const gv = cxstack[cxstack_ix].blk_sub.gv;
1319 register IO * const io = GvIOp(gv);
8b8cacda 1320 PerlIO *ofp;
760ac839 1321 PerlIO *fp;
8772537c
AL		 1322 SV **newsp;
1323 I32 gimme;
c09156bb 1324 register PERL_CONTEXT *cx;
a0d0e21e 1325
8b8cacda
B		 1326 if (!io || !(ofp = IoOFP(io)))
1327 goto forget_top;
1328
760ac839 1329 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
3280af22 1330 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
8b8cacda 1331
3280af22
NIS		 1332 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1333 PL_formtarget != PL_toptarget)
a0d0e21e 1334 {
4633a7c4
LW		 1335 GV *fgv;
1336 CV *cv;
a0d0e21e
LW		 1337 if (!IoTOP_GV(io)) {
1338 GV *topgv;
a0d0e21e
LW		 1339
1340 if (!IoTOP_NAME(io)) {
1b6737cc 1341 SV *topname;
a0d0e21e
LW		 1342 if (!IoFMT_NAME(io))
1343 IoFMT_NAME(io) = savepv(GvNAME(gv));
0bd0581c 1344 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%s_TOP", GvNAME(gv)));
f776e3cd 1345 topgv = gv_fetchsv(topname, 0, SVt_PVFM);
748a9306 1346 if ((topgv && GvFORM(topgv)) ||
fafc274c 1347 !gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM))
2e0de35c 1348 IoTOP_NAME(io) = savesvpv(topname);
a0d0e21e 1349 else
89529cee 1350 IoTOP_NAME(io) = savepvs("top");
a0d0e21e 1351 }
f776e3cd 1352 topgv = gv_fetchpv(IoTOP_NAME(io), 0, SVt_PVFM);
a0d0e21e 1353 if (!topgv || !GvFORM(topgv)) {
b929a54b 1354 IoLINES_LEFT(io) = IoPAGE_LEN(io);
a0d0e21e
LW		 1355 goto forget_top;
1356 }
1357 IoTOP_GV(io) = topgv;
1358 }
748a9306
LW		 1359 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1360 I32 lines = IoLINES_LEFT(io);
504618e9 1361 const char *s = SvPVX_const(PL_formtarget);
8e07c86e
AD		 1362 if (lines <= 0) /* Yow, header didn't even fit!!! */
1363 goto forget_top;
748a9306
LW		 1364 while (lines-- > 0) {
1365 s = strchr(s, '\n');
1366 if (!s)
1367 break;
1368 s++;
1369 }
1370 if (s) {
f54cb97a 1371 const STRLEN save = SvCUR(PL_formtarget);
aa07b2f6 1372 SvCUR_set(PL_formtarget, s - SvPVX_const(PL_formtarget));
d75029d0
NIS		 1373 do_print(PL_formtarget, ofp);
1374 SvCUR_set(PL_formtarget, save);
3280af22
NIS		 1375 sv_chop(PL_formtarget, s);
1376 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
748a9306
LW		 1377 }
1378 }
a0d0e21e 1379 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
d75029d0 1380 do_print(PL_formfeed, ofp);
a0d0e21e
LW		 1381 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1382 IoPAGE(io)++;
3280af22 1383 PL_formtarget = PL_toptarget;
748a9306 1384 IoFLAGS(io) |= IOf_DIDTOP;
4633a7c4
LW		 1385 fgv = IoTOP_GV(io);
1386 if (!fgv)
cea2e8a9 1387 DIE(aTHX_ "bad top format reference");
4633a7c4 1388 cv = GvFORM(fgv);
1df70142
AL		 1389 if (!cv) {
1390 SV * const sv = sv_newmortal();
b464bac0 1391 const char *name;
bd61b366 1392 gv_efullname4(sv, fgv, NULL, FALSE);
e62f0680 1393 name = SvPV_nolen_const(sv);
2dd78f96 1394 if (name && *name)
0e528f24
JH		 1395 DIE(aTHX_ "Undefined top format \"%s\" called", name);
1396 else
1397 DIE(aTHX_ "Undefined top format called");
4633a7c4 1398 }
0e528f24 1399 if (cv && CvCLONE(cv))
44a8e56a 1400 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
0e528f24 1401 return doform(cv, gv, PL_op);
a0d0e21e
LW		 1402 }
1403
1404 forget_top:
3280af22 1405 POPBLOCK(cx,PL_curpm);
a0d0e21e
LW		 1406 POPFORMAT(cx);
1407 LEAVE;
1408
1409 fp = IoOFP(io);
1410 if (!fp) {
599cee73 1411 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
6e6ef6b2
NC		 1412 if (IoIFP(io))
1413 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
599cee73 1414 else if (ckWARN(WARN_CLOSED))
bc37a18f 1415 report_evil_fh(gv, io, PL_op->op_type);
a0d0e21e 1416 }
3280af22 1417 PUSHs(&PL_sv_no);
a0d0e21e
LW		 1418 }
1419 else {
3280af22 1420 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
599cee73 1421 if (ckWARN(WARN_IO))
9014280d 1422 Perl_warner(aTHX_ packWARN(WARN_IO), "page overflow");
a0d0e21e 1423 }
d75029d0 1424 if (!do_print(PL_formtarget, fp))
3280af22 1425 PUSHs(&PL_sv_no);
a0d0e21e 1426 else {
3280af22
NIS		 1427 FmLINES(PL_formtarget) = 0;
1428 SvCUR_set(PL_formtarget, 0);
1429 *SvEND(PL_formtarget) = '\0';
a0d0e21e 1430 if (IoFLAGS(io) & IOf_FLUSH)
760ac839 1431 (void)PerlIO_flush(fp);
3280af22 1432 PUSHs(&PL_sv_yes);
a0d0e21e
LW		 1433 }
1434 }
9cbac4c7 1435 /* bad_ofp: */
3280af22 1436 PL_formtarget = PL_bodytarget;
a0d0e21e 1437 PUTBACK;
29033a8a
SH		 1438 PERL_UNUSED_VAR(newsp);
1439 PERL_UNUSED_VAR(gimme);
f39bc417 1440 return cx->blk_sub.retop;
a0d0e21e
LW		 1441}
1442
1443PP(pp_prtf)
1444{
27da23d5 1445 dVAR; dSP; dMARK; dORIGMARK;
a0d0e21e 1446 IO *io;
760ac839 1447 PerlIO *fp;
26db47c4 1448 SV *sv;
a0d0e21e 1449
c4420975 1450 GV * const gv = (PL_op->op_flags & OPf_STACKED) ? (GV*)*++MARK : PL_defoutgv;
46fc3d4c 1451
a79db61d
AL		 1452 if (gv && (io = GvIO(gv))) {
1453 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1454 if (mg) {
1455 if (MARK == ORIGMARK) {
1456 MEXTEND(SP, 1);
1457 ++MARK;
1458 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1459 ++SP;
1460 }
1461 PUSHMARK(MARK - 1);
1462 *MARK = SvTIED_obj((SV*)io, mg);
1463 PUTBACK;
1464 ENTER;
1465 call_method("PRINTF", G_SCALAR);
1466 LEAVE;
1467 SPAGAIN;
1468 MARK = ORIGMARK + 1;
1469 *MARK = *SP;
1470 SP = MARK;
1471 RETURN;
1472 }
46fc3d4c 1473 }
1474
561b68a9 1475 sv = newSV(0);
a0d0e21e 1476 if (!(io = GvIO(gv))) {
2dd78f96
JH		 1477 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1478 report_evil_fh(gv, io, PL_op->op_type);
93189314 1479 SETERRNO(EBADF,RMS_IFI);
a0d0e21e
LW		 1480 goto just_say_no;
1481 }
1482 else if (!(fp = IoOFP(io))) {
599cee73 1483 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
6e6ef6b2
NC		 1484 if (IoIFP(io))
1485 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
599cee73 1486 else if (ckWARN(WARN_CLOSED))
bc37a18f 1487 report_evil_fh(gv, io, PL_op->op_type);
a0d0e21e 1488 }
93189314 1489 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
a0d0e21e
LW		 1490 goto just_say_no;
1491 }
1492 else {
20ee07fb
RGS		 1493 if (SvTAINTED(MARK[1]))
1494 TAINT_PROPER("printf");
a0d0e21e
LW		 1495 do_sprintf(sv, SP - MARK, MARK + 1);
1496 if (!do_print(sv, fp))
1497 goto just_say_no;
1498
1499 if (IoFLAGS(io) & IOf_FLUSH)
760ac839 1500 if (PerlIO_flush(fp) == EOF)
a0d0e21e
LW		 1501 goto just_say_no;
1502 }
1503 SvREFCNT_dec(sv);
1504 SP = ORIGMARK;
3280af22 1505 PUSHs(&PL_sv_yes);
a0d0e21e
LW		 1506 RETURN;
1507
1508 just_say_no:
1509 SvREFCNT_dec(sv);
1510 SP = ORIGMARK;
3280af22 1511 PUSHs(&PL_sv_undef);
a0d0e21e
LW		 1512 RETURN;
1513}
1514
c07a80fd 1515PP(pp_sysopen)
1516{
97aff369 1517 dVAR;
39644a26 1518 dSP;
1df70142
AL		 1519 const int perm = (MAXARG > 3) ? POPi : 0666;
1520 const int mode = POPi;
1b6737cc
AL		 1521 SV * const sv = POPs;
1522 GV * const gv = (GV *)POPs;
1523 STRLEN len;
c07a80fd 1524
4592e6ca 1525 /* Need TIEHANDLE method ? */
1b6737cc 1526 const char * const tmps = SvPV_const(sv, len);
e62f0680 1527 /* FIXME? do_open should do const */
4608196e 1528 if (do_open(gv, tmps, len, TRUE, mode, perm, NULL)) {
c07a80fd 1529 IoLINES(GvIOp(gv)) = 0;
3280af22 1530 PUSHs(&PL_sv_yes);
c07a80fd 1531 }
1532 else {
3280af22 1533 PUSHs(&PL_sv_undef);
c07a80fd 1534 }
1535 RETURN;
1536}
1537
a0d0e21e
LW		 1538PP(pp_sysread)
1539{
27da23d5 1540 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e 1541 int offset;
a0d0e21e
LW		 1542 IO *io;
1543 char *buffer;
5b54f415 1544 SSize_t length;
eb5c063a 1545 SSize_t count;
1e422769 1546 Sock_size_t bufsize;
748a9306 1547 SV *bufsv;
a0d0e21e 1548 STRLEN blen;
eb5c063a 1549 int fp_utf8;
1dd30107
NC		 1550 int buffer_utf8;
1551 SV *read_target;
eb5c063a
NIS		 1552 Size_t got = 0;
1553 Size_t wanted;
1d636c13 1554 bool charstart = FALSE;
87330c3c
JH		 1555 STRLEN charskip = 0;
1556 STRLEN skip = 0;
a0d0e21e 1557
1b6737cc 1558 GV * const gv = (GV*)*++MARK;
5b468f54 1559 if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
1b6737cc 1560 && gv && (io = GvIO(gv)) )
137443ea 1561 {
1b6737cc
AL		 1562 const MAGIC * mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1563 if (mg) {
1564 SV *sv;
1565 PUSHMARK(MARK-1);
1566 *MARK = SvTIED_obj((SV*)io, mg);
1567 ENTER;
1568 call_method("READ", G_SCALAR);
1569 LEAVE;
1570 SPAGAIN;
1571 sv = POPs;
1572 SP = ORIGMARK;
1573 PUSHs(sv);
1574 RETURN;
1575 }
2ae324a7 1576 }
1577
a0d0e21e
LW		 1578 if (!gv)
1579 goto say_undef;
748a9306 1580 bufsv = *++MARK;
ff68c719 1581 if (! SvOK(bufsv))
1582 sv_setpvn(bufsv, "", 0);
a0d0e21e 1583 length = SvIVx(*++MARK);
748a9306 1584 SETERRNO(0,0);
a0d0e21e
LW		 1585 if (MARK < SP)
1586 offset = SvIVx(*++MARK);
1587 else
1588 offset = 0;
1589 io = GvIO(gv);
b5fe5ca2
SR		 1590 if (!io || !IoIFP(io)) {
1591 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1592 report_evil_fh(gv, io, PL_op->op_type);
1593 SETERRNO(EBADF,RMS_IFI);
a0d0e21e 1594 goto say_undef;
b5fe5ca2 1595 }
0064a8a9 1596 if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
7d59b7e4 1597 buffer = SvPVutf8_force(bufsv, blen);
1e54db1a 1598 /* UTF-8 may not have been set if they are all low bytes */
eb5c063a 1599 SvUTF8_on(bufsv);
9b9d7ce8 1600 buffer_utf8 = 0;
7d59b7e4
NIS		 1601 }
1602 else {
1603 buffer = SvPV_force(bufsv, blen);
1dd30107 1604 buffer_utf8 = !IN_BYTES && SvUTF8(bufsv);
7d59b7e4
NIS		 1605 }
1606 if (length < 0)
1607 DIE(aTHX_ "Negative length");
eb5c063a 1608 wanted = length;
7d59b7e4 1609
d0965105
JH		 1610 charstart = TRUE;
1611 charskip = 0;
87330c3c 1612 skip = 0;
d0965105 1613
a0d0e21e 1614#ifdef HAS_SOCKET
533c011a 1615 if (PL_op->op_type == OP_RECV) {
46fc3d4c 1616 char namebuf[MAXPATHLEN];
17a8c7ba 1617#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
490ab354
JH		 1618 bufsize = sizeof (struct sockaddr_in);
1619#else
46fc3d4c 1620 bufsize = sizeof namebuf;
490ab354 1621#endif
abf95952
IZ		 1622#ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1623 if (bufsize >= 256)
1624 bufsize = 255;
1625#endif
eb160463 1626 buffer = SvGROW(bufsv, (STRLEN)(length+1));
bbce6d69 1627 /* 'offset' means 'flags' here */
eb5c063a 1628 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
10edeb5d 1629 (struct sockaddr *)namebuf, &bufsize);
eb5c063a 1630 if (count < 0)
a0d0e21e 1631 RETPUSHUNDEF;
4107cc59
OF		 1632#ifdef EPOC
1633 /* Bogus return without padding */
1634 bufsize = sizeof (struct sockaddr_in);
1635#endif
eb5c063a 1636 SvCUR_set(bufsv, count);
748a9306
LW		 1637 *SvEND(bufsv) = '\0';
1638 (void)SvPOK_only(bufsv);
eb5c063a
NIS		 1639 if (fp_utf8)
1640 SvUTF8_on(bufsv);
748a9306 1641 SvSETMAGIC(bufsv);
aac0dd9a 1642 /* This should not be marked tainted if the fp is marked clean */
bbce6d69 1643 if (!(IoFLAGS(io) & IOf_UNTAINT))
1644 SvTAINTED_on(bufsv);
a0d0e21e 1645 SP = ORIGMARK;
46fc3d4c 1646 sv_setpvn(TARG, namebuf, bufsize);
a0d0e21e
LW		 1647 PUSHs(TARG);
1648 RETURN;
1649 }
1650#else
911d147d 1651 if (PL_op->op_type == OP_RECV)
cea2e8a9 1652 DIE(aTHX_ PL_no_sock_func, "recv");
a0d0e21e 1653#endif
eb5c063a
NIS		 1654 if (DO_UTF8(bufsv)) {
1655 /* offset adjust in characters not bytes */
1656 blen = sv_len_utf8(bufsv);
7d59b7e4 1657 }
bbce6d69 1658 if (offset < 0) {
eb160463 1659 if (-offset > (int)blen)
cea2e8a9 1660 DIE(aTHX_ "Offset outside string");
bbce6d69 1661 offset += blen;
1662 }
eb5c063a
NIS		 1663 if (DO_UTF8(bufsv)) {
1664 /* convert offset-as-chars to offset-as-bytes */
6960c29a
CH		 1665 if (offset >= (int)blen)
1666 offset += SvCUR(bufsv) - blen;
1667 else
1668 offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
eb5c063a
NIS		 1669 }
1670 more_bytes:
cd52b7b2 1671 bufsize = SvCUR(bufsv);
1dd30107
NC		 1672 /* Allocating length + offset + 1 isn't perfect in the case of reading
1673 bytes from a byte file handle into a UTF8 buffer, but it won't harm us
1674 unduly.
1675 (should be 2 * length + offset + 1, or possibly something longer if
1676 PL_encoding is true) */
eb160463 1677 buffer = SvGROW(bufsv, (STRLEN)(length+offset+1));
27da23d5 1678 if (offset > 0 && (Sock_size_t)offset > bufsize) { /* Zero any newly allocated space */
cd52b7b2 1679 Zero(buffer+bufsize, offset-bufsize, char);
1680 }
eb5c063a 1681 buffer = buffer + offset;
1dd30107
NC		 1682 if (!buffer_utf8) {
1683 read_target = bufsv;
1684 } else {
1685 /* Best to read the bytes into a new SV, upgrade that to UTF8, then
1686 concatenate it to the current buffer. */
1687
1688 /* Truncate the existing buffer to the start of where we will be
1689 reading to: */
1690 SvCUR_set(bufsv, offset);
1691
1692 read_target = sv_newmortal();
862a34c6 1693 SvUPGRADE(read_target, SVt_PV);
fe2774ed 1694 buffer = SvGROW(read_target, (STRLEN)(length + 1));
1dd30107 1695 }
eb5c063a 1696
533c011a 1697 if (PL_op->op_type == OP_SYSREAD) {
a7092146 1698#ifdef PERL_SOCK_SYSREAD_IS_RECV
50952442 1699 if (IoTYPE(io) == IoTYPE_SOCKET) {
eb5c063a
NIS		 1700 count = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
1701 buffer, length, 0);
a7092146
GS		 1702 }
1703 else
1704#endif
1705 {
eb5c063a
NIS		 1706 count = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
1707 buffer, length);
a7092146 1708 }
a0d0e21e
LW		 1709 }
1710 else
1711#ifdef HAS_SOCKET__bad_code_maybe
50952442 1712 if (IoTYPE(io) == IoTYPE_SOCKET) {
46fc3d4c 1713 char namebuf[MAXPATHLEN];
490ab354
JH		 1714#if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
1715 bufsize = sizeof (struct sockaddr_in);
1716#else
46fc3d4c 1717 bufsize = sizeof namebuf;
490ab354 1718#endif
eb5c063a 1719 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, 0,
46fc3d4c 1720 (struct sockaddr *)namebuf, &bufsize);
a0d0e21e
LW		 1721 }
1722 else
1723#endif
3b02c43c 1724 {
eb5c063a
NIS		 1725 count = PerlIO_read(IoIFP(io), buffer, length);
1726 /* PerlIO_read() - like fread() returns 0 on both error and EOF */
1727 if (count == 0 && PerlIO_error(IoIFP(io)))
1728 count = -1;
3b02c43c 1729 }
eb5c063a 1730 if (count < 0) {
a00b5bd3 1731 if ((IoTYPE(io) == IoTYPE_WRONLY) && ckWARN(WARN_IO))
6e6ef6b2 1732 report_evil_fh(gv, io, OP_phoney_OUTPUT_ONLY);
a0d0e21e 1733 goto say_undef;
af8c498a 1734 }
aa07b2f6 1735 SvCUR_set(read_target, count+(buffer - SvPVX_const(read_target)));
1dd30107
NC		 1736 *SvEND(read_target) = '\0';
1737 (void)SvPOK_only(read_target);
0064a8a9 1738 if (fp_utf8 && !IN_BYTES) {
eb5c063a 1739 /* Look at utf8 we got back and count the characters */
1df70142 1740 const char *bend = buffer + count;
eb5c063a 1741 while (buffer < bend) {
d0965105
JH		 1742 if (charstart) {
1743 skip = UTF8SKIP(buffer);
1744 charskip = 0;
1745 }
1746 if (buffer - charskip + skip > bend) {
eb5c063a
NIS		 1747 /* partial character - try for rest of it */
1748 length = skip - (bend-buffer);
aa07b2f6 1749 offset = bend - SvPVX_const(bufsv);
d0965105
JH		 1750 charstart = FALSE;
1751 charskip += count;
eb5c063a
NIS		 1752 goto more_bytes;
1753 }
1754 else {
1755 got++;
1756 buffer += skip;
d0965105
JH		 1757 charstart = TRUE;
1758 charskip = 0;
eb5c063a
NIS		 1759 }
1760 }
1761 /* If we have not 'got' the number of _characters_ we 'wanted' get some more
1762 provided amount read (count) was what was requested (length)
1763 */
1764 if (got < wanted && count == length) {
d0965105 1765 length = wanted - got;
aa07b2f6 1766 offset = bend - SvPVX_const(bufsv);
eb5c063a
NIS		 1767 goto more_bytes;
1768 }
1769 /* return value is character count */
1770 count = got;
1771 SvUTF8_on(bufsv);
1772 }
1dd30107
NC		 1773 else if (buffer_utf8) {
1774 /* Let svcatsv upgrade the bytes we read in to utf8.
1775 The buffer is a mortal so will be freed soon. */
1776 sv_catsv_nomg(bufsv, read_target);
1777 }
748a9306 1778 SvSETMAGIC(bufsv);
aac0dd9a 1779 /* This should not be marked tainted if the fp is marked clean */
bbce6d69 1780 if (!(IoFLAGS(io) & IOf_UNTAINT))
1781 SvTAINTED_on(bufsv);
a0d0e21e 1782 SP = ORIGMARK;
eb5c063a 1783 PUSHi(count);
a0d0e21e
LW		 1784 RETURN;
1785
1786 say_undef:
1787 SP = ORIGMARK;
1788 RETPUSHUNDEF;
1789}
1790
a0d0e21e
LW		 1791PP(pp_send)
1792{
27da23d5 1793 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e 1794 IO *io;
748a9306 1795 SV *bufsv;
83003860 1796 const char *buffer;
8c99d73e 1797 SSize_t retval;
a0d0e21e 1798 STRLEN blen;
c9cb0f41 1799 STRLEN orig_blen_bytes;
64a1bc8e 1800 const int op_type = PL_op->op_type;
c9cb0f41
NC		 1801 bool doing_utf8;
1802 U8 *tmpbuf = NULL;
64a1bc8e 1803
7452cf6a 1804 GV *const gv = (GV*)*++MARK;
14befaf4 1805 if (PL_op->op_type == OP_SYSWRITE
a79db61d
AL		 1806 && gv && (io = GvIO(gv))) {
1807 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1808 if (mg) {
1809 SV *sv;
64a1bc8e 1810
a79db61d
AL		 1811 if (MARK == SP - 1) {
1812 EXTEND(SP, 1000);
1813 sv = sv_2mortal(newSViv(sv_len(*SP)));
1814 PUSHs(sv);
1815 PUTBACK;
1816 }
1817
1818 PUSHMARK(ORIGMARK);
1819 *(ORIGMARK+1) = SvTIED_obj((SV*)io, mg);
1820 ENTER;
1821 call_method("WRITE", G_SCALAR);
1822 LEAVE;
1823 SPAGAIN;
1824 sv = POPs;
1825 SP = ORIGMARK;
64a1bc8e 1826 PUSHs(sv);
a79db61d 1827 RETURN;
64a1bc8e 1828 }
1d603a67 1829 }
a0d0e21e
LW		 1830 if (!gv)
1831 goto say_undef;
64a1bc8e 1832
748a9306 1833 bufsv = *++MARK;
64a1bc8e 1834
748a9306 1835 SETERRNO(0,0);
a0d0e21e 1836 io = GvIO(gv);
cf167416 1837 if (!io || !IoIFP(io) || IoTYPE(io) == IoTYPE_RDONLY) {
8c99d73e 1838 retval = -1;
cf167416
RGS		 1839 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
1840 if (io && IoIFP(io))
1841 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1842 else
1843 report_evil_fh(gv, io, PL_op->op_type);
1844 }
b5fe5ca2 1845 SETERRNO(EBADF,RMS_IFI);
7d59b7e4
NIS		 1846 goto say_undef;
1847 }
1848
c9cb0f41
NC		 1849 /* Do this first to trigger any overloading. */
1850 buffer = SvPV_const(bufsv, blen);
1851 orig_blen_bytes = blen;
1852 doing_utf8 = DO_UTF8(bufsv);
1853
7d59b7e4 1854 if (PerlIO_isutf8(IoIFP(io))) {
6aa2f6a7 1855 if (!SvUTF8(bufsv)) {
c9cb0f41
NC		 1856 /* We don't modify the original scalar. */
1857 tmpbuf = bytes_to_utf8((const U8*) buffer, &blen);
1858 buffer = (char *) tmpbuf;
1859 doing_utf8 = TRUE;
1860 }
a0d0e21e 1861 }
c9cb0f41
NC		 1862 else if (doing_utf8) {
1863 STRLEN tmplen = blen;
a79db61d 1864 U8 * const result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8);
c9cb0f41
NC		 1865 if (!doing_utf8) {
1866 tmpbuf = result;
1867 buffer = (char *) tmpbuf;
1868 blen = tmplen;
1869 }
1870 else {
1871 assert((char *)result == buffer);
1872 Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op));
1873 }
7d59b7e4
NIS		 1874 }
1875
64a1bc8e 1876 if (op_type == OP_SYSWRITE) {
c9cb0f41
NC		 1877 Size_t length = 0; /* This length is in characters. */
1878 STRLEN blen_chars;
7d59b7e4 1879 IV offset;
c9cb0f41
NC		 1880
1881 if (doing_utf8) {
1882 if (tmpbuf) {
1883 /* The SV is bytes, and we've had to upgrade it. */
1884 blen_chars = orig_blen_bytes;
1885 } else {
1886 /* The SV really is UTF-8. */
1887 if (SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1888 /* Don't call sv_len_utf8 again because it will call magic
1889 or overloading a second time, and we might get back a
1890 different result. */
9a206dfd 1891 blen_chars = utf8_length((U8*)buffer, (U8*)buffer + blen);
c9cb0f41
NC		 1892 } else {
1893 /* It's safe, and it may well be cached. */
1894 blen_chars = sv_len_utf8(bufsv);
1895 }
1896 }
1897 } else {
1898 blen_chars = blen;
1899 }
1900
1901 if (MARK >= SP) {
1902 length = blen_chars;
1903 } else {
1904#if Size_t_size > IVSIZE
1905 length = (Size_t)SvNVx(*++MARK);
1906#else
1907 length = (Size_t)SvIVx(*++MARK);
1908#endif
4b0c4b6f
NC		 1909 if ((SSize_t)length < 0) {
1910 Safefree(tmpbuf);
c9cb0f41 1911 DIE(aTHX_ "Negative length");
4b0c4b6f 1912 }
7d59b7e4 1913 }
c9cb0f41 1914
bbce6d69 1915 if (MARK < SP) {
a0d0e21e 1916 offset = SvIVx(*++MARK);
bbce6d69 1917 if (offset < 0) {
4b0c4b6f
NC		 1918 if (-offset > (IV)blen_chars) {
1919 Safefree(tmpbuf);
cea2e8a9 1920 DIE(aTHX_ "Offset outside string");
4b0c4b6f 1921 }
c9cb0f41 1922 offset += blen_chars;
4b0c4b6f
NC		 1923 } else if (offset >= (IV)blen_chars && blen_chars > 0) {
1924 Safefree(tmpbuf);
cea2e8a9 1925 DIE(aTHX_ "Offset outside string");
4b0c4b6f 1926 }
bbce6d69 1927 } else
a0d0e21e 1928 offset = 0;
c9cb0f41
NC		 1929 if (length > blen_chars - offset)
1930 length = blen_chars - offset;
1931 if (doing_utf8) {
1932 /* Here we convert length from characters to bytes. */
1933 if (tmpbuf || SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1934 /* Either we had to convert the SV, or the SV is magical, or
1935 the SV has overloading, in which case we can't or mustn't
1936 or mustn't call it again. */
1937
1938 buffer = (const char*)utf8_hop((const U8 *)buffer, offset);
1939 length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
1940 } else {
1941 /* It's a real UTF-8 SV, and it's not going to change under
1942 us. Take advantage of any cache. */
1943 I32 start = offset;
1944 I32 len_I32 = length;
1945
1946 /* Convert the start and end character positions to bytes.
1947 Remember that the second argument to sv_pos_u2b is relative
1948 to the first. */
1949 sv_pos_u2b(bufsv, &start, &len_I32);
1950
1951 buffer += start;
1952 length = len_I32;
1953 }
7d59b7e4
NIS		 1954 }
1955 else {
1956 buffer = buffer+offset;
1957 }
a7092146 1958#ifdef PERL_SOCK_SYSWRITE_IS_SEND
50952442 1959 if (IoTYPE(io) == IoTYPE_SOCKET) {
8c99d73e 1960 retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
7d59b7e4 1961 buffer, length, 0);
a7092146
GS		 1962 }
1963 else
1964#endif
1965 {
94e4c244 1966 /* See the note at doio.c:do_print about filesize limits. --jhi */
8c99d73e 1967 retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
7d59b7e4 1968 buffer, length);
a7092146 1969 }
a0d0e21e
LW		 1970 }
1971#ifdef HAS_SOCKET
64a1bc8e
NC		 1972 else {
1973 const int flags = SvIVx(*++MARK);
1974 if (SP > MARK) {
1975 STRLEN mlen;
1976 char * const sockbuf = SvPVx(*++MARK, mlen);
1977 retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
1978 flags, (struct sockaddr *)sockbuf, mlen);
1979 }
1980 else {
1981 retval
1982 = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, flags);
1983 }
a0d0e21e 1984 }
a0d0e21e
LW		 1985#else
1986 else
cea2e8a9 1987 DIE(aTHX_ PL_no_sock_func, "send");
a0d0e21e 1988#endif
c9cb0f41 1989
8c99d73e 1990 if (retval < 0)
a0d0e21e
LW		 1991 goto say_undef;
1992 SP = ORIGMARK;
c9cb0f41 1993 if (doing_utf8)
f36eea10 1994 retval = utf8_length((U8*)buffer, (U8*)buffer + retval);
4b0c4b6f 1995
a79db61d 1996 Safefree(tmpbuf);
8c99d73e
GS		 1997#if Size_t_size > IVSIZE
1998 PUSHn(retval);
1999#else
2000 PUSHi(retval);
2001#endif
a0d0e21e
LW		 2002 RETURN;
2003
2004 say_undef:
a79db61d 2005 Safefree(tmpbuf);
a0d0e21e
LW		 2006 SP = ORIGMARK;
2007 RETPUSHUNDEF;
2008}
2009
a0d0e21e
LW		 2010PP(pp_eof)
2011{
27da23d5 2012 dVAR; dSP;
a0d0e21e
LW		 2013 GV *gv;
2014
32da55ab 2015 if (MAXARG == 0) {
146174a9
CB		 2016 if (PL_op->op_flags & OPf_SPECIAL) { /* eof() */
2017 IO *io;
ed2c6b9b 2018 gv = PL_last_in_gv = GvEGV(PL_argvgv);
146174a9
CB		 2019 io = GvIO(gv);
2020 if (io && !IoIFP(io)) {
2021 if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) {
2022 IoLINES(io) = 0;
2023 IoFLAGS(io) &= ~IOf_START;
4608196e 2024 do_open(gv, "-", 1, FALSE, O_RDONLY, 0, NULL);
146174a9
CB		 2025 sv_setpvn(GvSV(gv), "-", 1);
2026 SvSETMAGIC(GvSV(gv));
2027 }
2028 else if (!nextargv(gv))
2029 RETPUSHYES;
2030 }
2031 }
2032 else
2033 gv = PL_last_in_gv; /* eof */
2034 }
a0d0e21e 2035 else
146174a9 2036 gv = PL_last_in_gv = (GV*)POPs; /* eof(FH) */
4592e6ca 2037
6136c704
AL		 2038 if (gv) {
2039 IO * const io = GvIO(gv);
2040 MAGIC * mg;
2041 if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
2042 PUSHMARK(SP);
2043 XPUSHs(SvTIED_obj((SV*)io, mg));
2044 PUTBACK;
2045 ENTER;
2046 call_method("EOF", G_SCALAR);
2047 LEAVE;
2048 SPAGAIN;
2049 RETURN;
2050 }
4592e6ca
NIS		 2051 }
2052
54310121 2053 PUSHs(boolSV(!gv || do_eof(gv)));
a0d0e21e
LW		 2054 RETURN;
2055}
2056
2057PP(pp_tell)
2058{
27da23d5 2059 dVAR; dSP; dTARGET;
301e8125 2060 GV *gv;
5b468f54 2061 IO *io;
a0d0e21e 2062
c4420975
AL		 2063 if (MAXARG != 0)
2064 PL_last_in_gv = (GV*)POPs;
2065 gv = PL_last_in_gv;
4592e6ca 2066
a79db61d
AL		 2067 if (gv && (io = GvIO(gv))) {
2068 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
2069 if (mg) {
2070 PUSHMARK(SP);
2071 XPUSHs(SvTIED_obj((SV*)io, mg));
2072 PUTBACK;
2073 ENTER;
2074 call_method("TELL", G_SCALAR);
2075 LEAVE;
2076 SPAGAIN;
2077 RETURN;
2078 }
4592e6ca
NIS		 2079 }
2080
146174a9
CB		 2081#if LSEEKSIZE > IVSIZE
2082 PUSHn( do_tell(gv) );
2083#else
a0d0e21e 2084 PUSHi( do_tell(gv) );
146174a9 2085#endif
a0d0e21e
LW		 2086 RETURN;
2087}
2088
137443ea 2089PP(pp_sysseek)
2090{
27da23d5 2091 dVAR; dSP;
1df70142 2092 const int whence = POPi;
146174a9 2093#if LSEEKSIZE > IVSIZE
7452cf6a 2094 const Off_t offset = (Off_t)SvNVx(POPs);
146174a9 2095#else
7452cf6a 2096 const Off_t offset = (Off_t)SvIVx(POPs);
146174a9 2097#endif
a0d0e21e 2098
7452cf6a 2099 GV * const gv = PL_last_in_gv = (GV*)POPs;
a79db61d 2100 IO *io;
4592e6ca 2101
a79db61d
AL		 2102 if (gv && (io = GvIO(gv))) {
2103 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
2104 if (mg) {
2105 PUSHMARK(SP);
2106 XPUSHs(SvTIED_obj((SV*)io, mg));
cb50131a 2107#if LSEEKSIZE > IVSIZE
a79db61d 2108 XPUSHs(sv_2mortal(newSVnv((NV) offset)));
cb50131a 2109#else
a79db61d 2110 XPUSHs(sv_2mortal(newSViv(offset)));
cb50131a 2111#endif
a79db61d
AL		 2112 XPUSHs(sv_2mortal(newSViv(whence)));
2113 PUTBACK;
2114 ENTER;
2115 call_method("SEEK", G_SCALAR);
2116 LEAVE;
2117 SPAGAIN;
2118 RETURN;
2119 }
4592e6ca
NIS		 2120 }
2121
533c011a 2122 if (PL_op->op_type == OP_SEEK)
8903cb82 2123 PUSHs(boolSV(do_seek(gv, offset, whence)));
2124 else {
0bcc34c2 2125 const Off_t sought = do_sysseek(gv, offset, whence);
b448e4fe 2126 if (sought < 0)
146174a9
CB		 2127 PUSHs(&PL_sv_undef);
2128 else {
7452cf6a 2129 SV* const sv = sought ?
146174a9 2130#if LSEEKSIZE > IVSIZE
b448e4fe 2131 newSVnv((NV)sought)
146174a9 2132#else
b448e4fe 2133 newSViv(sought)
146174a9
CB		 2134#endif
2135 : newSVpvn(zero_but_true, ZBTLEN);
2136 PUSHs(sv_2mortal(sv));
2137 }
8903cb82 2138 }
a0d0e21e
LW		 2139 RETURN;
2140}
2141
2142PP(pp_truncate)
2143{
97aff369 2144 dVAR;
39644a26 2145 dSP;
8c99d73e
GS		 2146 /* There seems to be no consensus on the length type of truncate()
2147 * and ftruncate(), both off_t and size_t have supporters. In
2148 * general one would think that when using large files, off_t is
2149 * at least as wide as size_t, so using an off_t should be okay. */
2150 /* XXX Configure probe for the length type of *truncate() needed XXX */
0bcc34c2 2151 Off_t len;
a0d0e21e 2152
25342a55 2153#if Off_t_size > IVSIZE
0bcc34c2 2154 len = (Off_t)POPn;
8c99d73e 2155#else
0bcc34c2 2156 len = (Off_t)POPi;
8c99d73e
GS		 2157#endif
2158 /* Checking for length < 0 is problematic as the type might or
301e8125 2159 * might not be signed: if it is not, clever compilers will moan. */
8c99d73e 2160 /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
748a9306 2161 SETERRNO(0,0);
d05c1ba0 2162 {
d05c1ba0
JH		 2163 int result = 1;
2164 GV *tmpgv;
090bf15b
SR		 2165 IO *io;
2166
d05c1ba0 2167 if (PL_op->op_flags & OPf_SPECIAL) {
f776e3cd 2168 tmpgv = gv_fetchsv(POPs, 0, SVt_PVIO);
d05c1ba0 2169
090bf15b
SR		 2170 do_ftruncate_gv:
2171 if (!GvIO(tmpgv))
2172 result = 0;
d05c1ba0 2173 else {
090bf15b
SR		 2174 PerlIO *fp;
2175 io = GvIOp(tmpgv);
2176 do_ftruncate_io:
2177 TAINT_PROPER("truncate");
2178 if (!(fp = IoIFP(io))) {
2179 result = 0;
2180 }
2181 else {
2182 PerlIO_flush(fp);
cbdc8872 2183#ifdef HAS_TRUNCATE
090bf15b 2184 if (ftruncate(PerlIO_fileno(fp), len) < 0)
301e8125 2185#else
090bf15b 2186 if (my_chsize(PerlIO_fileno(fp), len) < 0)
cbdc8872 2187#endif
090bf15b
SR		 2188 result = 0;
2189 }
d05c1ba0 2190 }
cbdc8872 2191 }
d05c1ba0 2192 else {
7452cf6a 2193 SV * const sv = POPs;
83003860 2194 const char *name;
7a5fd60d 2195
d05c1ba0
JH		 2196 if (SvTYPE(sv) == SVt_PVGV) {
2197 tmpgv = (GV*)sv; /* *main::FRED for example */
090bf15b 2198 goto do_ftruncate_gv;
d05c1ba0
JH		 2199 }
2200 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2201 tmpgv = (GV*) SvRV(sv); /* \*main::FRED for example */
090bf15b
SR		 2202 goto do_ftruncate_gv;
2203 }
2204 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2205 io = (IO*) SvRV(sv); /* *main::FRED{IO} for example */
2206 goto do_ftruncate_io;
d05c1ba0 2207 }
1e422769 2208
83003860 2209 name = SvPV_nolen_const(sv);
d05c1ba0 2210 TAINT_PROPER("truncate");
cbdc8872 2211#ifdef HAS_TRUNCATE
d05c1ba0
JH		 2212 if (truncate(name, len) < 0)
2213 result = 0;
cbdc8872 2214#else
d05c1ba0 2215 {
7452cf6a 2216 const int tmpfd = PerlLIO_open(name, O_RDWR);
d05c1ba0 2217
7452cf6a 2218 if (tmpfd < 0)
cbdc8872 2219 result = 0;
d05c1ba0
JH		 2220 else {
2221 if (my_chsize(tmpfd, len) < 0)
2222 result = 0;
2223 PerlLIO_close(tmpfd);
2224 }
cbdc8872 2225 }
a0d0e21e 2226#endif
d05c1ba0 2227 }
a0d0e21e 2228
d05c1ba0
JH		 2229 if (result)
2230 RETPUSHYES;
2231 if (!errno)
93189314 2232 SETERRNO(EBADF,RMS_IFI);
d05c1ba0
JH		 2233 RETPUSHUNDEF;
2234 }
a0d0e21e
LW		 2235}
2236
a0d0e21e
LW		 2237PP(pp_ioctl)
2238{
97aff369 2239 dVAR; dSP; dTARGET;
7452cf6a 2240 SV * const argsv = POPs;
1df70142 2241 const unsigned int func = POPu;
e1ec3a88 2242 const int optype = PL_op->op_type;
7452cf6a 2243 GV * const gv = (GV*)POPs;
4608196e 2244 IO * const io = gv ? GvIOn(gv) : NULL;
a0d0e21e 2245 char *s;
324aa91a 2246 IV retval;
a0d0e21e 2247
748a9306 2248 if (!io || !argsv || !IoIFP(io)) {
c289d2f7
JH		 2249 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2250 report_evil_fh(gv, io, PL_op->op_type);
93189314 2251 SETERRNO(EBADF,RMS_IFI); /* well, sort of... */
a0d0e21e
LW		 2252 RETPUSHUNDEF;
2253 }
2254
748a9306 2255 if (SvPOK(argsv) || !SvNIOK(argsv)) {
a0d0e21e 2256 STRLEN len;
324aa91a 2257 STRLEN need;
748a9306 2258 s = SvPV_force(argsv, len);
324aa91a
HF		 2259 need = IOCPARM_LEN(func);
2260 if (len < need) {
2261 s = Sv_Grow(argsv, need + 1);
2262 SvCUR_set(argsv, need);
a0d0e21e
LW		 2263 }
2264
748a9306 2265 s[SvCUR(argsv)] = 17; /* a little sanity check here */
a0d0e21e
LW		 2266 }
2267 else {
748a9306 2268 retval = SvIV(argsv);
c529f79d 2269 s = INT2PTR(char*,retval); /* ouch */
a0d0e21e
LW		 2270 }
2271
ed4b2e6b 2272 TAINT_PROPER(PL_op_desc[optype]);
a0d0e21e
LW		 2273
2274 if (optype == OP_IOCTL)
2275#ifdef HAS_IOCTL
76e3520e 2276 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
a0d0e21e 2277#else
cea2e8a9 2278 DIE(aTHX_ "ioctl is not implemented");
a0d0e21e
LW		 2279#endif
2280 else
c214f4ad
WB		 2281#ifndef HAS_FCNTL
2282 DIE(aTHX_ "fcntl is not implemented");
2283#else
55497cff 2284#if defined(OS2) && defined(__EMX__)
760ac839 2285 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
55497cff 2286#else
760ac839 2287 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
301e8125 2288#endif
6652bd42 2289#endif
a0d0e21e 2290
6652bd42 2291#if defined(HAS_IOCTL) || defined(HAS_FCNTL)
748a9306
LW		 2292 if (SvPOK(argsv)) {
2293 if (s[SvCUR(argsv)] != 17)
cea2e8a9 2294 DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
53e06cf0 2295 OP_NAME(PL_op));
748a9306
LW		 2296 s[SvCUR(argsv)] = 0; /* put our null back */
2297 SvSETMAGIC(argsv); /* Assume it has changed */
a0d0e21e
LW		 2298 }
2299
2300 if (retval == -1)
2301 RETPUSHUNDEF;
2302 if (retval != 0) {
2303 PUSHi(retval);
2304 }
2305 else {
8903cb82 2306 PUSHp(zero_but_true, ZBTLEN);
a0d0e21e 2307 }
4808266b 2308#endif
c214f4ad 2309 RETURN;
a0d0e21e
LW		 2310}
2311
2312PP(pp_flock)
2313{
9cad6237 2314#ifdef FLOCK
97aff369 2315 dVAR; dSP; dTARGET;
a0d0e21e 2316 I32 value;
bc37a18f 2317 IO *io = NULL;
760ac839 2318 PerlIO *fp;
7452cf6a
AL		 2319 const int argtype = POPi;
2320 GV * const gv = (MAXARG == 0) ? PL_last_in_gv : (GV*)POPs;
16d20bd9 2321
bc37a18f
RG		 2322 if (gv && (io = GvIO(gv)))
2323 fp = IoIFP(io);
2324 else {
4608196e 2325 fp = NULL;
bc37a18f
RG		 2326 io = NULL;
2327 }
0bcc34c2 2328 /* XXX Looks to me like io is always NULL at this point */
a0d0e21e 2329 if (fp) {
68dc0745 2330 (void)PerlIO_flush(fp);
76e3520e 2331 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
a0d0e21e 2332 }
cb50131a 2333 else {
bc37a18f
RG		 2334 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2335 report_evil_fh(gv, io, PL_op->op_type);
a0d0e21e 2336 value = 0;
93189314 2337 SETERRNO(EBADF,RMS_IFI);
cb50131a 2338 }
a0d0e21e
LW		 2339 PUSHi(value);
2340 RETURN;
2341#else
cea2e8a9 2342 DIE(aTHX_ PL_no_func, "flock()");
a0d0e21e
LW		 2343#endif
2344}
2345
2346/* Sockets. */
2347
2348PP(pp_socket)
2349{
a0d0e21e 2350#ifdef HAS_SOCKET
97aff369 2351 dVAR; dSP;
7452cf6a
AL		 2352 const int protocol = POPi;
2353 const int type = POPi;
2354 const int domain = POPi;
2355 GV * const gv = (GV*)POPs;
2356 register IO * const io = gv ? GvIOn(gv) : NULL;
a0d0e21e
LW		 2357 int fd;
2358
c289d2f7
JH		 2359 if (!gv || !io) {
2360 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2361 report_evil_fh(gv, io, PL_op->op_type);
5ee74a84 2362 if (io && IoIFP(io))
c289d2f7 2363 do_close(gv, FALSE);
93189314 2364 SETERRNO(EBADF,LIB_INVARG);
a0d0e21e
LW		 2365 RETPUSHUNDEF;
2366 }
2367
57171420
BS		 2368 if (IoIFP(io))
2369 do_close(gv, FALSE);
2370
a0d0e21e 2371 TAINT_PROPER("socket");
6ad3d225 2372 fd = PerlSock_socket(domain, type, protocol);
a0d0e21e
LW		 2373 if (fd < 0)
2374 RETPUSHUNDEF;
460c8493
IZ		 2375 IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
2376 IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
50952442 2377 IoTYPE(io) = IoTYPE_SOCKET;
a0d0e21e 2378 if (!IoIFP(io) || !IoOFP(io)) {
760ac839
LW		 2379 if (IoIFP(io)) PerlIO_close(IoIFP(io));
2380 if (IoOFP(io)) PerlIO_close(IoOFP(io));
6ad3d225 2381 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
a0d0e21e
LW		 2382 RETPUSHUNDEF;
2383 }
8d2a6795
GS		 2384#if defined(HAS_FCNTL) && defined(F_SETFD)
2385 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2386#endif
a0d0e21e 2387
d5ff79b3
OF		 2388#ifdef EPOC
2389 setbuf( IoIFP(io), NULL); /* EPOC gets confused about sockets */
2390#endif
2391
a0d0e21e
LW		 2392 RETPUSHYES;
2393#else
cea2e8a9 2394 DIE(aTHX_ PL_no_sock_func, "socket");
a0d0e21e
LW		 2395#endif
2396}
2397
2398PP(pp_sockpair)
2399{
c95c94b1 2400#if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
97aff369 2401 dVAR; dSP;
7452cf6a
AL		 2402 const int protocol = POPi;
2403 const int type = POPi;
2404 const int domain = POPi;
2405 GV * const gv2 = (GV*)POPs;
2406 GV * const gv1 = (GV*)POPs;
2407 register IO * const io1 = gv1 ? GvIOn(gv1) : NULL;
2408 register IO * const io2 = gv2 ? GvIOn(gv2) : NULL;
a0d0e21e
LW		 2409 int fd[2];
2410
c289d2f7
JH		 2411 if (!gv1 || !gv2 || !io1 || !io2) {
2412 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
2413 if (!gv1 || !io1)
2414 report_evil_fh(gv1, io1, PL_op->op_type);
2415 if (!gv2 || !io2)
2416 report_evil_fh(gv1, io2, PL_op->op_type);
2417 }
5ee74a84 2418 if (io1 && IoIFP(io1))
c289d2f7 2419 do_close(gv1, FALSE);
5ee74a84 2420 if (io2 && IoIFP(io2))
c289d2f7 2421 do_close(gv2, FALSE);
a0d0e21e 2422 RETPUSHUNDEF;
c289d2f7 2423 }
a0d0e21e 2424
dc0d0a5f
JH		 2425 if (IoIFP(io1))
2426 do_close(gv1, FALSE);
2427 if (IoIFP(io2))
2428 do_close(gv2, FALSE);
57171420 2429
a0d0e21e 2430 TAINT_PROPER("socketpair");
6ad3d225 2431 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
a0d0e21e 2432 RETPUSHUNDEF;
460c8493
IZ		 2433 IoIFP(io1) = PerlIO_fdopen(fd[0], "r"SOCKET_OPEN_MODE);
2434 IoOFP(io1) = PerlIO_fdopen(fd[0], "w"SOCKET_OPEN_MODE);
50952442 2435 IoTYPE(io1) = IoTYPE_SOCKET;
460c8493
IZ		 2436 IoIFP(io2) = PerlIO_fdopen(fd[1], "r"SOCKET_OPEN_MODE);
2437 IoOFP(io2) = PerlIO_fdopen(fd[1], "w"SOCKET_OPEN_MODE);
50952442 2438 IoTYPE(io2) = IoTYPE_SOCKET;
a0d0e21e 2439 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
760ac839
LW		 2440 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2441 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
6ad3d225 2442 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
760ac839
LW		 2443 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2444 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
6ad3d225 2445 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
a0d0e21e
LW		 2446 RETPUSHUNDEF;
2447 }
8d2a6795
GS		 2448#if defined(HAS_FCNTL) && defined(F_SETFD)
2449 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
2450 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
2451#endif
a0d0e21e
LW		 2452
2453 RETPUSHYES;
2454#else
cea2e8a9 2455 DIE(aTHX_ PL_no_sock_func, "socketpair");
a0d0e21e
LW		 2456#endif
2457}
2458
2459PP(pp_bind)
2460{
a0d0e21e 2461#ifdef HAS_SOCKET
97aff369 2462 dVAR; dSP;
7452cf6a 2463 SV * const addrsv = POPs;
349d4f2f
NC		 2464 /* OK, so on what platform does bind modify addr? */
2465 const char *addr;
7452cf6a
AL		 2466 GV * const gv = (GV*)POPs;
2467 register IO * const io = GvIOn(gv);
a0d0e21e
LW		 2468 STRLEN len;
2469
2470 if (!io || !IoIFP(io))
2471 goto nuts;
2472
349d4f2f 2473 addr = SvPV_const(addrsv, len);
a0d0e21e 2474 TAINT_PROPER("bind");
a79db61d 2475 if (PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
a0d0e21e
LW		 2476 RETPUSHYES;
2477 else
2478 RETPUSHUNDEF;
2479
2480nuts:
599cee73 2481 if (ckWARN(WARN_CLOSED))
bc37a18f 2482 report_evil_fh(gv, io, PL_op->op_type);
93189314 2483 SETERRNO(EBADF,SS_IVCHAN);
a0d0e21e
LW		 2484 RETPUSHUNDEF;
2485#else
cea2e8a9 2486 DIE(aTHX_ PL_no_sock_func, "bind");
a0d0e21e
LW		 2487#endif
2488}
2489
2490PP(pp_connect)
2491{
a0d0e21e 2492#ifdef HAS_SOCKET
97aff369 2493 dVAR; dSP;
7452cf6a
AL		 2494 SV * const addrsv = POPs;
2495 GV * const gv = (GV*)POPs;
2496 register IO * const io = GvIOn(gv);
349d4f2f 2497 const char *addr;
a0d0e21e
LW		 2498 STRLEN len;
2499
2500 if (!io || !IoIFP(io))
2501 goto nuts;
2502
349d4f2f 2503 addr = SvPV_const(addrsv, len);
a0d0e21e 2504 TAINT_PROPER("connect");
6ad3d225 2505 if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
a0d0e21e
LW		 2506 RETPUSHYES;
2507 else
2508 RETPUSHUNDEF;
2509
2510nuts:
599cee73 2511 if (ckWARN(WARN_CLOSED))
bc37a18f 2512 report_evil_fh(gv, io, PL_op->op_type);
93189314 2513 SETERRNO(EBADF,SS_IVCHAN);
a0d0e21e
LW		 2514 RETPUSHUNDEF;
2515#else
cea2e8a9 2516 DIE(aTHX_ PL_no_sock_func, "connect");
a0d0e21e
LW		 2517#endif
2518}
2519
2520PP(pp_listen)
2521{
a0d0e21e 2522#ifdef HAS_SOCKET
97aff369 2523 dVAR; dSP;
7452cf6a
AL		 2524 const int backlog = POPi;
2525 GV * const gv = (GV*)POPs;
2526 register IO * const io = gv ? GvIOn(gv) : NULL;
a0d0e21e 2527
c289d2f7 2528 if (!gv || !io || !IoIFP(io))
a0d0e21e
LW		 2529 goto nuts;
2530
6ad3d225 2531 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
a0d0e21e
LW		 2532 RETPUSHYES;
2533 else
2534 RETPUSHUNDEF;
2535
2536nuts:
599cee73 2537 if (ckWARN(WARN_CLOSED))
bc37a18f 2538 report_evil_fh(gv, io, PL_op->op_type);
93189314 2539 SETERRNO(EBADF,SS_IVCHAN);
a0d0e21e
LW		 2540 RETPUSHUNDEF;
2541#else
cea2e8a9 2542 DIE(aTHX_ PL_no_sock_func, "listen");
a0d0e21e
LW		 2543#endif
2544}
2545
2546PP(pp_accept)
2547{
a0d0e21e 2548#ifdef HAS_SOCKET
97aff369 2549 dVAR; dSP; dTARGET;
a0d0e21e
LW		 2550 register IO *nstio;
2551 register IO *gstio;
93d47a36
JH		 2552 char namebuf[MAXPATHLEN];
2553#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
2554 Sock_size_t len = sizeof (struct sockaddr_in);
2555#else
2556 Sock_size_t len = sizeof namebuf;
2557#endif
7452cf6a
AL		 2558 GV * const ggv = (GV*)POPs;
2559 GV * const ngv = (GV*)POPs;
a0d0e21e
LW		 2560 int fd;
2561
a0d0e21e
LW		 2562 if (!ngv)
2563 goto badexit;
2564 if (!ggv)
2565 goto nuts;
2566
2567 gstio = GvIO(ggv);
2568 if (!gstio || !IoIFP(gstio))
2569 goto nuts;
2570
2571 nstio = GvIOn(ngv);
93d47a36 2572 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
e294cc5d
JH		 2573#if defined(OEMVS)
2574 if (len == 0) {
2575 /* Some platforms indicate zero length when an AF_UNIX client is
2576 * not bound. Simulate a non-zero-length sockaddr structure in
2577 * this case. */
2578 namebuf[0] = 0; /* sun_len */
2579 namebuf[1] = AF_UNIX; /* sun_family */
2580 len = 2;
2581 }
2582#endif
2583
a0d0e21e
LW		 2584 if (fd < 0)
2585 goto badexit;
a70048fb
AB		 2586 if (IoIFP(nstio))
2587 do_close(ngv, FALSE);
460c8493
IZ		 2588 IoIFP(nstio) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);
2589 IoOFP(nstio) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
50952442 2590 IoTYPE(nstio) = IoTYPE_SOCKET;
a0d0e21e 2591 if (!IoIFP(nstio) || !IoOFP(nstio)) {
760ac839
LW		 2592 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2593 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
6ad3d225 2594 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
a0d0e21e
LW		 2595 goto badexit;
2596 }
8d2a6795
GS		 2597#if defined(HAS_FCNTL) && defined(F_SETFD)
2598 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2599#endif
a0d0e21e 2600
ed79a026 2601#ifdef EPOC
93d47a36 2602 len = sizeof (struct sockaddr_in); /* EPOC somehow truncates info */
a9f1f6b0 2603 setbuf( IoIFP(nstio), NULL); /* EPOC gets confused about sockets */
ed79a026 2604#endif
381c1bae 2605#ifdef __SCO_VERSION__
93d47a36 2606 len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
381c1bae 2607#endif
ed79a026 2608
93d47a36 2609 PUSHp(namebuf, len);
a0d0e21e
LW		 2610 RETURN;
2611
2612nuts:
599cee73 2613 if (ckWARN(WARN_CLOSED))
bc37a18f 2614 report_evil_fh(ggv, ggv ? GvIO(ggv) : 0, PL_op->op_type);
93189314 2615 SETERRNO(EBADF,SS_IVCHAN);
a0d0e21e
LW		 2616
2617badexit:
2618 RETPUSHUNDEF;
2619
2620#else
cea2e8a9 2621 DIE(aTHX_ PL_no_sock_func, "accept");
a0d0e21e
LW		 2622#endif
2623}
2624
2625PP(pp_shutdown)
2626{
a0d0e21e 2627#ifdef HAS_SOCKET
97aff369 2628 dVAR; dSP; dTARGET;
7452cf6a
AL		 2629 const int how = POPi;
2630 GV * const gv = (GV*)POPs;
2631 register IO * const io = GvIOn(gv);
a0d0e21e
LW		 2632
2633 if (!io || !IoIFP(io))
2634 goto nuts;
2635
6ad3d225 2636 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
a0d0e21e
LW		 2637 RETURN;
2638
2639nuts:
599cee73 2640 if (ckWARN(WARN_CLOSED))
bc37a18f 2641 report_evil_fh(gv, io, PL_op->op_type);
93189314 2642 SETERRNO(EBADF,SS_IVCHAN);
a0d0e21e
LW		 2643 RETPUSHUNDEF;
2644#else
cea2e8a9 2645 DIE(aTHX_ PL_no_sock_func, "shutdown");
a0d0e21e
LW		 2646#endif
2647}
2648
a0d0e21e
LW		 2649PP(pp_ssockopt)
2650{
a0d0e21e 2651#ifdef HAS_SOCKET
97aff369 2652 dVAR; dSP;
7452cf6a 2653 const int optype = PL_op->op_type;
561b68a9 2654 SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
7452cf6a
AL		 2655 const unsigned int optname = (unsigned int) POPi;
2656 const unsigned int lvl = (unsigned int) POPi;
2657 GV * const gv = (GV*)POPs;
2658 register IO * const io = GvIOn(gv);
a0d0e21e 2659 int fd;
1e422769 2660 Sock_size_t len;
a0d0e21e 2661
a0d0e21e
LW		 2662 if (!io || !IoIFP(io))
2663 goto nuts;
2664
760ac839 2665 fd = PerlIO_fileno(IoIFP(io));
a0d0e21e
LW		 2666 switch (optype) {
2667 case OP_GSOCKOPT:
748a9306 2668 SvGROW(sv, 257);
a0d0e21e 2669 (void)SvPOK_only(sv);
748a9306
LW		 2670 SvCUR_set(sv,256);
2671 *SvEND(sv) ='\0';
1e422769 2672 len = SvCUR(sv);
6ad3d225 2673 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
a0d0e21e 2674 goto nuts2;
1e422769 2675 SvCUR_set(sv, len);
748a9306 2676 *SvEND(sv) ='\0';
a0d0e21e
LW		 2677 PUSHs(sv);
2678 break;
2679 case OP_SSOCKOPT: {
1215b447
JH		 2680#if defined(__SYMBIAN32__)
2681# define SETSOCKOPT_OPTION_VALUE_T void *
2682#else
2683# define SETSOCKOPT_OPTION_VALUE_T const char *
2684#endif
2685 /* XXX TODO: We need to have a proper type (a Configure probe,
2686 * etc.) for what the C headers think of the third argument of
2687 * setsockopt(), the option_value read-only buffer: is it
2688 * a "char *", or a "void *", const or not. Some compilers
2689 * don't take kindly to e.g. assuming that "char *" implicitly
2690 * promotes to a "void *", or to explicitly promoting/demoting
2691 * consts to non/vice versa. The "const void *" is the SUS
2692 * definition, but that does not fly everywhere for the above
2693 * reasons. */
2694 SETSOCKOPT_OPTION_VALUE_T buf;
1e422769 2695 int aint;
2696 if (SvPOKp(sv)) {
2d8e6c8d 2697 STRLEN l;
1215b447 2698 buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l);
2d8e6c8d 2699 len = l;
1e422769 2700 }
56ee1660 2701 else {
a0d0e21e 2702 aint = (int)SvIV(sv);
1215b447 2703 buf = (SETSOCKOPT_OPTION_VALUE_T) &aint;
a0d0e21e
LW		 2704 len = sizeof(int);
2705 }
6ad3d225 2706 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
a0d0e21e 2707 goto nuts2;
3280af22 2708 PUSHs(&PL_sv_yes);
a0d0e21e
LW		 2709 }
2710 break;
2711 }
2712 RETURN;
2713
2714nuts:
599cee73 2715 if (ckWARN(WARN_CLOSED))
bc37a18f 2716 report_evil_fh(gv, io, optype);
93189314 2717 SETERRNO(EBADF,SS_IVCHAN);
a0d0e21e
LW		 2718nuts2:
2719 RETPUSHUNDEF;
2720
2721#else
af51a00e 2722 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
a0d0e21e
LW		 2723#endif
2724}
2725
a0d0e21e
LW		 2726PP(pp_getpeername)
2727{
a0d0e21e 2728#ifdef HAS_SOCKET
97aff369 2729 dVAR; dSP;
7452cf6a
AL		 2730 const int optype = PL_op->op_type;
2731 GV * const gv = (GV*)POPs;
2732 register IO * const io = GvIOn(gv);
2733 Sock_size_t len;
a0d0e21e
LW		 2734 SV *sv;
2735 int fd;
a0d0e21e
LW		 2736
2737 if (!io || !IoIFP(io))
2738 goto nuts;
2739
561b68a9 2740 sv = sv_2mortal(newSV(257));
748a9306 2741 (void)SvPOK_only(sv);
1e422769 2742 len = 256;
2743 SvCUR_set(sv, len);
748a9306 2744 *SvEND(sv) ='\0';
760ac839 2745 fd = PerlIO_fileno(IoIFP(io));
a0d0e21e
LW		 2746 switch (optype) {
2747 case OP_GETSOCKNAME:
6ad3d225 2748 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
a0d0e21e
LW		 2749 goto nuts2;
2750 break;
2751 case OP_GETPEERNAME:
6ad3d225 2752 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
a0d0e21e 2753 goto nuts2;
490ab354
JH		 2754#if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2755 {
2756 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";
2757 /* If the call succeeded, make sure we don't have a zeroed port/addr */
349d4f2f 2758 if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2fbb330f 2759 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
490ab354 2760 sizeof(u_short) + sizeof(struct in_addr))) {
301e8125 2761 goto nuts2;
490ab354
JH		 2762 }
2763 }
2764#endif
a0d0e21e
LW		 2765 break;
2766 }
13826f2c
CS		 2767#ifdef BOGUS_GETNAME_RETURN
2768 /* Interactive Unix, getpeername() and getsockname()
2769 does not return valid namelen */
1e422769 2770 if (len == BOGUS_GETNAME_RETURN)
2771 len = sizeof(struct sockaddr);
13826f2c 2772#endif
1e422769 2773 SvCUR_set(sv, len);
748a9306 2774 *SvEND(sv) ='\0';
a0d0e21e
LW		 2775 PUSHs(sv);
2776 RETURN;
2777
2778nuts:
599cee73 2779 if (ckWARN(WARN_CLOSED))
bc37a18f 2780 report_evil_fh(gv, io, optype);
93189314 2781 SETERRNO(EBADF,SS_IVCHAN);
a0d0e21e
LW		 2782nuts2:
2783 RETPUSHUNDEF;
2784
2785#else
af51a00e 2786 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
a0d0e21e
LW		 2787#endif
2788}
2789
2790/* Stat calls. */
2791
a0d0e21e
LW		 2792PP(pp_stat)
2793{
97aff369 2794 dVAR;
39644a26 2795 dSP;
10edeb5d 2796 GV *gv = NULL;
ad02613c 2797 IO *io;
54310121 2798 I32 gimme;
a0d0e21e
LW		 2799 I32 max = 13;
2800
533c011a 2801 if (PL_op->op_flags & OPf_REF) {
2dd78f96 2802 gv = cGVOP_gv;
8a4e5b40 2803 if (PL_op->op_type == OP_LSTAT) {
5d3e98de 2804 if (gv != PL_defgv) {
5d329e6e 2805 do_fstat_warning_check:
5d3e98de 2806 if (ckWARN(WARN_IO))
9014280d 2807 Perl_warner(aTHX_ packWARN(WARN_IO),
38ddb0ef 2808 "lstat() on filehandle %s", gv ? GvENAME(gv) : "");
5d3e98de 2809 } else if (PL_laststype != OP_LSTAT)
8a4e5b40 2810 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
8a4e5b40
DD		 2811 }
2812
748a9306 2813 do_fstat:
2dd78f96 2814 if (gv != PL_defgv) {
3280af22 2815 PL_laststype = OP_STAT;
2dd78f96 2816 PL_statgv = gv;
c69006e4 2817 sv_setpvn(PL_statname, "", 0);
5228a96c 2818 if(gv) {
ad02613c
SP		 2819 io = GvIO(gv);
2820 do_fstat_have_io:
5228a96c
SP		 2821 if (io) {
2822 if (IoIFP(io)) {
2823 PL_laststatval =
2824 PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
2825 } else if (IoDIRP(io)) {
2826#ifdef HAS_DIRFD
2827 PL_laststatval =
2828 PerlLIO_fstat(dirfd(IoDIRP(io)), &PL_statcache);
2829#else
2830 DIE(aTHX_ PL_no_func, "dirfd");
2831#endif
2832 } else {
2833 PL_laststatval = -1;
2834 }
2835 }
2836 }
2837 }
2838
9ddeeac9 2839 if (PL_laststatval < 0) {
2dd78f96
JH		 2840 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2841 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
a0d0e21e 2842 max = 0;
9ddeeac9 2843 }
a0d0e21e
LW		 2844 }
2845 else {
7452cf6a 2846 SV* const sv = POPs;
748a9306 2847 if (SvTYPE(sv) == SVt_PVGV) {
2dd78f96 2848 gv = (GV*)sv;
748a9306 2849 goto do_fstat;
ad02613c
SP		 2850 } else if(SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2851 gv = (GV*)SvRV(sv);
2852 if (PL_op->op_type == OP_LSTAT)
2853 goto do_fstat_warning_check;
2854 goto do_fstat;
2855 } else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2856 io = (IO*)SvRV(sv);
2857 if (PL_op->op_type == OP_LSTAT)
2858 goto do_fstat_warning_check;
2859 goto do_fstat_have_io;
2860 }
2861
0510663f 2862 sv_setpv(PL_statname, SvPV_nolen_const(sv));
a0714e2c 2863 PL_statgv = NULL;
533c011a
NIS		 2864 PL_laststype = PL_op->op_type;
2865 if (PL_op->op_type == OP_LSTAT)
0510663f 2866 PL_laststatval = PerlLIO_lstat(SvPV_nolen_const(PL_statname), &PL_statcache);
a0d0e21e 2867 else
0510663f 2868 PL_laststatval = PerlLIO_stat(SvPV_nolen_const(PL_statname), &PL_statcache);
3280af22 2869 if (PL_laststatval < 0) {
0510663f 2870 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname), '\n'))
9014280d 2871 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
a0d0e21e
LW		 2872 max = 0;
2873 }
2874 }
2875
54310121 2876 gimme = GIMME_V;
2877 if (gimme != G_ARRAY) {
2878 if (gimme != G_VOID)
2879 XPUSHs(boolSV(max));
2880 RETURN;
a0d0e21e
LW		 2881 }
2882 if (max) {
36477c24 2883 EXTEND(SP, max);
2884 EXTEND_MORTAL(max);
1ff81528
PL		 2885 PUSHs(sv_2mortal(newSViv(PL_statcache.st_dev)));
2886 PUSHs(sv_2mortal(newSViv(PL_statcache.st_ino)));
b448e4fe
JH		 2887 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_mode)));
2888 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_nlink)));
146174a9
CB		 2889#if Uid_t_size > IVSIZE
2890 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_uid)));
2891#else
23dcd6c8 2892# if Uid_t_sign <= 0
1ff81528 2893 PUSHs(sv_2mortal(newSViv(PL_statcache.st_uid)));
23dcd6c8
JH		 2894# else
2895 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_uid)));
2896# endif
146174a9 2897#endif
301e8125 2898#if Gid_t_size > IVSIZE
146174a9
CB		 2899 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_gid)));
2900#else
23dcd6c8 2901# if Gid_t_sign <= 0
1ff81528 2902 PUSHs(sv_2mortal(newSViv(PL_statcache.st_gid)));
23dcd6c8
JH		 2903# else
2904 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_gid)));
2905# endif
146174a9 2906#endif
cbdc8872 2907#ifdef USE_STAT_RDEV
1ff81528 2908 PUSHs(sv_2mortal(newSViv(PL_statcache.st_rdev)));
cbdc8872 2909#else
396482e1 2910 PUSHs(sv_2mortal(newSVpvs("")));
cbdc8872 2911#endif
146174a9 2912#if Off_t_size > IVSIZE
4a9d6100 2913 PUSHs(sv_2mortal(newSVnv((NV)PL_statcache.st_size)));
146174a9 2914#else
1ff81528 2915 PUSHs(sv_2mortal(newSViv(PL_statcache.st_size)));
146174a9 2916#endif
cbdc8872 2917#ifdef BIG_TIME
172ae379
JH		 2918 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_atime)));
2919 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_mtime)));
2920 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_ctime)));
cbdc8872 2921#else
aebaba0b
SH		 2922 PUSHs(sv_2mortal(newSViv((IV)PL_statcache.st_atime)));
2923 PUSHs(sv_2mortal(newSViv((IV)PL_statcache.st_mtime)));
2924 PUSHs(sv_2mortal(newSViv((IV)PL_statcache.st_ctime)));
cbdc8872 2925#endif
a0d0e21e 2926#ifdef USE_STAT_BLOCKS
b448e4fe
JH		 2927 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blksize)));
2928 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blocks)));
a0d0e21e 2929#else
396482e1
GA		 2930 PUSHs(sv_2mortal(newSVpvs("")));
2931 PUSHs(sv_2mortal(newSVpvs("")));
a0d0e21e
LW		 2932#endif
2933 }
2934 RETURN;
2935}
2936
fbb0b3b3
RGS		 2937/* This macro is used by the stacked filetest operators :
2938 * if the previous filetest failed, short-circuit and pass its value.
2939 * Else, discard it from the stack and continue. --rgs
2940 */
2941#define STACKED_FTEST_CHECK if (PL_op->op_private & OPpFT_STACKED) { \
2942 if (TOPs == &PL_sv_no || TOPs == &PL_sv_undef) { RETURN; } \
2943 else { (void)POPs; PUTBACK; } \
2944 }
2945
a0d0e21e
LW		 2946PP(pp_ftrread)
2947{
97aff369 2948 dVAR;
9cad6237 2949 I32 result;
af9e49b4
NC		 2950 /* Not const, because things tweak this below. Not bool, because there's
2951 no guarantee that OPp_FT_ACCESS is <= CHAR_MAX */
2952#if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
2953 I32 use_access = PL_op->op_private & OPpFT_ACCESS;
2954 /* Giving some sort of initial value silences compilers. */
2955# ifdef R_OK
2956 int access_mode = R_OK;
2957# else
2958 int access_mode = 0;
2959# endif
5ff3f7a4 2960#else
af9e49b4
NC		 2961 /* access_mode is never used, but leaving use_access in makes the
2962 conditional compiling below much clearer. */
2963 I32 use_access = 0;
5ff3f7a4 2964#endif
af9e49b4 2965 int stat_mode = S_IRUSR;
a0d0e21e 2966
af9e49b4 2967 bool effective = FALSE;
2a3ff820 2968 dSP;
af9e49b4 2969
fbb0b3b3 2970 STACKED_FTEST_CHECK;
af9e49b4
NC		 2971
2972 switch (PL_op->op_type) {
2973 case OP_FTRREAD:
2974#if !(defined(HAS_ACCESS) && defined(R_OK))
2975 use_access = 0;
2976#endif
2977 break;
2978
2979 case OP_FTRWRITE:
5ff3f7a4 2980#if defined(HAS_ACCESS) && defined(W_OK)
af9e49b4 2981 access_mode = W_OK;
5ff3f7a4 2982#else
af9e49b4 2983 use_access = 0;
5ff3f7a4 2984#endif
af9e49b4
NC		 2985 stat_mode = S_IWUSR;
2986 break;
a0d0e21e 2987
af9e49b4 2988 case OP_FTREXEC:
5ff3f7a4 2989#if defined(HAS_ACCESS) && defined(X_OK)
af9e49b4 2990 access_mode = X_OK;
5ff3f7a4 2991#else
af9e49b4 2992 use_access = 0;
5ff3f7a4 2993#endif
af9e49b4
NC		 2994 stat_mode = S_IXUSR;
2995 break;
a0d0e21e 2996
af9e49b4 2997 case OP_FTEWRITE:
faee0e31 2998#ifdef PERL_EFF_ACCESS
af9e49b4 2999 access_mode = W_OK;
5ff3f7a4 3000#endif
af9e49b4
NC		 3001 stat_mode = S_IWUSR;
3002 /* Fall through */
a0d0e21e 3003
af9e49b4
NC		 3004 case OP_FTEREAD:
3005#ifndef PERL_EFF_ACCESS
3006 use_access = 0;
3007#endif
3008 effective = TRUE;
3009 break;
3010
3011
3012 case OP_FTEEXEC:
faee0e31 3013#ifdef PERL_EFF_ACCESS
af9e49b4 3014 access_mode = W_OK;
5ff3f7a4 3015#else
af9e49b4 3016 use_access = 0;
5ff3f7a4 3017#endif
af9e49b4
NC		 3018 stat_mode = S_IXUSR;
3019 effective = TRUE;
3020 break;
3021 }
a0d0e21e 3022
af9e49b4
NC		 3023 if (use_access) {
3024#if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
2c2f35ab 3025 const char *name = POPpx;
af9e49b4
NC		 3026 if (effective) {
3027# ifdef PERL_EFF_ACCESS
3028 result = PERL_EFF_ACCESS(name, access_mode);
3029# else
3030 DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3031 OP_NAME(PL_op));
3032# endif
3033 }
3034 else {
3035# ifdef HAS_ACCESS
3036 result = access(name, access_mode);
3037# else
3038 DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3039# endif
3040 }
5ff3f7a4
GS		 3041 if (result == 0)
3042 RETPUSHYES;
3043 if (result < 0)
3044 RETPUSHUNDEF;
3045 RETPUSHNO;
af9e49b4 3046#endif
22865c03 3047 }
af9e49b4 3048
cea2e8a9 3049 result = my_stat();
22865c03 3050 SPAGAIN;
a0d0e21e
LW		 3051 if (result < 0)
3052 RETPUSHUNDEF;
af9e49b4 3053 if (cando(stat_mode, effective, &PL_statcache))
a0d0e21e
LW		 3054 RETPUSHYES;
3055 RETPUSHNO;
3056}
3057
3058PP(pp_ftis)
3059{
97aff369 3060 dVAR;
fbb0b3b3 3061 I32 result;
d7f0a2f4 3062 const int op_type = PL_op->op_type;
2a3ff820 3063 dSP;
fbb0b3b3
RGS		 3064 STACKED_FTEST_CHECK;
3065 result = my_stat();
3066 SPAGAIN;
a0d0e21e
LW		 3067 if (result < 0)
3068 RETPUSHUNDEF;
d7f0a2f4
NC		 3069 if (op_type == OP_FTIS)
3070 RETPUSHYES;
957b0e1d 3071 {
d7f0a2f4
NC		 3072 /* You can't dTARGET inside OP_FTIS, because you'll get
3073 "panic: pad_sv po" - the op is not flagged to have a target. */
957b0e1d 3074 dTARGET;
d7f0a2f4 3075 switch (op_type) {
957b0e1d
NC		 3076 case OP_FTSIZE:
3077#if Off_t_size > IVSIZE
3078 PUSHn(PL_statcache.st_size);
3079#else
3080 PUSHi(PL_statcache.st_size);
3081#endif
3082 break;
3083 case OP_FTMTIME:
3084 PUSHn( (((NV)PL_basetime - PL_statcache.st_mtime)) / 86400.0 );
3085 break;
3086 case OP_FTATIME:
3087 PUSHn( (((NV)PL_basetime - PL_statcache.st_atime)) / 86400.0 );
3088 break;
3089 case OP_FTCTIME:
3090 PUSHn( (((NV)PL_basetime - PL_statcache.st_ctime)) / 86400.0 );
3091 break;
3092 }
3093 }
3094 RETURN;
a0d0e21e
LW		 3095}
3096
a0d0e21e
LW		 3097PP(pp_ftrowned)
3098{
97aff369 3099 dVAR;
fbb0b3b3 3100 I32 result;
2a3ff820 3101 dSP;
17ad201a
NC		 3102
3103 /* I believe that all these three are likely to be defined on most every
3104 system these days. */
3105#ifndef S_ISUID
3106 if(PL_op->op_type == OP_FTSUID)
3107 RETPUSHNO;
3108#endif
3109#ifndef S_ISGID
3110 if(PL_op->op_type == OP_FTSGID)
3111 RETPUSHNO;
3112#endif
3113#ifndef S_ISVTX
3114 if(PL_op->op_type == OP_FTSVTX)
3115 RETPUSHNO;
3116#endif
3117
fbb0b3b3
RGS		 3118 STACKED_FTEST_CHECK;
3119 result = my_stat();
3120 SPAGAIN;
a0d0e21e
LW		 3121 if (result < 0)
3122 RETPUSHUNDEF;
f1cb2d48
NC		 3123 switch (PL_op->op_type) {
3124 case OP_FTROWNED:
9ab9fa88 3125 if (PL_statcache.st_uid == PL_uid)
f1cb2d48
NC		 3126 RETPUSHYES;
3127 break;
3128 case OP_FTEOWNED:
3129 if (PL_statcache.st_uid == PL_euid)
3130 RETPUSHYES;
3131 break;
3132 case OP_FTZERO:
3133 if (PL_statcache.st_size == 0)
3134 RETPUSHYES;
3135 break;
3136 case OP_FTSOCK:
3137 if (S_ISSOCK(PL_statcache.st_mode))
3138 RETPUSHYES;
3139 break;
3140 case OP_FTCHR:
3141 if (S_ISCHR(PL_statcache.st_mode))
3142 RETPUSHYES;
3143 break;
3144 case OP_FTBLK:
3145 if (S_ISBLK(PL_statcache.st_mode))
3146 RETPUSHYES;
3147 break;
3148 case OP_FTFILE:
3149 if (S_ISREG(PL_statcache.st_mode))
3150 RETPUSHYES;
3151 break;
3152 case OP_FTDIR:
3153 if (S_ISDIR(PL_statcache.st_mode))
3154 RETPUSHYES;
3155 break;
3156 case OP_FTPIPE:
3157 if (S_ISFIFO(PL_statcache.st_mode))
3158 RETPUSHYES;
3159 break;
a0d0e21e 3160#ifdef S_ISUID
17ad201a
NC		 3161 case OP_FTSUID:
3162 if (PL_statcache.st_mode & S_ISUID)
3163 RETPUSHYES;
3164 break;
a0d0e21e 3165#endif
a0d0e21e 3166#ifdef S_ISGID
17ad201a
NC		 3167 case OP_FTSGID:
3168 if (PL_statcache.st_mode & S_ISGID)
3169 RETPUSHYES;
3170 break;
3171#endif
3172#ifdef S_ISVTX
3173 case OP_FTSVTX:
3174 if (PL_statcache.st_mode & S_ISVTX)
3175 RETPUSHYES;
3176 break;
a0d0e21e 3177#endif
17ad201a 3178 }
a0d0e21e
LW		 3179 RETPUSHNO;
3180}
3181
17ad201a 3182PP(pp_ftlink)
a0d0e21e 3183{
97aff369 3184 dVAR;
17ad201a 3185 I32 result = my_lstat();
39644a26 3186 dSP;
a0d0e21e
LW		 3187 if (result < 0)
3188 RETPUSHUNDEF;
17ad201a 3189 if (S_ISLNK(PL_statcache.st_mode))
a0d0e21e 3190 RETPUSHYES;
a0d0e21e
LW		 3191 RETPUSHNO;
3192}
3193
3194PP(pp_fttty)
3195{
97aff369 3196 dVAR;
39644a26 3197 dSP;
a0d0e21e
LW		 3198 int fd;
3199 GV *gv;
a0714e2c 3200 SV *tmpsv = NULL;
fb73857a 3201
fbb0b3b3
RGS		 3202 STACKED_FTEST_CHECK;
3203
533c011a 3204 if (PL_op->op_flags & OPf_REF)
146174a9 3205 gv = cGVOP_gv;
fb73857a 3206 else if (isGV(TOPs))
3207 gv = (GV*)POPs;
3208 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3209 gv = (GV*)SvRV(POPs);
a0d0e21e 3210 else
f776e3cd 3211 gv = gv_fetchsv(tmpsv = POPs, 0, SVt_PVIO);
fb73857a 3212
a0d0e21e 3213 if (GvIO(gv) && IoIFP(GvIOp(gv)))
760ac839 3214 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
7a5fd60d 3215 else if (tmpsv && SvOK(tmpsv)) {
349d4f2f 3216 const char *tmps = SvPV_nolen_const(tmpsv);
7a5fd60d
NC		 3217 if (isDIGIT(*tmps))
3218 fd = atoi(tmps);
3219 else
3220 RETPUSHUNDEF;
3221 }
a0d0e21e
LW		 3222 else
3223 RETPUSHUNDEF;
6ad3d225 3224 if (PerlLIO_isatty(fd))
a0d0e21e
LW		 3225 RETPUSHYES;
3226 RETPUSHNO;
3227}
3228
16d20bd9
AD		 3229#if defined(atarist) /* this will work with atariST. Configure will
3230 make guesses for other systems. */
3231# define FILE_base(f) ((f)->_base)
3232# define FILE_ptr(f) ((f)->_ptr)
3233# define FILE_cnt(f) ((f)->_cnt)
3234# define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
a0d0e21e
LW		 3235#endif
3236
3237PP(pp_fttext)
3238{
97aff369 3239 dVAR;
39644a26 3240 dSP;
a0d0e21e
LW		 3241 I32 i;
3242 I32 len;
3243 I32 odd = 0;
3244 STDCHAR tbuf[512];
3245 register STDCHAR *s;
3246 register IO *io;
5f05dabc 3247 register SV *sv;
3248 GV *gv;
146174a9 3249 PerlIO *fp;
a0d0e21e 3250
fbb0b3b3
RGS		 3251 STACKED_FTEST_CHECK;
3252
533c011a 3253 if (PL_op->op_flags & OPf_REF)
146174a9 3254 gv = cGVOP_gv;
5f05dabc 3255 else if (isGV(TOPs))
3256 gv = (GV*)POPs;
3257 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3258 gv = (GV*)SvRV(POPs);
3259 else
a0714e2c 3260 gv = NULL;
5f05dabc 3261
3262 if (gv) {
a0d0e21e 3263 EXTEND(SP, 1);
3280af22
NIS		 3264 if (gv == PL_defgv) {
3265 if (PL_statgv)
3266 io = GvIO(PL_statgv);
a0d0e21e 3267 else {
3280af22 3268 sv = PL_statname;
a0d0e21e
LW		 3269 goto really_filename;
3270 }
3271 }
3272 else {
3280af22
NIS		 3273 PL_statgv = gv;
3274 PL_laststatval = -1;
c69006e4 3275 sv_setpvn(PL_statname, "", 0);
3280af22 3276 io = GvIO(PL_statgv);
a0d0e21e
LW		 3277 }
3278 if (io && IoIFP(io)) {
5f05dabc 3279 if (! PerlIO_has_base(IoIFP(io)))
cea2e8a9 3280 DIE(aTHX_ "-T and -B not implemented on filehandles");
3280af22
NIS		 3281 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3282 if (PL_laststatval < 0)
5f05dabc 3283 RETPUSHUNDEF;
9cbac4c7 3284 if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
533c011a 3285 if (PL_op->op_type == OP_FTTEXT)
a0d0e21e
LW		 3286 RETPUSHNO;
3287 else
3288 RETPUSHYES;
9cbac4c7 3289 }
a20bf0c3 3290 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
760ac839 3291 i = PerlIO_getc(IoIFP(io));
a0d0e21e 3292 if (i != EOF)
760ac839 3293 (void)PerlIO_ungetc(IoIFP(io),i);
a0d0e21e 3294 }
a20bf0c3 3295 if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
a0d0e21e 3296 RETPUSHYES;
a20bf0c3
JH		 3297 len = PerlIO_get_bufsiz(IoIFP(io));
3298 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
760ac839
LW		 3299 /* sfio can have large buffers - limit to 512 */
3300 if (len > 512)
3301 len = 512;
a0d0e21e
LW		 3302 }
3303 else {
2dd78f96 3304 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
146174a9 3305 gv = cGVOP_gv;
2dd78f96 3306 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
146174a9 3307 }
93189314 3308 SETERRNO(EBADF,RMS_IFI);
a0d0e21e
LW		 3309 RETPUSHUNDEF;
3310 }
3311 }
3312 else {
3313 sv = POPs;
5f05dabc 3314 really_filename:
a0714e2c 3315 PL_statgv = NULL;
5c9aa243 3316 PL_laststype = OP_STAT;
d5263905 3317 sv_setpv(PL_statname, SvPV_nolen_const(sv));
aa07b2f6 3318 if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) {
349d4f2f
NC		 3319 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname),
3320 '\n'))
9014280d 3321 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
a0d0e21e
LW		 3322 RETPUSHUNDEF;
3323 }
146174a9
CB		 3324 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3325 if (PL_laststatval < 0) {
3326 (void)PerlIO_close(fp);
5f05dabc 3327 RETPUSHUNDEF;
146174a9 3328 }
bd61b366 3329 PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
146174a9
CB		 3330 len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3331 (void)PerlIO_close(fp);
a0d0e21e 3332 if (len <= 0) {
533c011a 3333 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
a0d0e21e
LW		 3334 RETPUSHNO; /* special case NFS directories */
3335 RETPUSHYES; /* null file is anything */
3336 }
3337 s = tbuf;
3338 }
3339
3340 /* now scan s to look for textiness */
4633a7c4 3341 /* XXX ASCII dependent code */
a0d0e21e 3342
146174a9
CB		 3343#if defined(DOSISH) || defined(USEMYBINMODE)
3344 /* ignore trailing ^Z on short files */
58c0efa5 3345 if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26)
146174a9
CB		 3346 --len;
3347#endif
3348
a0d0e21e
LW		 3349 for (i = 0; i < len; i++, s++) {
3350 if (!*s) { /* null never allowed in text */
3351 odd += len;
3352 break;
3353 }
9d116dd7 3354#ifdef EBCDIC
301e8125 3355 else if (!(isPRINT(*s) || isSPACE(*s)))
9d116dd7
JH		 3356 odd++;
3357#else
146174a9
CB		 3358 else if (*s & 128) {
3359#ifdef USE_LOCALE
2de3dbcc 3360 if (IN_LOCALE_RUNTIME && isALPHA_LC(*s))
b3f66c68
GS		 3361 continue;
3362#endif
3363 /* utf8 characters don't count as odd */
fd400ab9 3364 if (UTF8_IS_START(*s)) {
b3f66c68
GS		 3365 int ulen = UTF8SKIP(s);
3366 if (ulen < len - i) {
3367 int j;
3368 for (j = 1; j < ulen; j++) {
fd400ab9 3369 if (!UTF8_IS_CONTINUATION(s[j]))
b3f66c68
GS		 3370 goto not_utf8;
3371 }
3372 --ulen; /* loop does extra increment */
3373 s += ulen;
3374 i += ulen;
3375 continue;
3376 }
3377 }
3378 not_utf8:
3379 odd++;
146174a9 3380 }
a0d0e21e
LW		 3381 else if (*s < 32 &&
3382 *s != '\n' && *s != '\r' && *s != '\b' &&
3383 *s != '\t' && *s != '\f' && *s != 27)
3384 odd++;
9d116dd7 3385#endif
a0d0e21e
LW		 3386 }
3387
533c011a 3388 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
a0d0e21e
LW		 3389 RETPUSHNO;
3390 else
3391 RETPUSHYES;
3392}
3393
a0d0e21e
LW		 3394/* File calls. */
3395
3396PP(pp_chdir)
3397{
97aff369 3398 dVAR; dSP; dTARGET;
c445ea15 3399 const char *tmps = NULL;
9a957fbc 3400 GV *gv = NULL;
a0d0e21e 3401
c4aca7d0 3402 if( MAXARG == 1 ) {
9a957fbc 3403 SV * const sv = POPs;
d4ac975e
GA		 3404 if (PL_op->op_flags & OPf_SPECIAL) {
3405 gv = gv_fetchsv(sv, 0, SVt_PVIO);
3406 }
3407 else if (SvTYPE(sv) == SVt_PVGV) {
c4aca7d0
GA		 3408 gv = (GV*)sv;
3409 }
3410 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
3411 gv = (GV*)SvRV(sv);
3412 }
3413 else {
3414 tmps = SvPVx_nolen_const(sv);
3415 }
3416 }
35ae6b54 3417
c4aca7d0 3418 if( !gv && (!tmps || !*tmps) ) {
9a957fbc
AL		 3419 HV * const table = GvHVn(PL_envgv);
3420 SV **svp;
3421
a4fc7abc
AL		 3422 if ( (svp = hv_fetchs(table, "HOME", FALSE))
3423 || (svp = hv_fetchs(table, "LOGDIR", FALSE))
491527d0 3424#ifdef VMS
a4fc7abc 3425 || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
491527d0 3426#endif
35ae6b54
MS		 3427 )
3428 {
3429 if( MAXARG == 1 )
9014280d 3430 deprecate("chdir('') or chdir(undef) as chdir()");
8c074e2a 3431 tmps = SvPV_nolen_const(*svp);
35ae6b54 3432 }
72f496dc 3433 else {
389ec635 3434 PUSHi(0);
b7ab37f8 3435 TAINT_PROPER("chdir");
389ec635
MS		 3436 RETURN;
3437 }
8ea155d1 3438 }
8ea155d1 3439
a0d0e21e 3440 TAINT_PROPER("chdir");
c4aca7d0
GA		 3441 if (gv) {
3442#ifdef HAS_FCHDIR
9a957fbc 3443 IO* const io = GvIO(gv);
c4aca7d0 3444 if (io) {
c08d6937 3445 if (IoDIRP(io)) {
c4aca7d0
GA		 3446#ifdef HAS_DIRFD
3447 PUSHi(fchdir(dirfd(IoDIRP(io))) >= 0);
3448#else
0f1f2428 3449 DIE(aTHX_ PL_no_func, "dirfd");
c4aca7d0 3450#endif
c08d6937
SP		 3451 } else if (IoIFP(io)) {
3452 PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
c4aca7d0
GA		 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.