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