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
Move the low/high cop sequences from NVX/IVX to a two U32 structure
[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 1831 io = GvIO(gv);
cf167416 1832 if (!io || !IoIFP(io) || IoTYPE(io) == IoTYPE_RDONLY) {
8c99d73e 1833 retval = -1;
cf167416
RGS		 1834 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
1835 if (io && IoIFP(io))
1836 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1837 else
1838 report_evil_fh(gv, io, PL_op->op_type);
1839 }
b5fe5ca2 1840 SETERRNO(EBADF,RMS_IFI);
7d59b7e4
NIS		 1841 goto say_undef;
1842 }
1843
c9cb0f41
NC		 1844 /* Do this first to trigger any overloading. */
1845 buffer = SvPV_const(bufsv, blen);
1846 orig_blen_bytes = blen;
1847 doing_utf8 = DO_UTF8(bufsv);
1848
7d59b7e4 1849 if (PerlIO_isutf8(IoIFP(io))) {
6aa2f6a7 1850 if (!SvUTF8(bufsv)) {
c9cb0f41
NC		 1851 /* We don't modify the original scalar. */
1852 tmpbuf = bytes_to_utf8((const U8*) buffer, &blen);
1853 buffer = (char *) tmpbuf;
1854 doing_utf8 = TRUE;
1855 }
a0d0e21e 1856 }
c9cb0f41
NC		 1857 else if (doing_utf8) {
1858 STRLEN tmplen = blen;
a79db61d 1859 U8 * const result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8);
c9cb0f41
NC		 1860 if (!doing_utf8) {
1861 tmpbuf = result;
1862 buffer = (char *) tmpbuf;
1863 blen = tmplen;
1864 }
1865 else {
1866 assert((char *)result == buffer);
1867 Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op));
1868 }
7d59b7e4
NIS		 1869 }
1870
64a1bc8e 1871 if (op_type == OP_SYSWRITE) {
c9cb0f41
NC		 1872 Size_t length = 0; /* This length is in characters. */
1873 STRLEN blen_chars;
7d59b7e4 1874 IV offset;
c9cb0f41
NC		 1875
1876 if (doing_utf8) {
1877 if (tmpbuf) {
1878 /* The SV is bytes, and we've had to upgrade it. */
1879 blen_chars = orig_blen_bytes;
1880 } else {
1881 /* The SV really is UTF-8. */
1882 if (SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1883 /* Don't call sv_len_utf8 again because it will call magic
1884 or overloading a second time, and we might get back a
1885 different result. */
9a206dfd 1886 blen_chars = utf8_length((U8*)buffer, (U8*)buffer + blen);
c9cb0f41
NC		 1887 } else {
1888 /* It's safe, and it may well be cached. */
1889 blen_chars = sv_len_utf8(bufsv);
1890 }
1891 }
1892 } else {
1893 blen_chars = blen;
1894 }
1895
1896 if (MARK >= SP) {
1897 length = blen_chars;
1898 } else {
1899#if Size_t_size > IVSIZE
1900 length = (Size_t)SvNVx(*++MARK);
1901#else
1902 length = (Size_t)SvIVx(*++MARK);
1903#endif
4b0c4b6f
NC		 1904 if ((SSize_t)length < 0) {
1905 Safefree(tmpbuf);
c9cb0f41 1906 DIE(aTHX_ "Negative length");
4b0c4b6f 1907 }
7d59b7e4 1908 }
c9cb0f41 1909
bbce6d69 1910 if (MARK < SP) {
a0d0e21e 1911 offset = SvIVx(*++MARK);
bbce6d69 1912 if (offset < 0) {
4b0c4b6f
NC		 1913 if (-offset > (IV)blen_chars) {
1914 Safefree(tmpbuf);
cea2e8a9 1915 DIE(aTHX_ "Offset outside string");
4b0c4b6f 1916 }
c9cb0f41 1917 offset += blen_chars;
4b0c4b6f
NC		 1918 } else if (offset >= (IV)blen_chars && blen_chars > 0) {
1919 Safefree(tmpbuf);
cea2e8a9 1920 DIE(aTHX_ "Offset outside string");
4b0c4b6f 1921 }
bbce6d69 1922 } else
a0d0e21e 1923 offset = 0;
c9cb0f41
NC		 1924 if (length > blen_chars - offset)
1925 length = blen_chars - offset;
1926 if (doing_utf8) {
1927 /* Here we convert length from characters to bytes. */
1928 if (tmpbuf || SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1929 /* Either we had to convert the SV, or the SV is magical, or
1930 the SV has overloading, in which case we can't or mustn't
1931 or mustn't call it again. */
1932
1933 buffer = (const char*)utf8_hop((const U8 *)buffer, offset);
1934 length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
1935 } else {
1936 /* It's a real UTF-8 SV, and it's not going to change under
1937 us. Take advantage of any cache. */
1938 I32 start = offset;
1939 I32 len_I32 = length;
1940
1941 /* Convert the start and end character positions to bytes.
1942 Remember that the second argument to sv_pos_u2b is relative
1943 to the first. */
1944 sv_pos_u2b(bufsv, &start, &len_I32);
1945
1946 buffer += start;
1947 length = len_I32;
1948 }
7d59b7e4
NIS		 1949 }
1950 else {
1951 buffer = buffer+offset;
1952 }
a7092146 1953#ifdef PERL_SOCK_SYSWRITE_IS_SEND
50952442 1954 if (IoTYPE(io) == IoTYPE_SOCKET) {
8c99d73e 1955 retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
7d59b7e4 1956 buffer, length, 0);
a7092146
GS		 1957 }
1958 else
1959#endif
1960 {
94e4c244 1961 /* See the note at doio.c:do_print about filesize limits. --jhi */
8c99d73e 1962 retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
7d59b7e4 1963 buffer, length);
a7092146 1964 }
a0d0e21e
LW		 1965 }
1966#ifdef HAS_SOCKET
64a1bc8e
NC		 1967 else {
1968 const int flags = SvIVx(*++MARK);
1969 if (SP > MARK) {
1970 STRLEN mlen;
1971 char * const sockbuf = SvPVx(*++MARK, mlen);
1972 retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
1973 flags, (struct sockaddr *)sockbuf, mlen);
1974 }
1975 else {
1976 retval
1977 = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, flags);
1978 }
a0d0e21e 1979 }
a0d0e21e
LW		 1980#else
1981 else
cea2e8a9 1982 DIE(aTHX_ PL_no_sock_func, "send");
a0d0e21e 1983#endif
c9cb0f41 1984
8c99d73e 1985 if (retval < 0)
a0d0e21e
LW		 1986 goto say_undef;
1987 SP = ORIGMARK;
c9cb0f41 1988 if (doing_utf8)
f36eea10 1989 retval = utf8_length((U8*)buffer, (U8*)buffer + retval);
4b0c4b6f 1990
a79db61d 1991 Safefree(tmpbuf);
8c99d73e
GS		 1992#if Size_t_size > IVSIZE
1993 PUSHn(retval);
1994#else
1995 PUSHi(retval);
1996#endif
a0d0e21e
LW		 1997 RETURN;
1998
1999 say_undef:
a79db61d 2000 Safefree(tmpbuf);
a0d0e21e
LW		 2001 SP = ORIGMARK;
2002 RETPUSHUNDEF;
2003}
2004
a0d0e21e
LW		 2005PP(pp_eof)
2006{
27da23d5 2007 dVAR; dSP;
a0d0e21e
LW		 2008 GV *gv;
2009
32da55ab 2010 if (MAXARG == 0) {
146174a9
CB		 2011 if (PL_op->op_flags & OPf_SPECIAL) { /* eof() */
2012 IO *io;
ed2c6b9b 2013 gv = PL_last_in_gv = GvEGV(PL_argvgv);
146174a9
CB		 2014 io = GvIO(gv);
2015 if (io && !IoIFP(io)) {
2016 if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) {
2017 IoLINES(io) = 0;
2018 IoFLAGS(io) &= ~IOf_START;
4608196e 2019 do_open(gv, "-", 1, FALSE, O_RDONLY, 0, NULL);
146174a9
CB		 2020 sv_setpvn(GvSV(gv), "-", 1);
2021 SvSETMAGIC(GvSV(gv));
2022 }
2023 else if (!nextargv(gv))
2024 RETPUSHYES;
2025 }
2026 }
2027 else
2028 gv = PL_last_in_gv; /* eof */
2029 }
a0d0e21e 2030 else
146174a9 2031 gv = PL_last_in_gv = (GV*)POPs; /* eof(FH) */
4592e6ca 2032
6136c704
AL		 2033 if (gv) {
2034 IO * const io = GvIO(gv);
2035 MAGIC * mg;
2036 if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
2037 PUSHMARK(SP);
2038 XPUSHs(SvTIED_obj((SV*)io, mg));
2039 PUTBACK;
2040 ENTER;
2041 call_method("EOF", G_SCALAR);
2042 LEAVE;
2043 SPAGAIN;
2044 RETURN;
2045 }
4592e6ca
NIS		 2046 }
2047
54310121 2048 PUSHs(boolSV(!gv || do_eof(gv)));
a0d0e21e
LW		 2049 RETURN;
2050}
2051
2052PP(pp_tell)
2053{
27da23d5 2054 dVAR; dSP; dTARGET;
301e8125 2055 GV *gv;
5b468f54 2056 IO *io;
a0d0e21e 2057
c4420975
AL		 2058 if (MAXARG != 0)
2059 PL_last_in_gv = (GV*)POPs;
2060 gv = PL_last_in_gv;
4592e6ca 2061
a79db61d
AL		 2062 if (gv && (io = GvIO(gv))) {
2063 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
2064 if (mg) {
2065 PUSHMARK(SP);
2066 XPUSHs(SvTIED_obj((SV*)io, mg));
2067 PUTBACK;
2068 ENTER;
2069 call_method("TELL", G_SCALAR);
2070 LEAVE;
2071 SPAGAIN;
2072 RETURN;
2073 }
4592e6ca
NIS		 2074 }
2075
146174a9
CB		 2076#if LSEEKSIZE > IVSIZE
2077 PUSHn( do_tell(gv) );
2078#else
a0d0e21e 2079 PUSHi( do_tell(gv) );
146174a9 2080#endif
a0d0e21e
LW		 2081 RETURN;
2082}
2083
137443ea 2084PP(pp_sysseek)
2085{
27da23d5 2086 dVAR; dSP;
1df70142 2087 const int whence = POPi;
146174a9 2088#if LSEEKSIZE > IVSIZE
7452cf6a 2089 const Off_t offset = (Off_t)SvNVx(POPs);
146174a9 2090#else
7452cf6a 2091 const Off_t offset = (Off_t)SvIVx(POPs);
146174a9 2092#endif
a0d0e21e 2093
7452cf6a 2094 GV * const gv = PL_last_in_gv = (GV*)POPs;
a79db61d 2095 IO *io;
4592e6ca 2096
a79db61d
AL		 2097 if (gv && (io = GvIO(gv))) {
2098 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
2099 if (mg) {
2100 PUSHMARK(SP);
2101 XPUSHs(SvTIED_obj((SV*)io, mg));
cb50131a 2102#if LSEEKSIZE > IVSIZE
a79db61d 2103 XPUSHs(sv_2mortal(newSVnv((NV) offset)));
cb50131a 2104#else
a79db61d 2105 XPUSHs(sv_2mortal(newSViv(offset)));
cb50131a 2106#endif
a79db61d
AL		 2107 XPUSHs(sv_2mortal(newSViv(whence)));
2108 PUTBACK;
2109 ENTER;
2110 call_method("SEEK", G_SCALAR);
2111 LEAVE;
2112 SPAGAIN;
2113 RETURN;
2114 }
4592e6ca
NIS		 2115 }
2116
533c011a 2117 if (PL_op->op_type == OP_SEEK)
8903cb82 2118 PUSHs(boolSV(do_seek(gv, offset, whence)));
2119 else {
0bcc34c2 2120 const Off_t sought = do_sysseek(gv, offset, whence);
b448e4fe 2121 if (sought < 0)
146174a9
CB		 2122 PUSHs(&PL_sv_undef);
2123 else {
7452cf6a 2124 SV* const sv = sought ?
146174a9 2125#if LSEEKSIZE > IVSIZE
b448e4fe 2126 newSVnv((NV)sought)
146174a9 2127#else
b448e4fe 2128 newSViv(sought)
146174a9
CB		 2129#endif
2130 : newSVpvn(zero_but_true, ZBTLEN);
2131 PUSHs(sv_2mortal(sv));
2132 }
8903cb82 2133 }
a0d0e21e
LW		 2134 RETURN;
2135}
2136
2137PP(pp_truncate)
2138{
97aff369 2139 dVAR;
39644a26 2140 dSP;
8c99d73e
GS		 2141 /* There seems to be no consensus on the length type of truncate()
2142 * and ftruncate(), both off_t and size_t have supporters. In
2143 * general one would think that when using large files, off_t is
2144 * at least as wide as size_t, so using an off_t should be okay. */
2145 /* XXX Configure probe for the length type of *truncate() needed XXX */
0bcc34c2 2146 Off_t len;
a0d0e21e 2147
25342a55 2148#if Off_t_size > IVSIZE
0bcc34c2 2149 len = (Off_t)POPn;
8c99d73e 2150#else
0bcc34c2 2151 len = (Off_t)POPi;
8c99d73e
GS		 2152#endif
2153 /* Checking for length < 0 is problematic as the type might or
301e8125 2154 * might not be signed: if it is not, clever compilers will moan. */
8c99d73e 2155 /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
748a9306 2156 SETERRNO(0,0);
d05c1ba0 2157 {
d05c1ba0
JH		 2158 int result = 1;
2159 GV *tmpgv;
090bf15b
SR		 2160 IO *io;
2161
d05c1ba0 2162 if (PL_op->op_flags & OPf_SPECIAL) {
f776e3cd 2163 tmpgv = gv_fetchsv(POPs, 0, SVt_PVIO);
d05c1ba0 2164
090bf15b
SR		 2165 do_ftruncate_gv:
2166 if (!GvIO(tmpgv))
2167 result = 0;
d05c1ba0 2168 else {
090bf15b
SR		 2169 PerlIO *fp;
2170 io = GvIOp(tmpgv);
2171 do_ftruncate_io:
2172 TAINT_PROPER("truncate");
2173 if (!(fp = IoIFP(io))) {
2174 result = 0;
2175 }
2176 else {
2177 PerlIO_flush(fp);
cbdc8872 2178#ifdef HAS_TRUNCATE
090bf15b 2179 if (ftruncate(PerlIO_fileno(fp), len) < 0)
301e8125 2180#else
090bf15b 2181 if (my_chsize(PerlIO_fileno(fp), len) < 0)
cbdc8872 2182#endif
090bf15b
SR		 2183 result = 0;
2184 }
d05c1ba0 2185 }
cbdc8872 2186 }
d05c1ba0 2187 else {
7452cf6a 2188 SV * const sv = POPs;
83003860 2189 const char *name;
7a5fd60d 2190
d05c1ba0
JH		 2191 if (SvTYPE(sv) == SVt_PVGV) {
2192 tmpgv = (GV*)sv; /* *main::FRED for example */
090bf15b 2193 goto do_ftruncate_gv;
d05c1ba0
JH		 2194 }
2195 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2196 tmpgv = (GV*) SvRV(sv); /* \*main::FRED for example */
090bf15b
SR		 2197 goto do_ftruncate_gv;
2198 }
2199 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2200 io = (IO*) SvRV(sv); /* *main::FRED{IO} for example */
2201 goto do_ftruncate_io;
d05c1ba0 2202 }
1e422769 2203
83003860 2204 name = SvPV_nolen_const(sv);
d05c1ba0 2205 TAINT_PROPER("truncate");
cbdc8872 2206#ifdef HAS_TRUNCATE
d05c1ba0
JH		 2207 if (truncate(name, len) < 0)
2208 result = 0;
cbdc8872 2209#else
d05c1ba0 2210 {
7452cf6a 2211 const int tmpfd = PerlLIO_open(name, O_RDWR);
d05c1ba0 2212
7452cf6a 2213 if (tmpfd < 0)
cbdc8872 2214 result = 0;
d05c1ba0
JH		 2215 else {
2216 if (my_chsize(tmpfd, len) < 0)
2217 result = 0;
2218 PerlLIO_close(tmpfd);
2219 }
cbdc8872 2220 }
a0d0e21e 2221#endif
d05c1ba0 2222 }
a0d0e21e 2223
d05c1ba0
JH		 2224 if (result)
2225 RETPUSHYES;
2226 if (!errno)
93189314 2227 SETERRNO(EBADF,RMS_IFI);
d05c1ba0
JH		 2228 RETPUSHUNDEF;
2229 }
a0d0e21e
LW		 2230}
2231
a0d0e21e
LW		 2232PP(pp_ioctl)
2233{
97aff369 2234 dVAR; dSP; dTARGET;
7452cf6a 2235 SV * const argsv = POPs;
1df70142 2236 const unsigned int func = POPu;
e1ec3a88 2237 const int optype = PL_op->op_type;
7452cf6a 2238 GV * const gv = (GV*)POPs;
4608196e 2239 IO * const io = gv ? GvIOn(gv) : NULL;
a0d0e21e 2240 char *s;
324aa91a 2241 IV retval;
a0d0e21e 2242
748a9306 2243 if (!io || !argsv || !IoIFP(io)) {
c289d2f7
JH		 2244 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2245 report_evil_fh(gv, io, PL_op->op_type);
93189314 2246 SETERRNO(EBADF,RMS_IFI); /* well, sort of... */
a0d0e21e
LW		 2247 RETPUSHUNDEF;
2248 }
2249
748a9306 2250 if (SvPOK(argsv) || !SvNIOK(argsv)) {
a0d0e21e 2251 STRLEN len;
324aa91a 2252 STRLEN need;
748a9306 2253 s = SvPV_force(argsv, len);
324aa91a
HF		 2254 need = IOCPARM_LEN(func);
2255 if (len < need) {
2256 s = Sv_Grow(argsv, need + 1);
2257 SvCUR_set(argsv, need);
a0d0e21e
LW		 2258 }
2259
748a9306 2260 s[SvCUR(argsv)] = 17; /* a little sanity check here */
a0d0e21e
LW		 2261 }
2262 else {
748a9306 2263 retval = SvIV(argsv);
c529f79d 2264 s = INT2PTR(char*,retval); /* ouch */
a0d0e21e
LW		 2265 }
2266
ed4b2e6b 2267 TAINT_PROPER(PL_op_desc[optype]);
a0d0e21e
LW		 2268
2269 if (optype == OP_IOCTL)
2270#ifdef HAS_IOCTL
76e3520e 2271 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
a0d0e21e 2272#else
cea2e8a9 2273 DIE(aTHX_ "ioctl is not implemented");
a0d0e21e
LW		 2274#endif
2275 else
c214f4ad
WB		 2276#ifndef HAS_FCNTL
2277 DIE(aTHX_ "fcntl is not implemented");
2278#else
55497cff 2279#if defined(OS2) && defined(__EMX__)
760ac839 2280 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
55497cff 2281#else
760ac839 2282 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
301e8125 2283#endif
6652bd42 2284#endif
a0d0e21e 2285
6652bd42 2286#if defined(HAS_IOCTL) || defined(HAS_FCNTL)
748a9306
LW		 2287 if (SvPOK(argsv)) {
2288 if (s[SvCUR(argsv)] != 17)
cea2e8a9 2289 DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
53e06cf0 2290 OP_NAME(PL_op));
748a9306
LW		 2291 s[SvCUR(argsv)] = 0; /* put our null back */
2292 SvSETMAGIC(argsv); /* Assume it has changed */
a0d0e21e
LW		 2293 }
2294
2295 if (retval == -1)
2296 RETPUSHUNDEF;
2297 if (retval != 0) {
2298 PUSHi(retval);
2299 }
2300 else {
8903cb82 2301 PUSHp(zero_but_true, ZBTLEN);
a0d0e21e 2302 }
4808266b 2303#endif
c214f4ad 2304 RETURN;
a0d0e21e
LW		 2305}
2306
2307PP(pp_flock)
2308{
9cad6237 2309#ifdef FLOCK
97aff369 2310 dVAR; dSP; dTARGET;
a0d0e21e 2311 I32 value;
bc37a18f 2312 IO *io = NULL;
760ac839 2313 PerlIO *fp;
7452cf6a
AL		 2314 const int argtype = POPi;
2315 GV * const gv = (MAXARG == 0) ? PL_last_in_gv : (GV*)POPs;
16d20bd9 2316
bc37a18f
RG		 2317 if (gv && (io = GvIO(gv)))
2318 fp = IoIFP(io);
2319 else {
4608196e 2320 fp = NULL;
bc37a18f
RG		 2321 io = NULL;
2322 }
0bcc34c2 2323 /* XXX Looks to me like io is always NULL at this point */
a0d0e21e 2324 if (fp) {
68dc0745 2325 (void)PerlIO_flush(fp);
76e3520e 2326 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
a0d0e21e 2327 }
cb50131a 2328 else {
bc37a18f
RG		 2329 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2330 report_evil_fh(gv, io, PL_op->op_type);
a0d0e21e 2331 value = 0;
93189314 2332 SETERRNO(EBADF,RMS_IFI);
cb50131a 2333 }
a0d0e21e
LW		 2334 PUSHi(value);
2335 RETURN;
2336#else
cea2e8a9 2337 DIE(aTHX_ PL_no_func, "flock()");
a0d0e21e
LW		 2338#endif
2339}
2340
2341/* Sockets. */
2342
2343PP(pp_socket)
2344{
a0d0e21e 2345#ifdef HAS_SOCKET
97aff369 2346 dVAR; dSP;
7452cf6a
AL		 2347 const int protocol = POPi;
2348 const int type = POPi;
2349 const int domain = POPi;
2350 GV * const gv = (GV*)POPs;
2351 register IO * const io = gv ? GvIOn(gv) : NULL;
a0d0e21e
LW		 2352 int fd;
2353
c289d2f7
JH		 2354 if (!gv || !io) {
2355 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2356 report_evil_fh(gv, io, PL_op->op_type);
5ee74a84 2357 if (io && IoIFP(io))
c289d2f7 2358 do_close(gv, FALSE);
93189314 2359 SETERRNO(EBADF,LIB_INVARG);
a0d0e21e
LW		 2360 RETPUSHUNDEF;
2361 }
2362
57171420
BS		 2363 if (IoIFP(io))
2364 do_close(gv, FALSE);
2365
a0d0e21e 2366 TAINT_PROPER("socket");
6ad3d225 2367 fd = PerlSock_socket(domain, type, protocol);
a0d0e21e
LW		 2368 if (fd < 0)
2369 RETPUSHUNDEF;
460c8493
IZ		 2370 IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
2371 IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
50952442 2372 IoTYPE(io) = IoTYPE_SOCKET;
a0d0e21e 2373 if (!IoIFP(io) || !IoOFP(io)) {
760ac839
LW		 2374 if (IoIFP(io)) PerlIO_close(IoIFP(io));
2375 if (IoOFP(io)) PerlIO_close(IoOFP(io));
6ad3d225 2376 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
a0d0e21e
LW		 2377 RETPUSHUNDEF;
2378 }
8d2a6795
GS		 2379#if defined(HAS_FCNTL) && defined(F_SETFD)
2380 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2381#endif
a0d0e21e 2382
d5ff79b3
OF		 2383#ifdef EPOC
2384 setbuf( IoIFP(io), NULL); /* EPOC gets confused about sockets */
2385#endif
2386
a0d0e21e
LW		 2387 RETPUSHYES;
2388#else
cea2e8a9 2389 DIE(aTHX_ PL_no_sock_func, "socket");
a0d0e21e
LW		 2390#endif
2391}
2392
2393PP(pp_sockpair)
2394{
c95c94b1 2395#if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
97aff369 2396 dVAR; dSP;
7452cf6a
AL		 2397 const int protocol = POPi;
2398 const int type = POPi;
2399 const int domain = POPi;
2400 GV * const gv2 = (GV*)POPs;
2401 GV * const gv1 = (GV*)POPs;
2402 register IO * const io1 = gv1 ? GvIOn(gv1) : NULL;
2403 register IO * const io2 = gv2 ? GvIOn(gv2) : NULL;
a0d0e21e
LW		 2404 int fd[2];
2405
c289d2f7
JH		 2406 if (!gv1 || !gv2 || !io1 || !io2) {
2407 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
2408 if (!gv1 || !io1)
2409 report_evil_fh(gv1, io1, PL_op->op_type);
2410 if (!gv2 || !io2)
2411 report_evil_fh(gv1, io2, PL_op->op_type);
2412 }
5ee74a84 2413 if (io1 && IoIFP(io1))
c289d2f7 2414 do_close(gv1, FALSE);
5ee74a84 2415 if (io2 && IoIFP(io2))
c289d2f7 2416 do_close(gv2, FALSE);
a0d0e21e 2417 RETPUSHUNDEF;
c289d2f7 2418 }
a0d0e21e 2419
dc0d0a5f
JH		 2420 if (IoIFP(io1))
2421 do_close(gv1, FALSE);
2422 if (IoIFP(io2))
2423 do_close(gv2, FALSE);
57171420 2424
a0d0e21e 2425 TAINT_PROPER("socketpair");
6ad3d225 2426 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
a0d0e21e 2427 RETPUSHUNDEF;
460c8493
IZ		 2428 IoIFP(io1) = PerlIO_fdopen(fd[0], "r"SOCKET_OPEN_MODE);
2429 IoOFP(io1) = PerlIO_fdopen(fd[0], "w"SOCKET_OPEN_MODE);
50952442 2430 IoTYPE(io1) = IoTYPE_SOCKET;
460c8493
IZ		 2431 IoIFP(io2) = PerlIO_fdopen(fd[1], "r"SOCKET_OPEN_MODE);
2432 IoOFP(io2) = PerlIO_fdopen(fd[1], "w"SOCKET_OPEN_MODE);
50952442 2433 IoTYPE(io2) = IoTYPE_SOCKET;
a0d0e21e 2434 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
760ac839
LW		 2435 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2436 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
6ad3d225 2437 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
760ac839
LW		 2438 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2439 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
6ad3d225 2440 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
a0d0e21e
LW		 2441 RETPUSHUNDEF;
2442 }
8d2a6795
GS		 2443#if defined(HAS_FCNTL) && defined(F_SETFD)
2444 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
2445 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
2446#endif
a0d0e21e
LW		 2447
2448 RETPUSHYES;
2449#else
cea2e8a9 2450 DIE(aTHX_ PL_no_sock_func, "socketpair");
a0d0e21e
LW		 2451#endif
2452}
2453
2454PP(pp_bind)
2455{
a0d0e21e 2456#ifdef HAS_SOCKET
97aff369 2457 dVAR; dSP;
7452cf6a 2458 SV * const addrsv = POPs;
349d4f2f
NC		 2459 /* OK, so on what platform does bind modify addr? */
2460 const char *addr;
7452cf6a
AL		 2461 GV * const gv = (GV*)POPs;
2462 register IO * const io = GvIOn(gv);
a0d0e21e
LW		 2463 STRLEN len;
2464
2465 if (!io || !IoIFP(io))
2466 goto nuts;
2467
349d4f2f 2468 addr = SvPV_const(addrsv, len);
a0d0e21e 2469 TAINT_PROPER("bind");
a79db61d 2470 if (PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
a0d0e21e
LW		 2471 RETPUSHYES;
2472 else
2473 RETPUSHUNDEF;
2474
2475nuts:
599cee73 2476 if (ckWARN(WARN_CLOSED))
bc37a18f 2477 report_evil_fh(gv, io, PL_op->op_type);
93189314 2478 SETERRNO(EBADF,SS_IVCHAN);
a0d0e21e
LW		 2479 RETPUSHUNDEF;
2480#else
cea2e8a9 2481 DIE(aTHX_ PL_no_sock_func, "bind");
a0d0e21e
LW		 2482#endif
2483}
2484
2485PP(pp_connect)
2486{
a0d0e21e 2487#ifdef HAS_SOCKET
97aff369 2488 dVAR; dSP;
7452cf6a
AL		 2489 SV * const addrsv = POPs;
2490 GV * const gv = (GV*)POPs;
2491 register IO * const io = GvIOn(gv);
349d4f2f 2492 const char *addr;
a0d0e21e
LW		 2493 STRLEN len;
2494
2495 if (!io || !IoIFP(io))
2496 goto nuts;
2497
349d4f2f 2498 addr = SvPV_const(addrsv, len);
a0d0e21e 2499 TAINT_PROPER("connect");
6ad3d225 2500 if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
a0d0e21e
LW		 2501 RETPUSHYES;
2502 else
2503 RETPUSHUNDEF;
2504
2505nuts:
599cee73 2506 if (ckWARN(WARN_CLOSED))
bc37a18f 2507 report_evil_fh(gv, io, PL_op->op_type);
93189314 2508 SETERRNO(EBADF,SS_IVCHAN);
a0d0e21e
LW		 2509 RETPUSHUNDEF;
2510#else
cea2e8a9 2511 DIE(aTHX_ PL_no_sock_func, "connect");
a0d0e21e
LW		 2512#endif
2513}
2514
2515PP(pp_listen)
2516{
a0d0e21e 2517#ifdef HAS_SOCKET
97aff369 2518 dVAR; dSP;
7452cf6a
AL		 2519 const int backlog = POPi;
2520 GV * const gv = (GV*)POPs;
2521 register IO * const io = gv ? GvIOn(gv) : NULL;
a0d0e21e 2522
c289d2f7 2523 if (!gv || !io || !IoIFP(io))
a0d0e21e
LW		 2524 goto nuts;
2525
6ad3d225 2526 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
a0d0e21e
LW		 2527 RETPUSHYES;
2528 else
2529 RETPUSHUNDEF;
2530
2531nuts:
599cee73 2532 if (ckWARN(WARN_CLOSED))
bc37a18f 2533 report_evil_fh(gv, io, PL_op->op_type);
93189314 2534 SETERRNO(EBADF,SS_IVCHAN);
a0d0e21e
LW		 2535 RETPUSHUNDEF;
2536#else
cea2e8a9 2537 DIE(aTHX_ PL_no_sock_func, "listen");
a0d0e21e
LW		 2538#endif
2539}
2540
2541PP(pp_accept)
2542{
a0d0e21e 2543#ifdef HAS_SOCKET
97aff369 2544 dVAR; dSP; dTARGET;
a0d0e21e
LW		 2545 register IO *nstio;
2546 register IO *gstio;
93d47a36
JH		 2547 char namebuf[MAXPATHLEN];
2548#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
2549 Sock_size_t len = sizeof (struct sockaddr_in);
2550#else
2551 Sock_size_t len = sizeof namebuf;
2552#endif
7452cf6a
AL		 2553 GV * const ggv = (GV*)POPs;
2554 GV * const ngv = (GV*)POPs;
a0d0e21e
LW		 2555 int fd;
2556
a0d0e21e
LW		 2557 if (!ngv)
2558 goto badexit;
2559 if (!ggv)
2560 goto nuts;
2561
2562 gstio = GvIO(ggv);
2563 if (!gstio || !IoIFP(gstio))
2564 goto nuts;
2565
2566 nstio = GvIOn(ngv);
93d47a36 2567 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
e294cc5d
JH		 2568#if defined(OEMVS)
2569 if (len == 0) {
2570 /* Some platforms indicate zero length when an AF_UNIX client is
2571 * not bound. Simulate a non-zero-length sockaddr structure in
2572 * this case. */
2573 namebuf[0] = 0; /* sun_len */
2574 namebuf[1] = AF_UNIX; /* sun_family */
2575 len = 2;
2576 }
2577#endif
2578
a0d0e21e
LW		 2579 if (fd < 0)
2580 goto badexit;
a70048fb
AB		 2581 if (IoIFP(nstio))
2582 do_close(ngv, FALSE);
460c8493
IZ		 2583 IoIFP(nstio) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);
2584 IoOFP(nstio) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
50952442 2585 IoTYPE(nstio) = IoTYPE_SOCKET;
a0d0e21e 2586 if (!IoIFP(nstio) || !IoOFP(nstio)) {
760ac839
LW		 2587 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2588 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
6ad3d225 2589 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
a0d0e21e
LW		 2590 goto badexit;
2591 }
8d2a6795
GS		 2592#if defined(HAS_FCNTL) && defined(F_SETFD)
2593 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2594#endif
a0d0e21e 2595
ed79a026 2596#ifdef EPOC
93d47a36 2597 len = sizeof (struct sockaddr_in); /* EPOC somehow truncates info */
a9f1f6b0 2598 setbuf( IoIFP(nstio), NULL); /* EPOC gets confused about sockets */
ed79a026 2599#endif
381c1bae 2600#ifdef __SCO_VERSION__
93d47a36 2601 len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
381c1bae 2602#endif
ed79a026 2603
93d47a36 2604 PUSHp(namebuf, len);
a0d0e21e
LW		 2605 RETURN;
2606
2607nuts:
599cee73 2608 if (ckWARN(WARN_CLOSED))
bc37a18f 2609 report_evil_fh(ggv, ggv ? GvIO(ggv) : 0, PL_op->op_type);
93189314 2610 SETERRNO(EBADF,SS_IVCHAN);
a0d0e21e
LW		 2611
2612badexit:
2613 RETPUSHUNDEF;
2614
2615#else
cea2e8a9 2616 DIE(aTHX_ PL_no_sock_func, "accept");
a0d0e21e
LW		 2617#endif
2618}
2619
2620PP(pp_shutdown)
2621{
a0d0e21e 2622#ifdef HAS_SOCKET
97aff369 2623 dVAR; dSP; dTARGET;
7452cf6a
AL		 2624 const int how = POPi;
2625 GV * const gv = (GV*)POPs;
2626 register IO * const io = GvIOn(gv);
a0d0e21e
LW		 2627
2628 if (!io || !IoIFP(io))
2629 goto nuts;
2630
6ad3d225 2631 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
a0d0e21e
LW		 2632 RETURN;
2633
2634nuts:
599cee73 2635 if (ckWARN(WARN_CLOSED))
bc37a18f 2636 report_evil_fh(gv, io, PL_op->op_type);
93189314 2637 SETERRNO(EBADF,SS_IVCHAN);
a0d0e21e
LW		 2638 RETPUSHUNDEF;
2639#else
cea2e8a9 2640 DIE(aTHX_ PL_no_sock_func, "shutdown");
a0d0e21e
LW		 2641#endif
2642}
2643
a0d0e21e
LW		 2644PP(pp_ssockopt)
2645{
a0d0e21e 2646#ifdef HAS_SOCKET
97aff369 2647 dVAR; dSP;
7452cf6a 2648 const int optype = PL_op->op_type;
561b68a9 2649 SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
7452cf6a
AL		 2650 const unsigned int optname = (unsigned int) POPi;
2651 const unsigned int lvl = (unsigned int) POPi;
2652 GV * const gv = (GV*)POPs;
2653 register IO * const io = GvIOn(gv);
a0d0e21e 2654 int fd;
1e422769 2655 Sock_size_t len;
a0d0e21e 2656
a0d0e21e
LW		 2657 if (!io || !IoIFP(io))
2658 goto nuts;
2659
760ac839 2660 fd = PerlIO_fileno(IoIFP(io));
a0d0e21e
LW		 2661 switch (optype) {
2662 case OP_GSOCKOPT:
748a9306 2663 SvGROW(sv, 257);
a0d0e21e 2664 (void)SvPOK_only(sv);
748a9306
LW		 2665 SvCUR_set(sv,256);
2666 *SvEND(sv) ='\0';
1e422769 2667 len = SvCUR(sv);
6ad3d225 2668 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
a0d0e21e 2669 goto nuts2;
1e422769 2670 SvCUR_set(sv, len);
748a9306 2671 *SvEND(sv) ='\0';
a0d0e21e
LW		 2672 PUSHs(sv);
2673 break;
2674 case OP_SSOCKOPT: {
1215b447
JH		 2675#if defined(__SYMBIAN32__)
2676# define SETSOCKOPT_OPTION_VALUE_T void *
2677#else
2678# define SETSOCKOPT_OPTION_VALUE_T const char *
2679#endif
2680 /* XXX TODO: We need to have a proper type (a Configure probe,
2681 * etc.) for what the C headers think of the third argument of
2682 * setsockopt(), the option_value read-only buffer: is it
2683 * a "char *", or a "void *", const or not. Some compilers
2684 * don't take kindly to e.g. assuming that "char *" implicitly
2685 * promotes to a "void *", or to explicitly promoting/demoting
2686 * consts to non/vice versa. The "const void *" is the SUS
2687 * definition, but that does not fly everywhere for the above
2688 * reasons. */
2689 SETSOCKOPT_OPTION_VALUE_T buf;
1e422769 2690 int aint;
2691 if (SvPOKp(sv)) {
2d8e6c8d 2692 STRLEN l;
1215b447 2693 buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l);
2d8e6c8d 2694 len = l;
1e422769 2695 }
56ee1660 2696 else {
a0d0e21e 2697 aint = (int)SvIV(sv);
1215b447 2698 buf = (SETSOCKOPT_OPTION_VALUE_T) &aint;
a0d0e21e
LW		 2699 len = sizeof(int);
2700 }
6ad3d225 2701 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
a0d0e21e 2702 goto nuts2;
3280af22 2703 PUSHs(&PL_sv_yes);
a0d0e21e
LW		 2704 }
2705 break;
2706 }
2707 RETURN;
2708
2709nuts:
599cee73 2710 if (ckWARN(WARN_CLOSED))
bc37a18f 2711 report_evil_fh(gv, io, optype);
93189314 2712 SETERRNO(EBADF,SS_IVCHAN);
a0d0e21e
LW		 2713nuts2:
2714 RETPUSHUNDEF;
2715
2716#else
af51a00e 2717 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
a0d0e21e
LW		 2718#endif
2719}
2720
a0d0e21e
LW		 2721PP(pp_getpeername)
2722{
a0d0e21e 2723#ifdef HAS_SOCKET
97aff369 2724 dVAR; dSP;
7452cf6a
AL		 2725 const int optype = PL_op->op_type;
2726 GV * const gv = (GV*)POPs;
2727 register IO * const io = GvIOn(gv);
2728 Sock_size_t len;
a0d0e21e
LW		 2729 SV *sv;
2730 int fd;
a0d0e21e
LW		 2731
2732 if (!io || !IoIFP(io))
2733 goto nuts;
2734
561b68a9 2735 sv = sv_2mortal(newSV(257));
748a9306 2736 (void)SvPOK_only(sv);
1e422769 2737 len = 256;
2738 SvCUR_set(sv, len);
748a9306 2739 *SvEND(sv) ='\0';
760ac839 2740 fd = PerlIO_fileno(IoIFP(io));
a0d0e21e
LW		 2741 switch (optype) {
2742 case OP_GETSOCKNAME:
6ad3d225 2743 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
a0d0e21e
LW		 2744 goto nuts2;
2745 break;
2746 case OP_GETPEERNAME:
6ad3d225 2747 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
a0d0e21e 2748 goto nuts2;
490ab354
JH		 2749#if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2750 {
2751 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";
2752 /* If the call succeeded, make sure we don't have a zeroed port/addr */
349d4f2f 2753 if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2fbb330f 2754 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
490ab354 2755 sizeof(u_short) + sizeof(struct in_addr))) {
301e8125 2756 goto nuts2;
490ab354
JH		 2757 }
2758 }
2759#endif
a0d0e21e
LW		 2760 break;
2761 }
13826f2c
CS		 2762#ifdef BOGUS_GETNAME_RETURN
2763 /* Interactive Unix, getpeername() and getsockname()
2764 does not return valid namelen */
1e422769 2765 if (len == BOGUS_GETNAME_RETURN)
2766 len = sizeof(struct sockaddr);
13826f2c 2767#endif
1e422769 2768 SvCUR_set(sv, len);
748a9306 2769 *SvEND(sv) ='\0';
a0d0e21e
LW		 2770 PUSHs(sv);
2771 RETURN;
2772
2773nuts:
599cee73 2774 if (ckWARN(WARN_CLOSED))
bc37a18f 2775 report_evil_fh(gv, io, optype);
93189314 2776 SETERRNO(EBADF,SS_IVCHAN);
a0d0e21e
LW		 2777nuts2:
2778 RETPUSHUNDEF;
2779
2780#else
af51a00e 2781 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
a0d0e21e
LW		 2782#endif
2783}
2784
2785/* Stat calls. */
2786
a0d0e21e
LW		 2787PP(pp_stat)
2788{
97aff369 2789 dVAR;
39644a26 2790 dSP;
10edeb5d 2791 GV *gv = NULL;
ad02613c 2792 IO *io;
54310121 2793 I32 gimme;
a0d0e21e
LW		 2794 I32 max = 13;
2795
533c011a 2796 if (PL_op->op_flags & OPf_REF) {
2dd78f96 2797 gv = cGVOP_gv;
8a4e5b40 2798 if (PL_op->op_type == OP_LSTAT) {
5d3e98de 2799 if (gv != PL_defgv) {
5d329e6e 2800 do_fstat_warning_check:
5d3e98de 2801 if (ckWARN(WARN_IO))
9014280d 2802 Perl_warner(aTHX_ packWARN(WARN_IO),
38ddb0ef 2803 "lstat() on filehandle %s", gv ? GvENAME(gv) : "");
5d3e98de 2804 } else if (PL_laststype != OP_LSTAT)
8a4e5b40 2805 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
8a4e5b40
DD		 2806 }
2807
748a9306 2808 do_fstat:
2dd78f96 2809 if (gv != PL_defgv) {
3280af22 2810 PL_laststype = OP_STAT;
2dd78f96 2811 PL_statgv = gv;
c69006e4 2812 sv_setpvn(PL_statname, "", 0);
5228a96c 2813 if(gv) {
ad02613c
SP		 2814 io = GvIO(gv);
2815 do_fstat_have_io:
5228a96c
SP		 2816 if (io) {
2817 if (IoIFP(io)) {
2818 PL_laststatval =
2819 PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
2820 } else if (IoDIRP(io)) {
2821#ifdef HAS_DIRFD
2822 PL_laststatval =
2823 PerlLIO_fstat(dirfd(IoDIRP(io)), &PL_statcache);
2824#else
2825 DIE(aTHX_ PL_no_func, "dirfd");
2826#endif
2827 } else {
2828 PL_laststatval = -1;
2829 }
2830 }
2831 }
2832 }
2833
9ddeeac9 2834 if (PL_laststatval < 0) {
2dd78f96
JH		 2835 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2836 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
a0d0e21e 2837 max = 0;
9ddeeac9 2838 }
a0d0e21e
LW		 2839 }
2840 else {
7452cf6a 2841 SV* const sv = POPs;
748a9306 2842 if (SvTYPE(sv) == SVt_PVGV) {
2dd78f96 2843 gv = (GV*)sv;
748a9306 2844 goto do_fstat;
ad02613c
SP		 2845 } else if(SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2846 gv = (GV*)SvRV(sv);
2847 if (PL_op->op_type == OP_LSTAT)
2848 goto do_fstat_warning_check;
2849 goto do_fstat;
2850 } else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2851 io = (IO*)SvRV(sv);
2852 if (PL_op->op_type == OP_LSTAT)
2853 goto do_fstat_warning_check;
2854 goto do_fstat_have_io;
2855 }
2856
0510663f 2857 sv_setpv(PL_statname, SvPV_nolen_const(sv));
a0714e2c 2858 PL_statgv = NULL;
533c011a
NIS		 2859 PL_laststype = PL_op->op_type;
2860 if (PL_op->op_type == OP_LSTAT)
0510663f 2861 PL_laststatval = PerlLIO_lstat(SvPV_nolen_const(PL_statname), &PL_statcache);
a0d0e21e 2862 else
0510663f 2863 PL_laststatval = PerlLIO_stat(SvPV_nolen_const(PL_statname), &PL_statcache);
3280af22 2864 if (PL_laststatval < 0) {
0510663f 2865 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname), '\n'))
9014280d 2866 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
a0d0e21e
LW		 2867 max = 0;
2868 }
2869 }
2870
54310121 2871 gimme = GIMME_V;
2872 if (gimme != G_ARRAY) {
2873 if (gimme != G_VOID)
2874 XPUSHs(boolSV(max));
2875 RETURN;
a0d0e21e
LW		 2876 }
2877 if (max) {
36477c24 2878 EXTEND(SP, max);
2879 EXTEND_MORTAL(max);
1ff81528
PL		 2880 PUSHs(sv_2mortal(newSViv(PL_statcache.st_dev)));
2881 PUSHs(sv_2mortal(newSViv(PL_statcache.st_ino)));
b448e4fe
JH		 2882 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_mode)));
2883 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_nlink)));
146174a9
CB		 2884#if Uid_t_size > IVSIZE
2885 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_uid)));
2886#else
23dcd6c8 2887# if Uid_t_sign <= 0
1ff81528 2888 PUSHs(sv_2mortal(newSViv(PL_statcache.st_uid)));
23dcd6c8
JH		 2889# else
2890 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_uid)));
2891# endif
146174a9 2892#endif
301e8125 2893#if Gid_t_size > IVSIZE
146174a9
CB		 2894 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_gid)));
2895#else
23dcd6c8 2896# if Gid_t_sign <= 0
1ff81528 2897 PUSHs(sv_2mortal(newSViv(PL_statcache.st_gid)));
23dcd6c8
JH		 2898# else
2899 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_gid)));
2900# endif
146174a9 2901#endif
cbdc8872 2902#ifdef USE_STAT_RDEV
1ff81528 2903 PUSHs(sv_2mortal(newSViv(PL_statcache.st_rdev)));
cbdc8872 2904#else
396482e1 2905 PUSHs(sv_2mortal(newSVpvs("")));
cbdc8872 2906#endif
146174a9 2907#if Off_t_size > IVSIZE
4a9d6100 2908 PUSHs(sv_2mortal(newSVnv((NV)PL_statcache.st_size)));
146174a9 2909#else
1ff81528 2910 PUSHs(sv_2mortal(newSViv(PL_statcache.st_size)));
146174a9 2911#endif
cbdc8872 2912#ifdef BIG_TIME
172ae379
JH		 2913 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_atime)));
2914 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_mtime)));
2915 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_ctime)));
cbdc8872 2916#else
aebaba0b
SH		 2917 PUSHs(sv_2mortal(newSViv((IV)PL_statcache.st_atime)));
2918 PUSHs(sv_2mortal(newSViv((IV)PL_statcache.st_mtime)));
2919 PUSHs(sv_2mortal(newSViv((IV)PL_statcache.st_ctime)));
cbdc8872 2920#endif
a0d0e21e 2921#ifdef USE_STAT_BLOCKS
b448e4fe
JH		 2922 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blksize)));
2923 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blocks)));
a0d0e21e 2924#else
396482e1
GA		 2925 PUSHs(sv_2mortal(newSVpvs("")));
2926 PUSHs(sv_2mortal(newSVpvs("")));
a0d0e21e
LW		 2927#endif
2928 }
2929 RETURN;
2930}
2931
fbb0b3b3
RGS		 2932/* This macro is used by the stacked filetest operators :
2933 * if the previous filetest failed, short-circuit and pass its value.
2934 * Else, discard it from the stack and continue. --rgs
2935 */
2936#define STACKED_FTEST_CHECK if (PL_op->op_private & OPpFT_STACKED) { \
2937 if (TOPs == &PL_sv_no || TOPs == &PL_sv_undef) { RETURN; } \
2938 else { (void)POPs; PUTBACK; } \
2939 }
2940
a0d0e21e
LW		 2941PP(pp_ftrread)
2942{
97aff369 2943 dVAR;
9cad6237 2944 I32 result;
af9e49b4
NC		 2945 /* Not const, because things tweak this below. Not bool, because there's
2946 no guarantee that OPp_FT_ACCESS is <= CHAR_MAX */
2947#if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
2948 I32 use_access = PL_op->op_private & OPpFT_ACCESS;
2949 /* Giving some sort of initial value silences compilers. */
2950# ifdef R_OK
2951 int access_mode = R_OK;
2952# else
2953 int access_mode = 0;
2954# endif
5ff3f7a4 2955#else
af9e49b4
NC		 2956 /* access_mode is never used, but leaving use_access in makes the
2957 conditional compiling below much clearer. */
2958 I32 use_access = 0;
5ff3f7a4 2959#endif
af9e49b4 2960 int stat_mode = S_IRUSR;
a0d0e21e 2961
af9e49b4 2962 bool effective = FALSE;
2a3ff820 2963 dSP;
af9e49b4 2964
fbb0b3b3 2965 STACKED_FTEST_CHECK;
af9e49b4
NC		 2966
2967 switch (PL_op->op_type) {
2968 case OP_FTRREAD:
2969#if !(defined(HAS_ACCESS) && defined(R_OK))
2970 use_access = 0;
2971#endif
2972 break;
2973
2974 case OP_FTRWRITE:
5ff3f7a4 2975#if defined(HAS_ACCESS) && defined(W_OK)
af9e49b4 2976 access_mode = W_OK;
5ff3f7a4 2977#else
af9e49b4 2978 use_access = 0;
5ff3f7a4 2979#endif
af9e49b4
NC		 2980 stat_mode = S_IWUSR;
2981 break;
a0d0e21e 2982
af9e49b4 2983 case OP_FTREXEC:
5ff3f7a4 2984#if defined(HAS_ACCESS) && defined(X_OK)
af9e49b4 2985 access_mode = X_OK;
5ff3f7a4 2986#else
af9e49b4 2987 use_access = 0;
5ff3f7a4 2988#endif
af9e49b4
NC		 2989 stat_mode = S_IXUSR;
2990 break;
a0d0e21e 2991
af9e49b4 2992 case OP_FTEWRITE:
faee0e31 2993#ifdef PERL_EFF_ACCESS
af9e49b4 2994 access_mode = W_OK;
5ff3f7a4 2995#endif
af9e49b4
NC		 2996 stat_mode = S_IWUSR;
2997 /* Fall through */
a0d0e21e 2998
af9e49b4
NC		 2999 case OP_FTEREAD:
3000#ifndef PERL_EFF_ACCESS
3001 use_access = 0;
3002#endif
3003 effective = TRUE;
3004 break;
3005
3006
3007 case OP_FTEEXEC:
faee0e31 3008#ifdef PERL_EFF_ACCESS
af9e49b4 3009 access_mode = W_OK;
5ff3f7a4 3010#else
af9e49b4 3011 use_access = 0;
5ff3f7a4 3012#endif
af9e49b4
NC		 3013 stat_mode = S_IXUSR;
3014 effective = TRUE;
3015 break;
3016 }
a0d0e21e 3017
af9e49b4
NC		 3018 if (use_access) {
3019#if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
2c2f35ab 3020 const char *name = POPpx;
af9e49b4
NC		 3021 if (effective) {
3022# ifdef PERL_EFF_ACCESS
3023 result = PERL_EFF_ACCESS(name, access_mode);
3024# else
3025 DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3026 OP_NAME(PL_op));
3027# endif
3028 }
3029 else {
3030# ifdef HAS_ACCESS
3031 result = access(name, access_mode);
3032# else
3033 DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3034# endif
3035 }
5ff3f7a4
GS		 3036 if (result == 0)
3037 RETPUSHYES;
3038 if (result < 0)
3039 RETPUSHUNDEF;
3040 RETPUSHNO;
af9e49b4 3041#endif
22865c03 3042 }
af9e49b4 3043
cea2e8a9 3044 result = my_stat();
22865c03 3045 SPAGAIN;
a0d0e21e
LW		 3046 if (result < 0)
3047 RETPUSHUNDEF;
af9e49b4 3048 if (cando(stat_mode, effective, &PL_statcache))
a0d0e21e
LW		 3049 RETPUSHYES;
3050 RETPUSHNO;
3051}
3052
3053PP(pp_ftis)
3054{
97aff369 3055 dVAR;
fbb0b3b3 3056 I32 result;
d7f0a2f4 3057 const int op_type = PL_op->op_type;
2a3ff820 3058 dSP;
fbb0b3b3
RGS		 3059 STACKED_FTEST_CHECK;
3060 result = my_stat();
3061 SPAGAIN;
a0d0e21e
LW		 3062 if (result < 0)
3063 RETPUSHUNDEF;
d7f0a2f4
NC		 3064 if (op_type == OP_FTIS)
3065 RETPUSHYES;
957b0e1d 3066 {
d7f0a2f4
NC		 3067 /* You can't dTARGET inside OP_FTIS, because you'll get
3068 "panic: pad_sv po" - the op is not flagged to have a target. */
957b0e1d 3069 dTARGET;
d7f0a2f4 3070 switch (op_type) {
957b0e1d
NC		 3071 case OP_FTSIZE:
3072#if Off_t_size > IVSIZE
3073 PUSHn(PL_statcache.st_size);
3074#else
3075 PUSHi(PL_statcache.st_size);
3076#endif
3077 break;
3078 case OP_FTMTIME:
3079 PUSHn( (((NV)PL_basetime - PL_statcache.st_mtime)) / 86400.0 );
3080 break;
3081 case OP_FTATIME:
3082 PUSHn( (((NV)PL_basetime - PL_statcache.st_atime)) / 86400.0 );
3083 break;
3084 case OP_FTCTIME:
3085 PUSHn( (((NV)PL_basetime - PL_statcache.st_ctime)) / 86400.0 );
3086 break;
3087 }
3088 }
3089 RETURN;
a0d0e21e
LW		 3090}
3091
a0d0e21e
LW		 3092PP(pp_ftrowned)
3093{
97aff369 3094 dVAR;
fbb0b3b3 3095 I32 result;
2a3ff820 3096 dSP;
17ad201a
NC		 3097
3098 /* I believe that all these three are likely to be defined on most every
3099 system these days. */
3100#ifndef S_ISUID
3101 if(PL_op->op_type == OP_FTSUID)
3102 RETPUSHNO;
3103#endif
3104#ifndef S_ISGID
3105 if(PL_op->op_type == OP_FTSGID)
3106 RETPUSHNO;
3107#endif
3108#ifndef S_ISVTX
3109 if(PL_op->op_type == OP_FTSVTX)
3110 RETPUSHNO;
3111#endif
3112
fbb0b3b3
RGS		 3113 STACKED_FTEST_CHECK;
3114 result = my_stat();
3115 SPAGAIN;
a0d0e21e
LW		 3116 if (result < 0)
3117 RETPUSHUNDEF;
f1cb2d48
NC		 3118 switch (PL_op->op_type) {
3119 case OP_FTROWNED:
9ab9fa88 3120 if (PL_statcache.st_uid == PL_uid)
f1cb2d48
NC		 3121 RETPUSHYES;
3122 break;
3123 case OP_FTEOWNED:
3124 if (PL_statcache.st_uid == PL_euid)
3125 RETPUSHYES;
3126 break;
3127 case OP_FTZERO:
3128 if (PL_statcache.st_size == 0)
3129 RETPUSHYES;
3130 break;
3131 case OP_FTSOCK:
3132 if (S_ISSOCK(PL_statcache.st_mode))
3133 RETPUSHYES;
3134 break;
3135 case OP_FTCHR:
3136 if (S_ISCHR(PL_statcache.st_mode))
3137 RETPUSHYES;
3138 break;
3139 case OP_FTBLK:
3140 if (S_ISBLK(PL_statcache.st_mode))
3141 RETPUSHYES;
3142 break;
3143 case OP_FTFILE:
3144 if (S_ISREG(PL_statcache.st_mode))
3145 RETPUSHYES;
3146 break;
3147 case OP_FTDIR:
3148 if (S_ISDIR(PL_statcache.st_mode))
3149 RETPUSHYES;
3150 break;
3151 case OP_FTPIPE:
3152 if (S_ISFIFO(PL_statcache.st_mode))
3153 RETPUSHYES;
3154 break;
a0d0e21e 3155#ifdef S_ISUID
17ad201a
NC		 3156 case OP_FTSUID:
3157 if (PL_statcache.st_mode & S_ISUID)
3158 RETPUSHYES;
3159 break;
a0d0e21e 3160#endif
a0d0e21e 3161#ifdef S_ISGID
17ad201a
NC		 3162 case OP_FTSGID:
3163 if (PL_statcache.st_mode & S_ISGID)
3164 RETPUSHYES;
3165 break;
3166#endif
3167#ifdef S_ISVTX
3168 case OP_FTSVTX:
3169 if (PL_statcache.st_mode & S_ISVTX)
3170 RETPUSHYES;
3171 break;
a0d0e21e 3172#endif
17ad201a 3173 }
a0d0e21e
LW		 3174 RETPUSHNO;
3175}
3176
17ad201a 3177PP(pp_ftlink)
a0d0e21e 3178{
97aff369 3179 dVAR;
17ad201a 3180 I32 result = my_lstat();
39644a26 3181 dSP;
a0d0e21e
LW		 3182 if (result < 0)
3183 RETPUSHUNDEF;
17ad201a 3184 if (S_ISLNK(PL_statcache.st_mode))
a0d0e21e 3185 RETPUSHYES;
a0d0e21e
LW		 3186 RETPUSHNO;
3187}
3188
3189PP(pp_fttty)
3190{
97aff369 3191 dVAR;
39644a26 3192 dSP;
a0d0e21e
LW		 3193 int fd;
3194 GV *gv;
a0714e2c 3195 SV *tmpsv = NULL;
fb73857a 3196
fbb0b3b3
RGS		 3197 STACKED_FTEST_CHECK;
3198
533c011a 3199 if (PL_op->op_flags & OPf_REF)
146174a9 3200 gv = cGVOP_gv;
fb73857a 3201 else if (isGV(TOPs))
3202 gv = (GV*)POPs;
3203 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3204 gv = (GV*)SvRV(POPs);
a0d0e21e 3205 else
f776e3cd 3206 gv = gv_fetchsv(tmpsv = POPs, 0, SVt_PVIO);
fb73857a 3207
a0d0e21e 3208 if (GvIO(gv) && IoIFP(GvIOp(gv)))
760ac839 3209 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
7a5fd60d 3210 else if (tmpsv && SvOK(tmpsv)) {
349d4f2f 3211 const char *tmps = SvPV_nolen_const(tmpsv);
7a5fd60d
NC		 3212 if (isDIGIT(*tmps))
3213 fd = atoi(tmps);
3214 else
3215 RETPUSHUNDEF;
3216 }
a0d0e21e
LW		 3217 else
3218 RETPUSHUNDEF;
6ad3d225 3219 if (PerlLIO_isatty(fd))
a0d0e21e
LW		 3220 RETPUSHYES;
3221 RETPUSHNO;
3222}
3223
16d20bd9
AD		 3224#if defined(atarist) /* this will work with atariST. Configure will
3225 make guesses for other systems. */
3226# define FILE_base(f) ((f)->_base)
3227# define FILE_ptr(f) ((f)->_ptr)
3228# define FILE_cnt(f) ((f)->_cnt)
3229# define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
a0d0e21e
LW		 3230#endif
3231
3232PP(pp_fttext)
3233{
97aff369 3234 dVAR;
39644a26 3235 dSP;
a0d0e21e
LW		 3236 I32 i;
3237 I32 len;
3238 I32 odd = 0;
3239 STDCHAR tbuf[512];
3240 register STDCHAR *s;
3241 register IO *io;
5f05dabc 3242 register SV *sv;
3243 GV *gv;
146174a9 3244 PerlIO *fp;
a0d0e21e 3245
fbb0b3b3
RGS		 3246 STACKED_FTEST_CHECK;
3247
533c011a 3248 if (PL_op->op_flags & OPf_REF)
146174a9 3249 gv = cGVOP_gv;
5f05dabc 3250 else if (isGV(TOPs))
3251 gv = (GV*)POPs;
3252 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3253 gv = (GV*)SvRV(POPs);
3254 else
a0714e2c 3255 gv = NULL;
5f05dabc 3256
3257 if (gv) {
a0d0e21e 3258 EXTEND(SP, 1);
3280af22
NIS		 3259 if (gv == PL_defgv) {
3260 if (PL_statgv)
3261 io = GvIO(PL_statgv);
a0d0e21e 3262 else {
3280af22 3263 sv = PL_statname;
a0d0e21e
LW		 3264 goto really_filename;
3265 }
3266 }
3267 else {
3280af22
NIS		 3268 PL_statgv = gv;
3269 PL_laststatval = -1;
c69006e4 3270 sv_setpvn(PL_statname, "", 0);
3280af22 3271 io = GvIO(PL_statgv);
a0d0e21e
LW		 3272 }
3273 if (io && IoIFP(io)) {
5f05dabc 3274 if (! PerlIO_has_base(IoIFP(io)))
cea2e8a9 3275 DIE(aTHX_ "-T and -B not implemented on filehandles");
3280af22
NIS		 3276 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3277 if (PL_laststatval < 0)
5f05dabc 3278 RETPUSHUNDEF;
9cbac4c7 3279 if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
533c011a 3280 if (PL_op->op_type == OP_FTTEXT)
a0d0e21e
LW		 3281 RETPUSHNO;
3282 else
3283 RETPUSHYES;
9cbac4c7 3284 }
a20bf0c3 3285 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
760ac839 3286 i = PerlIO_getc(IoIFP(io));
a0d0e21e 3287 if (i != EOF)
760ac839 3288 (void)PerlIO_ungetc(IoIFP(io),i);
a0d0e21e 3289 }
a20bf0c3 3290 if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
a0d0e21e 3291 RETPUSHYES;
a20bf0c3
JH		 3292 len = PerlIO_get_bufsiz(IoIFP(io));
3293 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
760ac839
LW		 3294 /* sfio can have large buffers - limit to 512 */
3295 if (len > 512)
3296 len = 512;
a0d0e21e
LW		 3297 }
3298 else {
2dd78f96 3299 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
146174a9 3300 gv = cGVOP_gv;
2dd78f96 3301 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
146174a9 3302 }
93189314 3303 SETERRNO(EBADF,RMS_IFI);
a0d0e21e
LW		 3304 RETPUSHUNDEF;
3305 }
3306 }
3307 else {
3308 sv = POPs;
5f05dabc 3309 really_filename:
a0714e2c 3310 PL_statgv = NULL;
5c9aa243 3311 PL_laststype = OP_STAT;
d5263905 3312 sv_setpv(PL_statname, SvPV_nolen_const(sv));
aa07b2f6 3313 if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) {
349d4f2f
NC		 3314 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname),
3315 '\n'))
9014280d 3316 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
a0d0e21e
LW		 3317 RETPUSHUNDEF;
3318 }
146174a9
CB		 3319 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3320 if (PL_laststatval < 0) {
3321 (void)PerlIO_close(fp);
5f05dabc 3322 RETPUSHUNDEF;
146174a9 3323 }
bd61b366 3324 PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
146174a9
CB		 3325 len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3326 (void)PerlIO_close(fp);
a0d0e21e 3327 if (len <= 0) {
533c011a 3328 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
a0d0e21e
LW		 3329 RETPUSHNO; /* special case NFS directories */
3330 RETPUSHYES; /* null file is anything */
3331 }
3332 s = tbuf;
3333 }
3334
3335 /* now scan s to look for textiness */
4633a7c4 3336 /* XXX ASCII dependent code */
a0d0e21e 3337
146174a9
CB		 3338#if defined(DOSISH) || defined(USEMYBINMODE)
3339 /* ignore trailing ^Z on short files */
3340 if (len && len < sizeof(tbuf) && tbuf[len-1] == 26)
3341 --len;
3342#endif
3343
a0d0e21e
LW		 3344 for (i = 0; i < len; i++, s++) {
3345 if (!*s) { /* null never allowed in text */
3346 odd += len;
3347 break;
3348 }
9d116dd7 3349#ifdef EBCDIC
301e8125 3350 else if (!(isPRINT(*s) || isSPACE(*s)))
9d116dd7
JH		 3351 odd++;
3352#else
146174a9
CB		 3353 else if (*s & 128) {
3354#ifdef USE_LOCALE
2de3dbcc 3355 if (IN_LOCALE_RUNTIME && isALPHA_LC(*s))
b3f66c68
GS		 3356 continue;
3357#endif
3358 /* utf8 characters don't count as odd */
fd400ab9 3359 if (UTF8_IS_START(*s)) {
b3f66c68
GS		 3360 int ulen = UTF8SKIP(s);
3361 if (ulen < len - i) {
3362 int j;
3363 for (j = 1; j < ulen; j++) {
fd400ab9 3364 if (!UTF8_IS_CONTINUATION(s[j]))
b3f66c68
GS		 3365 goto not_utf8;
3366 }
3367 --ulen; /* loop does extra increment */
3368 s += ulen;
3369 i += ulen;
3370 continue;
3371 }
3372 }
3373 not_utf8:
3374 odd++;
146174a9 3375 }
a0d0e21e
LW		 3376 else if (*s < 32 &&
3377 *s != '\n' && *s != '\r' && *s != '\b' &&
3378 *s != '\t' && *s != '\f' && *s != 27)
3379 odd++;
9d116dd7 3380#endif
a0d0e21e
LW		 3381 }
3382
533c011a 3383 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
a0d0e21e
LW		 3384 RETPUSHNO;
3385 else
3386 RETPUSHYES;
3387}
3388
a0d0e21e
LW		 3389/* File calls. */
3390
3391PP(pp_chdir)
3392{
97aff369 3393 dVAR; dSP; dTARGET;
c445ea15 3394 const char *tmps = NULL;
9a957fbc 3395 GV *gv = NULL;
a0d0e21e 3396
c4aca7d0 3397 if( MAXARG == 1 ) {
9a957fbc 3398 SV * const sv = POPs;
d4ac975e
GA		 3399 if (PL_op->op_flags & OPf_SPECIAL) {
3400 gv = gv_fetchsv(sv, 0, SVt_PVIO);
3401 }
3402 else if (SvTYPE(sv) == SVt_PVGV) {
c4aca7d0
GA		 3403 gv = (GV*)sv;
3404 }
3405 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
3406 gv = (GV*)SvRV(sv);
3407 }
3408 else {
3409 tmps = SvPVx_nolen_const(sv);
3410 }
3411 }
35ae6b54 3412
c4aca7d0 3413 if( !gv && (!tmps || !*tmps) ) {
9a957fbc
AL		 3414 HV * const table = GvHVn(PL_envgv);
3415 SV **svp;
3416
a4fc7abc
AL		 3417 if ( (svp = hv_fetchs(table, "HOME", FALSE))
3418 || (svp = hv_fetchs(table, "LOGDIR", FALSE))
491527d0 3419#ifdef VMS
a4fc7abc 3420 || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
491527d0 3421#endif
35ae6b54
MS		 3422 )
3423 {
3424 if( MAXARG == 1 )
9014280d 3425 deprecate("chdir('') or chdir(undef) as chdir()");
8c074e2a 3426 tmps = SvPV_nolen_const(*svp);
35ae6b54 3427 }
72f496dc 3428 else {
389ec635 3429 PUSHi(0);
b7ab37f8 3430 TAINT_PROPER("chdir");
389ec635
MS		 3431 RETURN;
3432 }
8ea155d1 3433 }
8ea155d1 3434
a0d0e21e 3435 TAINT_PROPER("chdir");
c4aca7d0
GA		 3436 if (gv) {
3437#ifdef HAS_FCHDIR
9a957fbc 3438 IO* const io = GvIO(gv);
c4aca7d0
GA		 3439 if (io) {
3440 if (IoIFP(io)) {
3441 PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
3442 }
3443 else if (IoDIRP(io)) {
3444#ifdef HAS_DIRFD
3445 PUSHi(fchdir(dirfd(IoDIRP(io))) >= 0);
3446#else
0f1f2428 3447 DIE(aTHX_ PL_no_func, "dirfd");
c4aca7d0
GA		 3448#endif
3449 }
3450 else {
4dc171f0
PD		 3451 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
3452 report_evil_fh(gv, io, PL_op->op_type);
3453 SETERRNO(EBADF, RMS_IFI);
c4aca7d0
GA		 3454 PUSHi(0);
3455 }
3456 }
3457 else {
4dc171f0
PD		 3458 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
3459 report_evil_fh(gv, io, PL_op->op_type);
3460 SETERRNO(EBADF,RMS_IFI);
c4aca7d0
GA		 3461 PUSHi(0);
3462 }
3463#else
3464 DIE(aTHX_ PL_no_func, "fchdir");
3465#endif
3466 }
3467 else
b8ffc8df 3468 PUSHi( PerlDir_chdir(tmps) >= 0 );
748a9306
LW		 3469#ifdef VMS
3470 /* Clear the DEFAULT element of ENV so we'll get the new value
3471 * in the future. */
6b88bc9c 3472 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
748a9306 3473#endif
a0d0e21e
LW		 3474 RETURN;
3475}
3476
3477PP(pp_chown)
3478{
97aff369 3479 dVAR; dSP; dMARK; dTARGET;
605b9385 3480 const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
76ffd3b9 3481
a0d0e21e 3482 SP = MARK;
b59aed67 3483 XPUSHi(value);
a0d0e21e 3484 RETURN;
a0d0e21e
LW		 3485}
3486
3487PP(pp_chroot)
3488{
a0d0e21e 3489#ifdef HAS_CHROOT
97aff369 3490 dVAR; dSP; dTARGET;
7452cf6a 3491 char * const tmps = POPpx;
a0d0e21e
LW		 3492 TAINT_PROPER("chroot");
3493 PUSHi( chroot(tmps) >= 0 );
3494 RETURN;
3495#else
cea2e8a9 3496 DIE(aTHX_ PL_no_func, "chroot");
a0d0e21e
LW		 3497#endif
3498}
3499
a0d0e21e
LW		 3500PP(pp_rename)
3501{
97aff369 3502 dVAR; dSP; dTARGET;
a0d0e21e 3503 int anum;
7452cf6a
AL		 3504 const char * const tmps2 = POPpconstx;
3505 const char * const tmps = SvPV_nolen_const(TOPs);
a0d0e21e
LW		 3506 TAINT_PROPER("rename");
3507#ifdef HAS_RENAME
baed7233 3508 anum = PerlLIO_rename(tmps, tmps2);
a0d0e21e 3509#else
6b88bc9c 3510 if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
ed969818
W		 3511 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3512 anum = 1;
3513 else {
3654eb6c 3514 if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
ed969818
W		 3515 (void)UNLINK(tmps2);
3516 if (!(anum = link(tmps, tmps2)))
3517 anum = UNLINK(tmps);
3518 }
a0d0e21e
LW		 3519 }
3520#endif
3521 SETi( anum >= 0 );
3522 RETURN;
3523}
3524
ce6987d0 3525#if defined(HAS_LINK) || defined(HAS_SYMLINK)
a0d0e21e
LW		 3526PP(pp_link)
3527{
97aff369 3528 dVAR; dSP; dTARGET;
ce6987d0
NC		 3529 const int op_type = PL_op->op_type;
3530 int result;
a0d0e21e 3531
ce6987d0
NC		 3532# ifndef HAS_LINK
3533 if (op_type == OP_LINK)
3534 DIE(aTHX_ PL_no_func, "link");
3535# endif
3536# ifndef HAS_SYMLINK
3537 if (op_type == OP_SYMLINK)
3538 DIE(aTHX_ PL_no_func, "symlink");
3539# endif
3540
3541 {
7452cf6a
AL		 3542 const char * const tmps2 = POPpconstx;
3543 const char * const tmps = SvPV_nolen_const(TOPs);
ce6987d0
NC		 3544 TAINT_PROPER(PL_op_desc[op_type]);
3545 result =
3546# if defined(HAS_LINK)
3547# if defined(HAS_SYMLINK)
3548 /* Both present - need to choose which. */
3549 (op_type == OP_LINK) ?
3550 PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3551# else
4a8ebb7f
SH		 3552 /* Only have link, so calls to pp_symlink will have DIE()d above. */
3553 PerlLIO_link(tmps, tmps2);
ce6987d0
NC		 3554# endif
3555# else
3556# if defined(HAS_SYMLINK)
4a8ebb7f
SH		 3557 /* Only have symlink, so calls to pp_link will have DIE()d above. */
3558 symlink(tmps, tmps2);
ce6987d0
NC		 3559# endif
3560# endif
3561 }
3562
3563 SETi( result >= 0 );
a0d0e21e 3564 RETURN;
ce6987d0 3565}
a0d0e21e 3566#else
ce6987d0
NC		 3567PP(pp_link)
3568{
3569 /* Have neither. */
3570 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
a0d0e21e 3571}
ce6987d0 3572#endif
a0d0e21e
LW		 3573
3574PP(pp_readlink)
3575{
97aff369 3576 dVAR;
76ffd3b9 3577 dSP;
a0d0e21e 3578#ifdef HAS_SYMLINK
76ffd3b9 3579 dTARGET;
10516c54 3580 const char *tmps;
46fc3d4c 3581 char buf[MAXPATHLEN];
a0d0e21e 3582 int len;
46fc3d4c 3583
fb73857a 3584#ifndef INCOMPLETE_TAINTS
3585 TAINT;
3586#endif
10516c54 3587 tmps = POPpconstx;
97dcea33 3588 len = readlink(tmps, buf, sizeof(buf) - 1);
a0d0e21e
LW		 3589 EXTEND(SP, 1);
3590 if (len < 0)
3591 RETPUSHUNDEF;
3592 PUSHp(buf, len);
3593 RETURN;
3594#else
3595 EXTEND(SP, 1);
3596 RETSETUNDEF; /* just pretend it's a normal file */
3597#endif
3598}
3599
3600#if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
ba106d47 3601STATIC int
b464bac0 3602S_dooneliner(pTHX_ const char *cmd, const char *filename)
a0d0e21e 3603{
b464bac0 3604 char * const save_filename = filename;
1e422769 3605 char *cmdline;
3606 char *s;
760ac839 3607 PerlIO *myfp;
1e422769 3608 int anum = 1;
6fca0082 3609 Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
a0d0e21e 3610
6fca0082
SP		 3611 Newx(cmdline, size, char);
3612 my_strlcpy(cmdline, cmd, size);
3613 my_strlcat(cmdline, " ", size);
1e422769 3614 for (s = cmdline + strlen(cmdline); *filename; ) {
a0d0e21e
LW		 3615 *s++ = '\\';
3616 *s++ = *filename++;
3617 }
d1307786
JH		 3618 if (s - cmdline < size)
3619 my_strlcpy(s, " 2>&1", size - (s - cmdline));
6ad3d225 3620 myfp = PerlProc_popen(cmdline, "r");
1e422769 3621 Safefree(cmdline);
3622
a0d0e21e 3623 if (myfp) {
0bcc34c2 3624 SV * const tmpsv = sv_newmortal();
6b88bc9c 3625 /* Need to save/restore 'PL_rs' ?? */
760ac839 3626 s = sv_gets(tmpsv, myfp, 0);
6ad3d225 3627 (void)PerlProc_pclose(myfp);
bd61b366 3628 if (s != NULL) {
1e422769 3629 int e;
3630 for (e = 1;
a0d0e21e 3631#ifdef HAS_SYS_ERRLIST
1e422769 3632 e <= sys_nerr
3633#endif
3634 ; e++)
3635 {
3636 /* you don't see this */
6136c704 3637 const char * const errmsg =
1e422769 3638#ifdef HAS_SYS_ERRLIST
3639 sys_errlist[e]
a0d0e21e 3640#else
1e422769 3641 strerror(e)
a0d0e21e 3642#endif
1e422769 3643 ;
3644 if (!errmsg)
3645 break;
3646 if (instr(s, errmsg)) {
3647 SETERRNO(e,0);
3648 return 0;
3649 }
a0d0e21e 3650 }
748a9306 3651 SETERRNO(0,0);
a0d0e21e
LW		 3652#ifndef EACCES
3653#define EACCES EPERM
3654#endif
1e422769 3655 if (instr(s, "cannot make"))
93189314 3656 SETERRNO(EEXIST,RMS_FEX);
1e422769 3657 else if (instr(s, "existing file"))
93189314 3658 SETERRNO(EEXIST,RMS_FEX);
1e422769 3659 else if (instr(s, "ile exists"))
93189314 3660 SETERRNO(EEXIST,RMS_FEX);
1e422769 3661 else if (instr(s, "non-exist"))
93189314 3662 SETERRNO(ENOENT,RMS_FNF);
1e422769 3663 else if (instr(s, "does not exist"))
93189314 3664 SETERRNO(ENOENT,RMS_FNF);
1e422769 3665 else if (instr(s, "not empty"))
93189314 3666 SETERRNO(EBUSY,SS_DEVOFFLINE);
1e422769 3667 else if (instr(s, "cannot access"))
93189314 3668 SETERRNO(EACCES,RMS_PRV);
a0d0e21e 3669 else
93189314 3670 SETERRNO(EPERM,RMS_PRV);
a0d0e21e
LW		 3671 return 0;
3672 }
3673 else { /* some mkdirs return no failure indication */
6b88bc9c 3674 anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
911d147d 3675 if (PL_op->op_type == OP_RMDIR)
a0d0e21e
LW		 3676 anum = !anum;
3677 if (anum)
748a9306 3678 SETERRNO(0,0);
a0d0e21e 3679 else
93189314 3680 SETERRNO(EACCES,RMS_PRV); /* a guess */
a0d0e21e
LW		 3681 }
3682 return anum;
3683 }
3684 else
3685 return 0;
3686}
3687#endif
3688
0c54f65b
RGS		 3689/* This macro removes trailing slashes from a directory name.
3690 * Different operating and file systems take differently to
3691 * trailing slashes. According to POSIX 1003.1 1996 Edition
3692 * any number of trailing slashes should be allowed.
3693 * Thusly we snip them away so that even non-conforming
3694 * systems are happy.
3695 * We should probably do this "filtering" for all
3696 * the functions that expect (potentially) directory names:
3697 * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3698 * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3699
5c144d81 3700#define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
0c54f65b
RGS		 3701 if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3702 do { \
3703 (len)--; \
3704 } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3705 (tmps) = savepvn((tmps), (len)); \
3706 (copy) = TRUE; \
3707 }
3708
a0d0e21e
LW		 3709PP(pp_mkdir)
3710{
97aff369 3711 dVAR; dSP; dTARGET;
df25ddba 3712 STRLEN len;
5c144d81 3713 const char *tmps;
df25ddba 3714 bool copy = FALSE;
7452cf6a 3715 const int mode = (MAXARG > 1) ? POPi : 0777;
5a211162 3716
0c54f65b 3717 TRIMSLASHES(tmps,len,copy);
a0d0e21e
LW		 3718
3719 TAINT_PROPER("mkdir");
3720#ifdef HAS_MKDIR
b8ffc8df 3721 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
a0d0e21e 3722#else
0bcc34c2
AL		 3723 {
3724 int oldumask;
a0d0e21e 3725 SETi( dooneliner("mkdir", tmps) );
6ad3d225
GS		 3726 oldumask = PerlLIO_umask(0);
3727 PerlLIO_umask(oldumask);
3728 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
0bcc34c2 3729 }
a0d0e21e 3730#endif
df25ddba
JH		 3731 if (copy)
3732 Safefree(tmps);
a0d0e21e
LW		 3733 RETURN;
3734}
3735
3736PP(pp_rmdir)
3737{
97aff369 3738 dVAR; dSP; dTARGET;
0c54f65b 3739 STRLEN len;
5c144d81 3740 const char *tmps;
0c54f65b 3741 bool copy = FALSE;
a0d0e21e 3742
0c54f65b 3743 TRIMSLASHES(tmps,len,copy);
a0d0e21e
LW		 3744 TAINT_PROPER("rmdir");
3745#ifdef HAS_RMDIR
b8ffc8df 3746 SETi( PerlDir_rmdir(tmps) >= 0 );
a0d0e21e 3747#else
0c54f65b 3748 SETi( dooneliner("rmdir", tmps) );
a0d0e21e 3749#endif
0c54f65b
RGS		 3750 if (copy)
3751 Safefree(tmps);
a0d0e21e
LW		 3752 RETURN;
3753}
3754
3755/* Directory calls. */
3756
3757PP(pp_open_dir)
3758{
a0d0e21e 3759#if defined(Direntry_t) && defined(HAS_READDIR)
97aff369 3760 dVAR; dSP;
7452cf6a
AL		 3761 const char * const dirname = POPpconstx;
3762 GV * const gv = (GV*)POPs;
3763 register IO * const io = GvIOn(gv);
a0d0e21e
LW		 3764
3765 if (!io)
3766 goto nope;
3767
3768 if (IoDIRP(io))
6ad3d225 3769 PerlDir_close(IoDIRP(io));
b8ffc8df 3770 if (!(IoDIRP(io) = PerlDir_open(dirname)))
a0d0e21e
LW		 3771 goto nope;
3772
3773 RETPUSHYES;
3774nope:
3775 if (!errno)
93189314 3776 SETERRNO(EBADF,RMS_DIR);
a0d0e21e
LW		 3777 RETPUSHUNDEF;
3778#else
cea2e8a9 3779 DIE(aTHX_ PL_no_dir_func, "opendir");
a0d0e21e
LW		 3780#endif
3781}
3782
3783PP(pp_readdir)
3784{
34b7f128
AMS		 3785#if !defined(Direntry_t) || !defined(HAS_READDIR)
3786 DIE(aTHX_ PL_no_dir_func, "readdir");
3787#else
fd8cd3a3 3788#if !defined(I_DIRENT) && !defined(VMS)
20ce7b12 3789 Direntry_t *readdir (DIR *);
a0d0e21e 3790#endif
97aff369 3791 dVAR;
34b7f128
AMS		 3792 dSP;
3793
3794 SV *sv;
f54cb97a 3795 const I32 gimme = GIMME;
7452cf6a
AL		 3796 GV * const gv = (GV *)POPs;
3797 register const Direntry_t *dp;
3798 register IO * const io = GvIOn(gv);
a0d0e21e 3799
3b7fbd4a
SP		 3800 if (!io || !IoDIRP(io)) {
3801 if(ckWARN(WARN_IO)) {
3802 Perl_warner(aTHX_ packWARN(WARN_IO),
3803 "readdir() attempted on invalid dirhandle %s", GvENAME(gv));
3804 }
3805 goto nope;
3806 }
a0d0e21e 3807
34b7f128
AMS		 3808 do {
3809 dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
3810 if (!dp)
3811 break;
a0d0e21e 3812#ifdef DIRNAMLEN
34b7f128 3813 sv = newSVpvn(dp->d_name, dp->d_namlen);
a0d0e21e 3814#else
34b7f128 3815 sv = newSVpv(dp->d_name, 0);
fb73857a 3816#endif
3817#ifndef INCOMPLETE_TAINTS
34b7f128
AMS		 3818 if (!(IoFLAGS(io) & IOf_UNTAINT))
3819 SvTAINTED_on(sv);
a0d0e21e 3820#endif
34b7f128 3821 XPUSHs(sv_2mortal(sv));
a79db61d 3822 } while (gimme == G_ARRAY);
34b7f128
AMS		 3823
3824 if (!dp && gimme != G_ARRAY)
3825 goto nope;
3826
a0d0e21e
LW		 3827 RETURN;
3828
3829nope:
3830 if (!errno)
93189314 3831 SETERRNO(EBADF,RMS_ISI);
a0d0e21e
LW		 3832 if (GIMME == G_ARRAY)
3833 RETURN;
3834 else
3835 RETPUSHUNDEF;
a0d0e21e
LW		 3836#endif
3837}
3838
3839PP(pp_telldir)
3840{
a0d0e21e 3841#if defined(HAS_TELLDIR) || defined(telldir)
27da23d5 3842 dVAR; dSP; dTARGET;
968dcd91
JH		 3843 /* XXX does _anyone_ need this? --AD 2/20/1998 */
3844 /* XXX netbsd still seemed to.
3845 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3846 --JHI 1999-Feb-02 */
3847# if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
20ce7b12 3848 long telldir (DIR *);
dfe9444c 3849# endif
7452cf6a
AL		 3850 GV * const gv = (GV*)POPs;
3851 register IO * const io = GvIOn(gv);
a0d0e21e 3852
abc7ecad
SP		 3853 if (!io || !IoDIRP(io)) {
3854 if(ckWARN(WARN_IO)) {
3855 Perl_warner(aTHX_ packWARN(WARN_IO),
3856 "telldir() attempted on invalid dirhandle %s", GvENAME(gv));
3857 }
3858 goto nope;
3859 }
a0d0e21e 3860
6ad3d225 3861 PUSHi( PerlDir_tell(IoDIRP(io)) );
a0d0e21e
LW		 3862 RETURN;
3863nope:
3864 if (!errno)
93189314 3865 SETERRNO(EBADF,RMS_ISI);
a0d0e21e
LW		 3866 RETPUSHUNDEF;
3867#else
cea2e8a9 3868 DIE(aTHX_ PL_no_dir_func, "telldir");
a0d0e21e
LW		 3869#endif
3870}
3871
3872PP(pp_seekdir)
3873{
a0d0e21e 3874#if defined(HAS_SEEKDIR) || defined(seekdir)
97aff369 3875 dVAR; dSP;
7452cf6a
AL		 3876 const long along = POPl;
3877 GV * const gv = (GV*)POPs;
3878 register IO * const io = GvIOn(gv);
a0d0e21e 3879
abc7ecad
SP		 3880 if (!io || !IoDIRP(io)) {
3881 if(ckWARN(WARN_IO)) {
3882 Perl_warner(aTHX_ packWARN(WARN_IO),
3883 "seekdir() attempted on invalid dirhandle %s", GvENAME(gv));
3884 }
3885 goto nope;
3886 }
6ad3d225 3887 (void)PerlDir_seek(IoDIRP(io), along);
a0d0e21e
LW		 3888
3889 RETPUSHYES;
3890nope:
3891 if (!errno)
93189314 3892 SETERRNO(EBADF,RMS_ISI);
a0d0e21e
LW		 3893 RETPUSHUNDEF;
3894#else
cea2e8a9 3895 DIE(aTHX_ PL_no_dir_func, "seekdir");
a0d0e21e
LW		 3896#endif
3897}
3898
3899PP(pp_rewinddir)
3900{
a0d0e21e 3901#if defined(HAS_REWINDDIR) || defined(rewinddir)
97aff369 3902 dVAR; dSP;
7452cf6a
AL		 3903 GV * const gv = (GV*)POPs;
3904 register IO * const io = GvIOn(gv);
a0d0e21e 3905
abc7ecad
SP		 3906 if (!io || !IoDIRP(io)) {
3907 if(ckWARN(WARN_IO)) {
3908 Perl_warner(aTHX_ packWARN(WARN_IO),
3909 "rewinddir() attempted on invalid dirhandle %s", GvENAME(gv));
3910 }
a0d0e21e 3911 goto nope;
abc7ecad 3912 }
6ad3d225 3913 (void)PerlDir_rewind(IoDIRP(io));
a0d0e21e
LW		 3914 RETPUSHYES;
3915nope:
3916 if (!errno)
93189314 3917 SETERRNO(EBADF,RMS_ISI);
a0d0e21e
LW		 3918 RETPUSHUNDEF;
3919#else
cea2e8a9 3920 DIE(aTHX_ PL_no_dir_func, "rewinddir");
a0d0e21e
LW		 3921#endif
3922}
3923
3924PP(pp_closedir)
3925{
a0d0e21e 3926#if defined(Direntry_t) && defined(HAS_READDIR)
97aff369 3927 dVAR; dSP;
7452cf6a
AL		 3928 GV * const gv = (GV*)POPs;
3929 register IO * const io = GvIOn(gv);
a0d0e21e 3930
abc7ecad
SP		 3931 if (!io || !IoDIRP(io)) {
3932 if(ckWARN(WARN_IO)) {
3933 Perl_warner(aTHX_ packWARN(WARN_IO),
3934 "closedir() attempted on invalid dirhandle %s", GvENAME(gv));
3935 }
3936 goto nope;
3937 }
a0d0e21e 3938#ifdef VOID_CLOSEDIR
6ad3d225 3939 PerlDir_close(IoDIRP(io));
a0d0e21e 3940#else
6ad3d225 3941 if (PerlDir_close(IoDIRP(io)) < 0) {
748a9306 3942 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
a0d0e21e 3943 goto nope;
748a9306 3944 }
a0d0e21e
LW		 3945#endif
3946 IoDIRP(io) = 0;
3947
3948 RETPUSHYES;
3949nope:
3950 if (!errno)
93189314 3951 SETERRNO(EBADF,RMS_IFI);
a0d0e21e
LW		 3952 RETPUSHUNDEF;
3953#else
cea2e8a9 3954 DIE(aTHX_ PL_no_dir_func, "closedir");
a0d0e21e
LW		 3955#endif
3956}
3957
3958/* Process control. */
3959
3960PP(pp_fork)
3961{
44a8e56a 3962#ifdef HAS_FORK
97aff369 3963 dVAR; dSP; dTARGET;
761237fe 3964 Pid_t childpid;
a0d0e21e
LW		 3965
3966 EXTEND(SP, 1);
45bc9206 3967 PERL_FLUSHALL_FOR_CHILD;
52e18b1f 3968 childpid = PerlProc_fork();
a0d0e21e
LW		 3969 if (childpid < 0)
3970 RETSETUNDEF;
3971 if (!childpid) {
fafc274c 3972 GV * const tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV);
7452cf6a 3973 if (tmpgv) {
306196c3 3974 SvREADONLY_off(GvSV(tmpgv));
146174a9 3975 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
306196c3
MS		 3976 SvREADONLY_on(GvSV(tmpgv));
3977 }
4d76a344
RGS		 3978#ifdef THREADS_HAVE_PIDS
3979 PL_ppid = (IV)getppid();
3980#endif
ca0c25f6 3981#ifdef PERL_USES_PL_PIDSTATUS
3280af22 3982 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
ca0c25f6 3983#endif
a0d0e21e
LW		 3984 }
3985 PUSHi(childpid);
3986 RETURN;
3987#else
146174a9 3988# if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
39644a26 3989 dSP; dTARGET;
146174a9
CB		 3990 Pid_t childpid;
3991
3992 EXTEND(SP, 1);
3993 PERL_FLUSHALL_FOR_CHILD;
3994 childpid = PerlProc_fork();
60fa28ff
GS		 3995 if (childpid == -1)
3996 RETSETUNDEF;
146174a9
CB		 3997 PUSHi(childpid);
3998 RETURN;
3999# else
0322a713 4000 DIE(aTHX_ PL_no_func, "fork");
146174a9 4001# endif
a0d0e21e
LW		 4002#endif
4003}
4004
4005PP(pp_wait)
4006{
301e8125 4007#if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
97aff369 4008 dVAR; dSP; dTARGET;
761237fe 4009 Pid_t childpid;
a0d0e21e 4010 int argflags;
a0d0e21e 4011
4ffa73a3
JH		 4012 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4013 childpid = wait4pid(-1, &argflags, 0);
4014 else {
4015 while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4016 errno == EINTR) {
4017 PERL_ASYNC_CHECK();
4018 }
0a0ada86 4019 }
68a29c53
GS		 4020# if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4021 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
2fbb330f 4022 STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
68a29c53 4023# else
2fbb330f 4024 STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
68a29c53 4025# endif
44a8e56a 4026 XPUSHi(childpid);
a0d0e21e
LW		 4027 RETURN;
4028#else
0322a713 4029 DIE(aTHX_ PL_no_func, "wait");
a0d0e21e
LW		 4030#endif
4031}
4032
4033PP(pp_waitpid)
4034{
301e8125 4035#if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
97aff369 4036 dVAR; dSP; dTARGET;
0bcc34c2
AL		 4037 const int optype = POPi;
4038 const Pid_t pid = TOPi;
2ec0bfb3 4039 Pid_t result;
a0d0e21e 4040 int argflags;
a0d0e21e 4041
4ffa73a3 4042 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2ec0bfb3 4043 result = wait4pid(pid, &argflags, optype);
4ffa73a3 4044 else {
2ec0bfb3 4045 while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4ffa73a3
JH		 4046 errno == EINTR) {
4047 PERL_ASYNC_CHECK();
4048 }
0a0ada86 4049 }
68a29c53
GS		 4050# if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4051 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
2fbb330f 4052 STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
68a29c53 4053# else
2fbb330f 4054 STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
68a29c53 4055# endif
2ec0bfb3 4056 SETi(result);
a0d0e21e
LW		 4057 RETURN;
4058#else
0322a713 4059 DIE(aTHX_ PL_no_func, "waitpid");
a0d0e21e
LW		 4060#endif
4061}
4062
4063PP(pp_system)
4064{
97aff369 4065 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e 4066 I32 value;
76ffd3b9 4067 int result;
a0d0e21e 4068
bbd7eb8a
RD		 4069 if (PL_tainting) {
4070 TAINT_ENV();
4071 while (++MARK <= SP) {
10516c54 4072 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
5a445156 4073 if (PL_tainted)
bbd7eb8a
RD		 4074 break;
4075 }
4076 MARK = ORIGMARK;
5a445156 4077 TAINT_PROPER("system");
a0d0e21e 4078 }
45bc9206 4079 PERL_FLUSHALL_FOR_CHILD;
273b0206 4080#if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
d7e492a4 4081 {
eb160463
GS		 4082 Pid_t childpid;
4083 int pp[2];
27da23d5 4084 I32 did_pipes = 0;
eb160463
GS		 4085
4086 if (PerlProc_pipe(pp) >= 0)
4087 did_pipes = 1;
4088 while ((childpid = PerlProc_fork()) == -1) {
4089 if (errno != EAGAIN) {
4090 value = -1;
4091 SP = ORIGMARK;
b59aed67 4092 XPUSHi(value);
eb160463
GS		 4093 if (did_pipes) {
4094 PerlLIO_close(pp[0]);
4095 PerlLIO_close(pp[1]);
4096 }
4097 RETURN;
4098 }
4099 sleep(5);
4100 }
4101 if (childpid > 0) {
4102 Sigsave_t ihand,qhand; /* place to save signals during system() */
4103 int status;
4104
4105 if (did_pipes)
4106 PerlLIO_close(pp[1]);
64ca3a65 4107#ifndef PERL_MICRO
8aad04aa
JH		 4108 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &ihand);
4109 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
64ca3a65 4110#endif
eb160463
GS		 4111 do {
4112 result = wait4pid(childpid, &status, 0);
4113 } while (result == -1 && errno == EINTR);
64ca3a65 4114#ifndef PERL_MICRO
eb160463
GS		 4115 (void)rsignal_restore(SIGINT, &ihand);
4116 (void)rsignal_restore(SIGQUIT, &qhand);
4117#endif
37038d91 4118 STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
eb160463
GS		 4119 do_execfree(); /* free any memory child malloced on fork */
4120 SP = ORIGMARK;
4121 if (did_pipes) {
4122 int errkid;
bb7a0f54
MHM		 4123 unsigned n = 0;
4124 SSize_t n1;
eb160463
GS		 4125
4126 while (n < sizeof(int)) {
4127 n1 = PerlLIO_read(pp[0],
4128 (void*)(((char*)&errkid)+n),
4129 (sizeof(int)) - n);
4130 if (n1 <= 0)
4131 break;
4132 n += n1;
4133 }
4134 PerlLIO_close(pp[0]);
4135 if (n) { /* Error */
4136 if (n != sizeof(int))
4137 DIE(aTHX_ "panic: kid popen errno read");
4138 errno = errkid; /* Propagate errno from kid */
37038d91 4139 STATUS_NATIVE_CHILD_SET(-1);
eb160463
GS		 4140 }
4141 }
b59aed67 4142 XPUSHi(STATUS_CURRENT);
eb160463
GS		 4143 RETURN;
4144 }
4145 if (did_pipes) {
4146 PerlLIO_close(pp[0]);
d5a9bfb0 4147#if defined(HAS_FCNTL) && defined(F_SETFD)
eb160463 4148 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
d5a9bfb0 4149#endif
eb160463 4150 }
e0a1f643 4151 if (PL_op->op_flags & OPf_STACKED) {
0bcc34c2 4152 SV * const really = *++MARK;
e0a1f643
JH		 4153 value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4154 }
4155 else if (SP - MARK != 1)
a0714e2c 4156 value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
e0a1f643 4157 else {
8c074e2a 4158 value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
e0a1f643
JH		 4159 }
4160 PerlProc__exit(-1);
d5a9bfb0 4161 }
c3293030 4162#else /* ! FORK or VMS or OS/2 */
922b1888
GS		 4163 PL_statusvalue = 0;
4164 result = 0;
911d147d 4165 if (PL_op->op_flags & OPf_STACKED) {
0bcc34c2 4166 SV * const really = *++MARK;
a0fd4948 4167# if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__)
54725af6
GS		 4168 value = (I32)do_aspawn(really, MARK, SP);
4169# else
c5be433b 4170 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
54725af6 4171# endif
a0d0e21e 4172 }
54725af6 4173 else if (SP - MARK != 1) {
a0fd4948 4174# if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__)
a0714e2c 4175 value = (I32)do_aspawn(NULL, MARK, SP);
54725af6 4176# else
a0714e2c 4177 value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
54725af6
GS		 4178# endif
4179 }
a0d0e21e 4180 else {
8c074e2a 4181 value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
a0d0e21e 4182 }
922b1888
GS		 4183 if (PL_statusvalue == -1) /* hint that value must be returned as is */
4184 result = 1;
2fbb330f 4185 STATUS_NATIVE_CHILD_SET(value);
a0d0e21e
LW		 4186 do_execfree();
4187 SP = ORIGMARK;
b59aed67 4188 XPUSHi(result ? value : STATUS_CURRENT);
a0d0e21e
LW		 4189#endif /* !FORK or VMS */
4190 RETURN;
4191}
4192
4193PP(pp_exec)
4194{
97aff369 4195 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW		 4196 I32 value;
4197
bbd7eb8a
RD		 4198 if (PL_tainting) {
4199 TAINT_ENV();
4200 while (++MARK <= SP) {
10516c54 4201 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
5a445156 4202 if (PL_tainted)
bbd7eb8a
RD		 4203 break;
4204 }
4205 MARK = ORIGMARK;
5a445156 4206 TAINT_PROPER("exec");
bbd7eb8a 4207 }
45bc9206 4208 PERL_FLUSHALL_FOR_CHILD;
533c011a 4209 if (PL_op->op_flags & OPf_STACKED) {
0bcc34c2 4210 SV * const really = *++MARK;
a0d0e21e
LW		 4211 value = (I32)do_aexec(really, MARK, SP);
4212 }
4213 else if (SP - MARK != 1)
4214#ifdef VMS
a0714e2c 4215 value = (I32)vms_do_aexec(NULL, MARK, SP);
a0d0e21e 4216#else
092bebab
JH		 4217# ifdef __OPEN_VM
4218 {
a0714e2c 4219 (void ) do_aspawn(NULL, MARK, SP);
092bebab
JH		 4220 value = 0;
4221 }
4222# else
a0714e2c 4223 value = (I32)do_aexec(NULL, MARK, SP);
092bebab 4224# endif
a0d0e21e
LW		 4225#endif
4226 else {
a0d0e21e 4227#ifdef VMS
8c074e2a 4228 value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
a0d0e21e 4229#else
092bebab 4230# ifdef __OPEN_VM
8c074e2a 4231 (void) do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
092bebab
JH		 4232 value = 0;
4233# else
8c074e2a 4234 value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
092bebab 4235# endif
a0d0e21e
LW		 4236#endif
4237 }
146174a9 4238
a0d0e21e 4239 SP = ORIGMARK;
b59aed67 4240 XPUSHi(value);
a0d0e21e
LW		 4241 RETURN;
4242}
4243
a0d0e21e
LW		 4244PP(pp_getppid)
4245{
4246#ifdef HAS_GETPPID
97aff369 4247 dVAR; dSP; dTARGET;
4d76a344 4248# ifdef THREADS_HAVE_PIDS
e39f92a7
RGS		 4249 if (PL_ppid != 1 && getppid() == 1)
4250 /* maybe the parent process has died. Refresh ppid cache */
4251 PL_ppid = 1;
4d76a344
RGS		 4252 XPUSHi( PL_ppid );
4253# else
a0d0e21e 4254 XPUSHi( getppid() );
4d76a344 4255# endif
a0d0e21e
LW		 4256 RETURN;
4257#else
cea2e8a9 4258 DIE(aTHX_ PL_no_func, "getppid");
a0d0e21e
LW		 4259#endif
4260}
4261
4262PP(pp_getpgrp)
4263{
4264#ifdef HAS_GETPGRP
97aff369 4265 dVAR; dSP; dTARGET;
9853a804 4266 Pid_t pgrp;
0bcc34c2 4267 const Pid_t pid = (MAXARG < 1) ? 0 : SvIVx(POPs);
a0d0e21e 4268
c3293030 4269#ifdef BSD_GETPGRP
9853a804 4270 pgrp = (I32)BSD_GETPGRP(pid);
a0d0e21e 4271#else
146174a9 4272 if (pid != 0 && pid != PerlProc_getpid())
cea2e8a9 4273 DIE(aTHX_ "POSIX getpgrp can't take an argument");
9853a804 4274 pgrp = getpgrp();
a0d0e21e 4275#endif
9853a804 4276 XPUSHi(pgrp);
a0d0e21e
LW		 4277 RETURN;
4278#else
cea2e8a9 4279 DIE(aTHX_ PL_no_func, "getpgrp()");
a0d0e21e
LW		 4280#endif
4281}
4282
4283PP(pp_setpgrp)
4284{
4285#ifdef HAS_SETPGRP
97aff369 4286 dVAR; dSP; dTARGET;
d8a83dd3
JH		 4287 Pid_t pgrp;
4288 Pid_t pid;
a0d0e21e
LW		 4289 if (MAXARG < 2) {
4290 pgrp = 0;
4291 pid = 0;
4292 }
4293 else {
4294 pgrp = POPi;
4295 pid = TOPi;
4296 }
4297
4298 TAINT_PROPER("setpgrp");
c3293030
IZ		 4299#ifdef BSD_SETPGRP
4300 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
a0d0e21e 4301#else
146174a9
CB		 4302 if ((pgrp != 0 && pgrp != PerlProc_getpid())
4303 || (pid != 0 && pid != PerlProc_getpid()))
4304 {
4305 DIE(aTHX_ "setpgrp can't take arguments");
4306 }
a0d0e21e
LW		 4307 SETi( setpgrp() >= 0 );
4308#endif /* USE_BSDPGRP */
4309 RETURN;
4310#else
cea2e8a9 4311 DIE(aTHX_ PL_no_func, "setpgrp()");
a0d0e21e
LW		 4312#endif
4313}
4314
4315PP(pp_getpriority)
4316{
a0d0e21e 4317#ifdef HAS_GETPRIORITY
97aff369 4318 dVAR; dSP; dTARGET;
0bcc34c2
AL		 4319 const int who = POPi;
4320 const int which = TOPi;
a0d0e21e
LW		 4321 SETi( getpriority(which, who) );
4322 RETURN;
4323#else
cea2e8a9 4324 DIE(aTHX_ PL_no_func, "getpriority()");
a0d0e21e
LW		 4325#endif
4326}
4327
4328PP(pp_setpriority)
4329{
a0d0e21e 4330#ifdef HAS_SETPRIORITY
97aff369 4331 dVAR; dSP; dTARGET;
0bcc34c2
AL		 4332 const int niceval = POPi;
4333 const int who = POPi;
4334 const int which = TOPi;
a0d0e21e
LW		 4335 TAINT_PROPER("setpriority");
4336 SETi( setpriority(which, who, niceval) >= 0 );
4337 RETURN;
4338#else
cea2e8a9 4339 DIE(aTHX_ PL_no_func, "setpriority()");
a0d0e21e
LW		 4340#endif
4341}
4342
4343/* Time calls. */
4344
4345PP(pp_time)
4346{
97aff369 4347 dVAR; dSP; dTARGET;
cbdc8872 4348#ifdef BIG_TIME
4608196e 4349 XPUSHn( time(NULL) );
cbdc8872 4350#else
4608196e 4351 XPUSHi( time(NULL) );
cbdc8872 4352#endif
a0d0e21e
LW		 4353 RETURN;
4354}
4355
a0d0e21e
LW		 4356PP(pp_tms)
4357{
9cad6237 4358#ifdef HAS_TIMES
97aff369 4359 dVAR;
39644a26 4360 dSP;
a0d0e21e 4361 EXTEND(SP, 4);
a0d0e21e 4362#ifndef VMS
3280af22 4363 (void)PerlProc_times(&PL_timesbuf);
a0d0e21e 4364#else
6b88bc9c 4365 (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */
76e3520e
GS		 4366 /* struct tms, though same data */
4367 /* is returned. */
a0d0e21e
LW		 4368#endif
4369
5311654c 4370 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick)));
a0d0e21e 4371 if (GIMME == G_ARRAY) {
5311654c
JH		 4372 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick)));
4373 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick)));
4374 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick)));
a0d0e21e
LW		 4375 }
4376 RETURN;
9cad6237 4377#else
2f42fcb0
JH		 4378# ifdef PERL_MICRO
4379 dSP;
4380 PUSHs(sv_2mortal(newSVnv((NV)0.0)));
4381 EXTEND(SP, 4);
4382 if (GIMME == G_ARRAY) {
4383 PUSHs(sv_2mortal(newSVnv((NV)0.0)));
4384 PUSHs(sv_2mortal(newSVnv((NV)0.0)));
4385 PUSHs(sv_2mortal(newSVnv((NV)0.0)));
4386 }
4387 RETURN;
4388# else
9cad6237 4389 DIE(aTHX_ "times not implemented");
2f42fcb0 4390# endif
55497cff 4391#endif /* HAS_TIMES */
a0d0e21e
LW		 4392}
4393
a4323dee 4394#ifdef LOCALTIME_EDGECASE_BROKEN
89261a6c 4395static struct tm *S_my_localtime (pTHX_ Time_t *tp)
a4323dee
MB		 4396{
4397 auto time_t T;
4398 auto struct tm *P;
4399
4400 /* No workarounds in the valid range */
4401 if (!tp || *tp < 0x7fff573f || *tp >= 0x80000000)
4402 return (localtime (tp));
4403
4404 /* This edge case is to workaround the undefined behaviour, where the
4405 * TIMEZONE makes the time go beyond the defined range.
4406 * gmtime (0x7fffffff) => 2038-01-19 03:14:07
4407 * If there is a negative offset in TZ, like MET-1METDST, some broken
4408 * implementations of localtime () (like AIX 5.2) barf with bogus
4409 * return values:
4410 * 0x7fffffff gmtime 2038-01-19 03:14:07
4411 * 0x7fffffff localtime 1901-12-13 21:45:51
4412 * 0x7fffffff mylocaltime 2038-01-19 04:14:07
4413 * 0x3c19137f gmtime 2001-12-13 20:45:51
4414 * 0x3c19137f localtime 2001-12-13 21:45:51
4415 * 0x3c19137f mylocaltime 2001-12-13 21:45:51
4416 * Given that legal timezones are typically between GMT-12 and GMT+12
4417 * we turn back the clock 23 hours before calling the localtime
4418 * function, and add those to the return value. This will never cause
3574fba9 4419 * day wrapping problems, since the edge case is Tue Jan *19*
a4323dee
MB		 4420 */
4421 T = *tp - 82800; /* 23 hour. allows up to GMT-23 */
4422 P = localtime (&T);
4423 P->tm_hour += 23;
4424 if (P->tm_hour >= 24) {
4425 P->tm_hour -= 24;
3574fba9
CW		 4426 P->tm_mday++; /* 18 -> 19 */
4427 P->tm_wday++; /* Mon -> Tue */
4428 P->tm_yday++; /* 18 -> 19 */
a4323dee
MB		 4429 }
4430 return (P);
4431} /* S_my_localtime */
4432#endif
4433
a0d0e21e
LW		 4434PP(pp_gmtime)
4435{
97aff369 4436 dVAR;
39644a26 4437 dSP;
a0d0e21e 4438 Time_t when;
bfed75c6 4439 const struct tm *tmbuf;
27da23d5
JH		 4440 static const char * const dayname[] =
4441 {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4442 static const char * const monname[] =
4443 {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4444 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
a0d0e21e
LW		 4445
4446 if (MAXARG < 1)
4447 (void)time(&when);
4448 else
cbdc8872 4449#ifdef BIG_TIME
4450 when = (Time_t)SvNVx(POPs);
4451#else
a0d0e21e 4452 when = (Time_t)SvIVx(POPs);
cbdc8872 4453#endif
a0d0e21e 4454
533c011a 4455 if (PL_op->op_type == OP_LOCALTIME)
a4323dee 4456#ifdef LOCALTIME_EDGECASE_BROKEN
89261a6c 4457 tmbuf = S_my_localtime(aTHX_ &when);
a4323dee 4458#else
a0d0e21e 4459 tmbuf = localtime(&when);
a4323dee 4460#endif
a0d0e21e
LW		 4461 else
4462 tmbuf = gmtime(&when);
4463
a0d0e21e 4464 if (GIMME != G_ARRAY) {
46fc3d4c 4465 SV *tsv;
9a5ff6d9
AB		 4466 EXTEND(SP, 1);
4467 EXTEND_MORTAL(1);
a0d0e21e
LW		 4468 if (!tmbuf)
4469 RETPUSHUNDEF;
be28567c 4470 tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %d",
f5a29b03
RB		 4471 dayname[tmbuf->tm_wday],
4472 monname[tmbuf->tm_mon],
be28567c
GS		 4473 tmbuf->tm_mday,
4474 tmbuf->tm_hour,
4475 tmbuf->tm_min,
4476 tmbuf->tm_sec,
4477 tmbuf->tm_year + 1900);
46fc3d4c 4478 PUSHs(sv_2mortal(tsv));
a0d0e21e
LW		 4479 }
4480 else if (tmbuf) {
9a5ff6d9
AB		 4481 EXTEND(SP, 9);
4482 EXTEND_MORTAL(9);
4483 PUSHs(sv_2mortal(newSViv(tmbuf->tm_sec)));
c6419e06
JH		 4484 PUSHs(sv_2mortal(newSViv(tmbuf->tm_min)));
4485 PUSHs(sv_2mortal(newSViv(tmbuf->tm_hour)));
4486 PUSHs(sv_2mortal(newSViv(tmbuf->tm_mday)));
4487 PUSHs(sv_2mortal(newSViv(tmbuf->tm_mon)));
4488 PUSHs(sv_2mortal(newSViv(tmbuf->tm_year)));
4489 PUSHs(sv_2mortal(newSViv(tmbuf->tm_wday)));
4490 PUSHs(sv_2mortal(newSViv(tmbuf->tm_yday)));
4491 PUSHs(sv_2mortal(newSViv(tmbuf->tm_isdst)));
a0d0e21e
LW		 4492 }
4493 RETURN;
4494}
4495
4496PP(pp_alarm)
4497{
9cad6237 4498#ifdef HAS_ALARM
97aff369 4499 dVAR; dSP; dTARGET;
a0d0e21e 4500 int anum;
a0d0e21e
LW		 4501 anum = POPi;
4502 anum = alarm((unsigned int)anum);
4503 EXTEND(SP, 1);
4504 if (anum < 0)
4505 RETPUSHUNDEF;
c6419e06 4506 PUSHi(anum);
a0d0e21e
LW		 4507 RETURN;
4508#else
0322a713 4509 DIE(aTHX_ PL_no_func, "alarm");
a0d0e21e
LW		 4510#endif
4511}
4512
4513PP(pp_sleep)
4514{
97aff369 4515 dVAR; dSP; dTARGET;
a0d0e21e
LW		 4516 I32 duration;
4517 Time_t lasttime;
4518 Time_t when;
4519
4520 (void)time(&lasttime);
4521 if (MAXARG < 1)
76e3520e 4522 PerlProc_pause();
a0d0e21e
LW		 4523 else {
4524 duration = POPi;
76e3520e 4525 PerlProc_sleep((unsigned int)duration);
a0d0e21e
LW		 4526 }
4527 (void)time(&when);
4528 XPUSHi(when - lasttime);
4529 RETURN;
4530}
4531
4532/* Shared memory. */
c9f7ac20 4533/* Merged with some message passing. */
a0d0e21e 4534
a0d0e21e
LW		 4535PP(pp_shmwrite)
4536{
4537#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
97aff369 4538 dVAR; dSP; dMARK; dTARGET;
c9f7ac20
NC		 4539 const int op_type = PL_op->op_type;
4540 I32 value;
a0d0e21e 4541
c9f7ac20
NC		 4542 switch (op_type) {
4543 case OP_MSGSND:
4544 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4545 break;
4546 case OP_MSGRCV:
4547 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4548 break;
ca563b4e
NC		 4549 case OP_SEMOP:
4550 value = (I32)(do_semop(MARK, SP) >= 0);
4551 break;
c9f7ac20
NC		 4552 default:
4553 value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4554 break;
4555 }
a0d0e21e 4556
a0d0e21e
LW		 4557 SP = MARK;
4558 PUSHi(value);
4559 RETURN;
4560#else
cea2e8a9 4561 return pp_semget();
a0d0e21e
LW		 4562#endif
4563}
4564
4565/* Semaphores. */
4566
4567PP(pp_semget)
4568{
4569#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
97aff369 4570 dVAR; dSP; dMARK; dTARGET;
0bcc34c2 4571 const int anum = do_ipcget(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 4572 SP = MARK;
4573 if (anum == -1)
4574 RETPUSHUNDEF;
4575 PUSHi(anum);
4576 RETURN;
4577#else
cea2e8a9 4578 DIE(aTHX_ "System V IPC is not implemented on this machine");
a0d0e21e
LW		 4579#endif
4580}
4581
4582PP(pp_semctl)
4583{
4584#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
97aff369 4585 dVAR; dSP; dMARK; dTARGET;
0bcc34c2 4586 const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 4587 SP = MARK;
4588 if (anum == -1)
4589 RETSETUNDEF;
4590 if (anum != 0) {
4591 PUSHi(anum);
4592 }
4593 else {
8903cb82 4594 PUSHp(zero_but_true, ZBTLEN);
a0d0e21e
LW		 4595 }
4596 RETURN;
4597#else
cea2e8a9 4598 return pp_semget();
a0d0e21e
LW		 4599#endif
4600}
4601
5cdc4e88
NC		 4602/* I can't const this further without getting warnings about the types of
4603 various arrays passed in from structures. */
4604static SV *
4605S_space_join_names_mortal(pTHX_ char *const *array)
4606{
7c58897d 4607 SV *target;
5cdc4e88
NC		 4608
4609 if (array && *array) {
7c58897d 4610 target = sv_2mortal(newSVpvs(""));
5cdc4e88
NC		 4611 while (1) {
4612 sv_catpv(target, *array);
4613 if (!*++array)
4614 break;
4615 sv_catpvs(target, " ");
4616 }
7c58897d
NC		 4617 } else {
4618 target = sv_mortalcopy(&PL_sv_no);
5cdc4e88
NC		 4619 }
4620 return target;
4621}
4622
a0d0e21e
LW		 4623/* Get system info. */
4624
a0d0e21e
LW		 4625PP(pp_ghostent)
4626{
693762b4 4627#if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
97aff369 4628 dVAR; dSP;
533c011a 4629 I32 which = PL_op->op_type;
a0d0e21e
LW		 4630 register char **elem;
4631 register SV *sv;
dc45a647 4632#ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
1d88b533
JH		 4633 struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4634 struct hostent *gethostbyname(Netdb_name_t);
4635 struct hostent *gethostent(void);
a0d0e21e
LW		 4636#endif
4637 struct hostent *hent;
4638 unsigned long len;
4639
4640 EXTEND(SP, 10);
edd309b7 4641 if (which == OP_GHBYNAME) {
dc45a647 4642#ifdef HAS_GETHOSTBYNAME
0bcc34c2 4643 const char* const name = POPpbytex;
edd309b7 4644 hent = PerlSock_gethostbyname(name);
dc45a647 4645#else
cea2e8a9 4646 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
dc45a647 4647#endif
edd309b7 4648 }
a0d0e21e 4649 else if (which == OP_GHBYADDR) {
dc45a647 4650#ifdef HAS_GETHOSTBYADDR
0bcc34c2
AL		 4651 const int addrtype = POPi;
4652 SV * const addrsv = POPs;
a0d0e21e 4653 STRLEN addrlen;
5bf7026a 4654 Netdb_host_t addr = (Netdb_host_t) SvPVbyte(addrsv, addrlen);
a0d0e21e 4655
1d0eb99a 4656 hent = PerlSock_gethostbyaddr((const char*)addr, (Netdb_hlen_t) addrlen, addrtype);
dc45a647 4657#else
cea2e8a9 4658 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
dc45a647 4659#endif
a0d0e21e
LW		 4660 }
4661 else
4662#ifdef HAS_GETHOSTENT
6ad3d225 4663 hent = PerlSock_gethostent();
a0d0e21e 4664#else
cea2e8a9 4665 DIE(aTHX_ PL_no_sock_func, "gethostent");
a0d0e21e
LW		 4666#endif
4667
4668#ifdef HOST_NOT_FOUND
10bc17b6
JH		 4669 if (!hent) {
4670#ifdef USE_REENTRANT_API
4671# ifdef USE_GETHOSTENT_ERRNO
4672 h_errno = PL_reentrant_buffer->_gethostent_errno;
4673# endif
4674#endif
37038d91 4675 STATUS_UNIX_SET(h_errno);
10bc17b6 4676 }
a0d0e21e
LW		 4677#endif
4678
4679 if (GIMME != G_ARRAY) {
4680 PUSHs(sv = sv_newmortal());
4681 if (hent) {
4682 if (which == OP_GHBYNAME) {
fd0af264 4683 if (hent->h_addr)
4684 sv_setpvn(sv, hent->h_addr, hent->h_length);
a0d0e21e
LW		 4685 }
4686 else
4687 sv_setpv(sv, (char*)hent->h_name);
4688 }
4689 RETURN;
4690 }
4691
4692 if (hent) {
7c58897d 4693 PUSHs(sv_2mortal(newSVpv((char*)hent->h_name, 0)));
931e0695 4694 PUSHs(space_join_names_mortal(hent->h_aliases));
7c58897d 4695 PUSHs(sv_2mortal(newSViv((IV)hent->h_addrtype)));
a0d0e21e 4696 len = hent->h_length;
7c58897d 4697 PUSHs(sv_2mortal(newSViv((IV)len)));
a0d0e21e
LW		 4698#ifdef h_addr
4699 for (elem = hent->h_addr_list; elem && *elem; elem++) {
7c58897d 4700 XPUSHs(sv_2mortal(newSVpvn(*elem, len)));
a0d0e21e
LW		 4701 }
4702#else
fd0af264 4703 if (hent->h_addr)
7c58897d
NC		 4704 PUSHs(newSVpvn(hent->h_addr, len));
4705 else
4706 PUSHs(sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 4707#endif /* h_addr */
4708 }
4709 RETURN;
4710#else
cea2e8a9 4711 DIE(aTHX_ PL_no_sock_func, "gethostent");
a0d0e21e
LW		 4712#endif
4713}
4714
a0d0e21e
LW		 4715PP(pp_gnetent)
4716{
693762b4 4717#if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
97aff369 4718 dVAR; dSP;
533c011a 4719 I32 which = PL_op->op_type;
a0d0e21e 4720 register SV *sv;
dc45a647 4721#ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
1d88b533
JH		 4722 struct netent *getnetbyaddr(Netdb_net_t, int);
4723 struct netent *getnetbyname(Netdb_name_t);
4724 struct netent *getnetent(void);
8ac85365 4725#endif
a0d0e21e
LW		 4726 struct netent *nent;
4727
edd309b7 4728 if (which == OP_GNBYNAME){
dc45a647 4729#ifdef HAS_GETNETBYNAME
0bcc34c2 4730 const char * const name = POPpbytex;
edd309b7 4731 nent = PerlSock_getnetbyname(name);
dc45a647 4732#else
cea2e8a9 4733 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
dc45a647 4734#endif
edd309b7 4735 }
a0d0e21e 4736 else if (which == OP_GNBYADDR) {
dc45a647 4737#ifdef HAS_GETNETBYADDR
0bcc34c2
AL		 4738 const int addrtype = POPi;
4739 const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
76e3520e 4740 nent = PerlSock_getnetbyaddr(addr, addrtype);
dc45a647 4741#else
cea2e8a9 4742 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
dc45a647 4743#endif
a0d0e21e
LW		 4744 }
4745 else
dc45a647 4746#ifdef HAS_GETNETENT
76e3520e 4747 nent = PerlSock_getnetent();
dc45a647 4748#else
cea2e8a9 4749 DIE(aTHX_ PL_no_sock_func, "getnetent");
dc45a647 4750#endif
a0d0e21e 4751
10bc17b6
JH		 4752#ifdef HOST_NOT_FOUND
4753 if (!nent) {
4754#ifdef USE_REENTRANT_API
4755# ifdef USE_GETNETENT_ERRNO
4756 h_errno = PL_reentrant_buffer->_getnetent_errno;
4757# endif
4758#endif
37038d91 4759 STATUS_UNIX_SET(h_errno);
10bc17b6
JH		 4760 }
4761#endif
4762
a0d0e21e
LW		 4763 EXTEND(SP, 4);
4764 if (GIMME != G_ARRAY) {
4765 PUSHs(sv = sv_newmortal());
4766 if (nent) {
4767 if (which == OP_GNBYNAME)
1e422769 4768 sv_setiv(sv, (IV)nent->n_net);
a0d0e21e
LW		 4769 else
4770 sv_setpv(sv, nent->n_name);
4771 }
4772 RETURN;
4773 }
4774
4775 if (nent) {
7c58897d 4776 PUSHs(sv_2mortal(newSVpv(nent->n_name, 0)));
931e0695 4777 PUSHs(space_join_names_mortal(nent->n_aliases));
7c58897d
NC		 4778 PUSHs(sv_2mortal(newSViv((IV)nent->n_addrtype)));
4779 PUSHs(sv_2mortal(newSViv((IV)nent->n_net)));
a0d0e21e
LW		 4780 }
4781
4782 RETURN;
4783#else
cea2e8a9 4784 DIE(aTHX_ PL_no_sock_func, "getnetent");
a0d0e21e
LW		 4785#endif
4786}
4787
a0d0e21e
LW		 4788PP(pp_gprotoent)
4789{
693762b4 4790#if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
97aff369 4791 dVAR; dSP;
533c011a 4792 I32 which = PL_op->op_type;
301e8125 4793 register SV *sv;
dc45a647 4794#ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
1d88b533
JH		 4795 struct protoent *getprotobyname(Netdb_name_t);
4796 struct protoent *getprotobynumber(int);
4797 struct protoent *getprotoent(void);
8ac85365 4798#endif
a0d0e21e
LW		 4799 struct protoent *pent;
4800
edd309b7 4801 if (which == OP_GPBYNAME) {
e5c9fcd0 4802#ifdef HAS_GETPROTOBYNAME
0bcc34c2 4803 const char* const name = POPpbytex;
edd309b7 4804 pent = PerlSock_getprotobyname(name);
e5c9fcd0 4805#else
cea2e8a9 4806 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
e5c9fcd0 4807#endif
edd309b7
JH		 4808 }
4809 else if (which == OP_GPBYNUMBER) {
e5c9fcd0 4810#ifdef HAS_GETPROTOBYNUMBER
0bcc34c2 4811 const int number = POPi;
edd309b7 4812 pent = PerlSock_getprotobynumber(number);
e5c9fcd0 4813#else
edd309b7 4814 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
e5c9fcd0 4815#endif
edd309b7 4816 }
a0d0e21e 4817 else
e5c9fcd0 4818#ifdef HAS_GETPROTOENT
6ad3d225 4819 pent = PerlSock_getprotoent();
e5c9fcd0 4820#else
cea2e8a9 4821 DIE(aTHX_ PL_no_sock_func, "getprotoent");
e5c9fcd0 4822#endif
a0d0e21e
LW		 4823
4824 EXTEND(SP, 3);
4825 if (GIMME != G_ARRAY) {
4826 PUSHs(sv = sv_newmortal());
4827 if (pent) {
4828 if (which == OP_GPBYNAME)
1e422769 4829 sv_setiv(sv, (IV)pent->p_proto);
a0d0e21e
LW		 4830 else
4831 sv_setpv(sv, pent->p_name);
4832 }
4833 RETURN;
4834 }
4835
4836 if (pent) {
7c58897d 4837 PUSHs(sv_2mortal(newSVpv(pent->p_name, 0)));
931e0695 4838 PUSHs(space_join_names_mortal(pent->p_aliases));
7c58897d 4839 PUSHs(sv_2mortal(newSViv((IV)pent->p_proto)));
a0d0e21e
LW		 4840 }
4841
4842 RETURN;
4843#else
cea2e8a9 4844 DIE(aTHX_ PL_no_sock_func, "getprotoent");
a0d0e21e
LW		 4845#endif
4846}
4847
a0d0e21e
LW		 4848PP(pp_gservent)
4849{
693762b4 4850#if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
97aff369 4851 dVAR; dSP;
533c011a 4852 I32 which = PL_op->op_type;
a0d0e21e 4853 register SV *sv;
dc45a647 4854#ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
1d88b533
JH		 4855 struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
4856 struct servent *getservbyport(int, Netdb_name_t);
4857 struct servent *getservent(void);
8ac85365 4858#endif
a0d0e21e
LW		 4859 struct servent *sent;
4860
4861 if (which == OP_GSBYNAME) {
dc45a647 4862#ifdef HAS_GETSERVBYNAME
0bcc34c2
AL		 4863 const char * const proto = POPpbytex;
4864 const char * const name = POPpbytex;
bd61b366 4865 sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
dc45a647 4866#else
cea2e8a9 4867 DIE(aTHX_ PL_no_sock_func, "getservbyname");
dc45a647 4868#endif
a0d0e21e
LW		 4869 }
4870 else if (which == OP_GSBYPORT) {
dc45a647 4871#ifdef HAS_GETSERVBYPORT
0bcc34c2 4872 const char * const proto = POPpbytex;
eb160463 4873 unsigned short port = (unsigned short)POPu;
36477c24 4874#ifdef HAS_HTONS
6ad3d225 4875 port = PerlSock_htons(port);
36477c24 4876#endif
bd61b366 4877 sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
dc45a647 4878#else
cea2e8a9 4879 DIE(aTHX_ PL_no_sock_func, "getservbyport");
dc45a647 4880#endif
a0d0e21e
LW		 4881 }
4882 else
e5c9fcd0 4883#ifdef HAS_GETSERVENT
6ad3d225 4884 sent = PerlSock_getservent();
e5c9fcd0 4885#else
cea2e8a9 4886 DIE(aTHX_ PL_no_sock_func, "getservent");
e5c9fcd0 4887#endif
a0d0e21e
LW		 4888
4889 EXTEND(SP, 4);
4890 if (GIMME != G_ARRAY) {
4891 PUSHs(sv = sv_newmortal());
4892 if (sent) {
4893 if (which == OP_GSBYNAME) {
4894#ifdef HAS_NTOHS
6ad3d225 4895 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
a0d0e21e 4896#else
1e422769 4897 sv_setiv(sv, (IV)(sent->s_port));
a0d0e21e
LW		 4898#endif
4899 }
4900 else
4901 sv_setpv(sv, sent->s_name);
4902 }
4903 RETURN;
4904 }
4905
4906 if (sent) {
7c58897d 4907 PUSHs(sv_2mortal(newSVpv(sent->s_name, 0)));
931e0695 4908 PUSHs(space_join_names_mortal(sent->s_aliases));
a0d0e21e 4909#ifdef HAS_NTOHS
7c58897d 4910 PUSHs(sv_2mortal(newSViv((IV)PerlSock_ntohs(sent->s_port))));
a0d0e21e 4911#else
7c58897d 4912 PUSHs(sv_2mortal(newSViv((IV)(sent->s_port))));
a0d0e21e 4913#endif
7c58897d 4914 PUSHs(sv_2mortal(newSVpv(sent->s_proto, 0)));
a0d0e21e
LW		 4915 }
4916
4917 RETURN;
4918#else
cea2e8a9 4919 DIE(aTHX_ PL_no_sock_func, "getservent");
a0d0e21e
LW		 4920#endif
4921}
4922
4923PP(pp_shostent)
4924{
693762b4 4925#ifdef HAS_SETHOSTENT
97aff369 4926 dVAR; dSP;
76e3520e 4927 PerlSock_sethostent(TOPi);
a0d0e21e
LW		 4928 RETSETYES;
4929#else
cea2e8a9 4930 DIE(aTHX_ PL_no_sock_func, "sethostent");
a0d0e21e
LW		 4931#endif
4932}
4933
4934PP(pp_snetent)
4935{
693762b4 4936#ifdef HAS_SETNETENT
97aff369 4937 dVAR; dSP;
76e3520e 4938 PerlSock_setnetent(TOPi);
a0d0e21e
LW		 4939 RETSETYES;
4940#else
cea2e8a9 4941 DIE(aTHX_ PL_no_sock_func, "setnetent");
a0d0e21e
LW		 4942#endif
4943}
4944
4945PP(pp_sprotoent)
4946{
693762b4 4947#ifdef HAS_SETPROTOENT
97aff369 4948 dVAR; dSP;
76e3520e 4949 PerlSock_setprotoent(TOPi);
a0d0e21e
LW		 4950 RETSETYES;
4951#else
cea2e8a9 4952 DIE(aTHX_ PL_no_sock_func, "setprotoent");
a0d0e21e
LW		 4953#endif
4954}
4955
4956PP(pp_sservent)
4957{
693762b4 4958#ifdef HAS_SETSERVENT
97aff369 4959 dVAR; dSP;
76e3520e 4960 PerlSock_setservent(TOPi);
a0d0e21e
LW		 4961 RETSETYES;
4962#else
cea2e8a9 4963 DIE(aTHX_ PL_no_sock_func, "setservent");
a0d0e21e
LW		 4964#endif
4965}
4966
4967PP(pp_ehostent)
4968{
693762b4 4969#ifdef HAS_ENDHOSTENT
97aff369 4970 dVAR; dSP;
76e3520e 4971 PerlSock_endhostent();
924508f0 4972 EXTEND(SP,1);
a0d0e21e
LW		 4973 RETPUSHYES;
4974#else
cea2e8a9 4975 DIE(aTHX_ PL_no_sock_func, "endhostent");
a0d0e21e
LW		 4976#endif
4977}
4978
4979PP(pp_enetent)
4980{
693762b4 4981#ifdef HAS_ENDNETENT
97aff369 4982 dVAR; dSP;
76e3520e 4983 PerlSock_endnetent();
924508f0 4984 EXTEND(SP,1);
a0d0e21e
LW		 4985 RETPUSHYES;
4986#else
cea2e8a9 4987 DIE(aTHX_ PL_no_sock_func, "endnetent");
a0d0e21e
LW		 4988#endif
4989}
4990
4991PP(pp_eprotoent)
4992{
693762b4 4993#ifdef HAS_ENDPROTOENT
97aff369 4994 dVAR; dSP;
76e3520e 4995 PerlSock_endprotoent();
924508f0 4996 EXTEND(SP,1);
a0d0e21e
LW		 4997 RETPUSHYES;
4998#else
cea2e8a9 4999 DIE(aTHX_ PL_no_sock_func, "endprotoent");
a0d0e21e
LW		 5000#endif
5001}
5002
5003PP(pp_eservent)
5004{
693762b4 5005#ifdef HAS_ENDSERVENT
97aff369 5006 dVAR; dSP;
76e3520e 5007 PerlSock_endservent();
924508f0 5008 EXTEND(SP,1);
a0d0e21e
LW		 5009 RETPUSHYES;
5010#else
cea2e8a9 5011 DIE(aTHX_ PL_no_sock_func, "endservent");
a0d0e21e
LW		 5012#endif
5013}
5014
a0d0e21e
LW		 5015PP(pp_gpwent)
5016{
0994c4d0 5017#ifdef HAS_PASSWD
97aff369 5018 dVAR; dSP;
533c011a 5019 I32 which = PL_op->op_type;
a0d0e21e 5020 register SV *sv;
e3aefe8d 5021 struct passwd *pwent = NULL;
301e8125 5022 /*
bcf53261
JH		 5023 * We currently support only the SysV getsp* shadow password interface.
5024 * The interface is declared in <shadow.h> and often one needs to link
5025 * with -lsecurity or some such.
5026 * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5027 * (and SCO?)
5028 *
5029 * AIX getpwnam() is clever enough to return the encrypted password
5030 * only if the caller (euid?) is root.
5031 *
e549f1c5 5032 * There are at least three other shadow password APIs. Many platforms
bcf53261
JH		 5033 * seem to contain more than one interface for accessing the shadow
5034 * password databases, possibly for compatibility reasons.
3813c136 5035 * The getsp*() is by far he simplest one, the other two interfaces
bcf53261
JH		 5036 * are much more complicated, but also very similar to each other.
5037 *
5038 * <sys/types.h>
5039 * <sys/security.h>
5040 * <prot.h>
5041 * struct pr_passwd *getprpw*();
5042 * The password is in
3813c136
JH		 5043 * char getprpw*(...).ufld.fd_encrypt[]
5044 * Mention HAS_GETPRPWNAM here so that Configure probes for it.
bcf53261
JH		 5045 *
5046 * <sys/types.h>
5047 * <sys/security.h>
5048 * <prot.h>
5049 * struct es_passwd *getespw*();
5050 * The password is in
5051 * char *(getespw*(...).ufld.fd_encrypt)
3813c136 5052 * Mention HAS_GETESPWNAM here so that Configure probes for it.
bcf53261 5053 *
e1920a95 5054 * <userpw.h> (AIX)
e549f1c5
JH		 5055 * struct userpw *getuserpw();
5056 * The password is in
5057 * char *(getuserpw(...)).spw_upw_passwd
5058 * (but the de facto standard getpwnam() should work okay)
5059 *
3813c136 5060 * Mention I_PROT here so that Configure probes for it.
bcf53261
JH		 5061 *
5062 * In HP-UX for getprpw*() the manual page claims that one should include
5063 * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5064 * if one includes <shadow.h> as that includes <hpsecurity.h>,
5065 * and pp_sys.c already includes <shadow.h> if there is such.
3813c136
JH		 5066 *
5067 * Note that <sys/security.h> is already probed for, but currently
5068 * it is only included in special cases.
301e8125 5069 *
bcf53261
JH		 5070 * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5071 * be preferred interface, even though also the getprpw*() interface
5072 * is available) one needs to link with -lsecurity -ldb -laud -lm.
3813c136
JH		 5073 * One also needs to call set_auth_parameters() in main() before
5074 * doing anything else, whether one is using getespw*() or getprpw*().
5075 *
5076 * Note that accessing the shadow databases can be magnitudes
5077 * slower than accessing the standard databases.
bcf53261
JH		 5078 *
5079 * --jhi
5080 */
a0d0e21e 5081
9e5f0c48
JH		 5082# if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5083 /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5084 * the pw_comment is left uninitialized. */
5085 PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5086# endif
5087
e3aefe8d
JH		 5088 switch (which) {
5089 case OP_GPWNAM:
edd309b7 5090 {
0bcc34c2 5091 const char* const name = POPpbytex;
edd309b7
JH		 5092 pwent = getpwnam(name);
5093 }
5094 break;
e3aefe8d 5095 case OP_GPWUID:
edd309b7
JH		 5096 {
5097 Uid_t uid = POPi;
5098 pwent = getpwuid(uid);
5099 }
e3aefe8d
JH		 5100 break;
5101 case OP_GPWENT:
1883634f 5102# ifdef HAS_GETPWENT
e3aefe8d 5103 pwent = getpwent();
faea9016
IRC		 5104#ifdef POSIX_BC /* In some cases pw_passwd has invalid addresses */
5105 if (pwent) pwent = getpwnam(pwent->pw_name);
5106#endif
1883634f 5107# else
a45d1c96 5108 DIE(aTHX_ PL_no_func, "getpwent");
1883634f 5109# endif
e3aefe8d
JH		 5110 break;
5111 }
8c0bfa08 5112
a0d0e21e
LW		 5113 EXTEND(SP, 10);
5114 if (GIMME != G_ARRAY) {
5115 PUSHs(sv = sv_newmortal());
5116 if (pwent) {
5117 if (which == OP_GPWNAM)
1883634f 5118# if Uid_t_sign <= 0
1e422769 5119 sv_setiv(sv, (IV)pwent->pw_uid);
1883634f 5120# else
23dcd6c8 5121 sv_setuv(sv, (UV)pwent->pw_uid);
1883634f 5122# endif
a0d0e21e
LW		 5123 else
5124 sv_setpv(sv, pwent->pw_name);
5125 }
5126 RETURN;
5127 }
5128
5129 if (pwent) {
7c58897d 5130 PUSHs(sv_2mortal(newSVpv(pwent->pw_name, 0)));
6ee623d5 5131
7c58897d 5132 PUSHs(sv = sv_2mortal(newSViv(0)));
3813c136
JH		 5133 /* If we have getspnam(), we try to dig up the shadow
5134 * password. If we are underprivileged, the shadow
5135 * interface will set the errno to EACCES or similar,
5136 * and return a null pointer. If this happens, we will
5137 * use the dummy password (usually "*" or "x") from the
5138 * standard password database.
5139 *
5140 * In theory we could skip the shadow call completely
5141 * if euid != 0 but in practice we cannot know which
5142 * security measures are guarding the shadow databases
5143 * on a random platform.
5144 *
5145 * Resist the urge to use additional shadow interfaces.
5146 * Divert the urge to writing an extension instead.
5147 *
5148 * --jhi */
e549f1c5
JH		 5149 /* Some AIX setups falsely(?) detect some getspnam(), which
5150 * has a different API than the Solaris/IRIX one. */
5151# if defined(HAS_GETSPNAM) && !defined(_AIX)
3813c136 5152 {
0bcc34c2
AL		 5153 const int saverrno = errno;
5154 const struct spwd * const spwent = getspnam(pwent->pw_name);
5155 /* Save and restore errno so that
3813c136
JH		 5156 * underprivileged attempts seem
5157 * to have never made the unsccessful
5158 * attempt to retrieve the shadow password. */
3813c136
JH		 5159 errno = saverrno;
5160 if (spwent && spwent->sp_pwdp)
5161 sv_setpv(sv, spwent->sp_pwdp);
5162 }
f1066039 5163# endif
e020c87d 5164# ifdef PWPASSWD
3813c136
JH		 5165 if (!SvPOK(sv)) /* Use the standard password, then. */
5166 sv_setpv(sv, pwent->pw_passwd);
e020c87d 5167# endif
3813c136 5168
1883634f 5169# ifndef INCOMPLETE_TAINTS
3813c136
JH		 5170 /* passwd is tainted because user himself can diddle with it.
5171 * admittedly not much and in a very limited way, but nevertheless. */
2959b6e3 5172 SvTAINTED_on(sv);
1883634f 5173# endif
6ee623d5 5174
1883634f 5175# if Uid_t_sign <= 0
7c58897d 5176 PUSHs(sv_2mortal(newSViv((IV)pwent->pw_uid)));
1883634f 5177# else
7c58897d 5178 PUSHs(sv_2mortal(newSVuv((UV)pwent->pw_uid)));
1883634f 5179# endif
6ee623d5 5180
1883634f 5181# if Uid_t_sign <= 0
7c58897d 5182 PUSHs(sv_2mortal(newSViv((IV)pwent->pw_gid)));
1883634f 5183# else
7c58897d 5184 PUSHs(sv_2mortal(newSVuv((UV)pwent->pw_gid)));
1883634f 5185# endif
3813c136
JH		 5186 /* pw_change, pw_quota, and pw_age are mutually exclusive--
5187 * because of the poor interface of the Perl getpw*(),
5188 * not because there's some standard/convention saying so.
5189 * A better interface would have been to return a hash,
5190 * but we are accursed by our history, alas. --jhi. */
1883634f 5191# ifdef PWCHANGE
7c58897d 5192 PUSHs(sv_2mortal(newSViv((IV)pwent->pw_change)));
6ee623d5 5193# else
1883634f 5194# ifdef PWQUOTA
7c58897d 5195 PUSHs(sv_2mortal(newSViv((IV)pwent->pw_quota)));
1883634f 5196# else
a1757be1 5197# ifdef PWAGE
7c58897d
NC		 5198 PUSHs(sv_2mortal(newSVpv(pwent->pw_age, 0)));
5199# else
5200 /* I think that you can never get this compiled, but just in case. */
5201 PUSHs(sv_mortalcopy(&PL_sv_no));
a1757be1 5202# endif
6ee623d5
GS		 5203# endif
5204# endif
6ee623d5 5205
3813c136
JH		 5206 /* pw_class and pw_comment are mutually exclusive--.
5207 * see the above note for pw_change, pw_quota, and pw_age. */
1883634f 5208# ifdef PWCLASS
7c58897d 5209 PUSHs(sv_2mortal(newSVpv(pwent->pw_class, 0)));
1883634f
JH		 5210# else
5211# ifdef PWCOMMENT
7c58897d
NC		 5212 PUSHs(sv_2mortal(newSVpv(pwent->pw_comment, 0)));
5213# else
5214 /* I think that you can never get this compiled, but just in case. */
5215 PUSHs(sv_mortalcopy(&PL_sv_no));
1883634f 5216# endif
6ee623d5 5217# endif
6ee623d5 5218
1883634f 5219# ifdef PWGECOS
7c58897d
NC		 5220 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
5221# else
5222 PUSHs(sv_mortalcopy(&PL_sv_no));
1883634f
JH		 5223# endif
5224# ifndef INCOMPLETE_TAINTS
d2719217 5225 /* pw_gecos is tainted because user himself can diddle with it. */
fb73857a 5226 SvTAINTED_on(sv);
1883634f 5227# endif
6ee623d5 5228
7c58897d 5229 PUSHs(sv_2mortal(newSVpv(pwent->pw_dir, 0)));
6ee623d5 5230
7c58897d 5231 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
1883634f 5232# ifndef INCOMPLETE_TAINTS
4602f195
JH		 5233 /* pw_shell is tainted because user himself can diddle with it. */
5234 SvTAINTED_on(sv);
1883634f 5235# endif
6ee623d5 5236
1883634f 5237# ifdef PWEXPIRE
7c58897d 5238 PUSHs(sv_2mortal(newSViv((IV)pwent->pw_expire)));
1883634f 5239# endif
a0d0e21e
LW		 5240 }
5241 RETURN;
5242#else
af51a00e 5243 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
a0d0e21e
LW		 5244#endif
5245}
5246
5247PP(pp_spwent)
5248{
d493b042 5249#if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
97aff369 5250 dVAR; dSP;
a0d0e21e
LW		 5251 setpwent();
5252 RETPUSHYES;
5253#else
cea2e8a9 5254 DIE(aTHX_ PL_no_func, "setpwent");
a0d0e21e
LW		 5255#endif
5256}
5257
5258PP(pp_epwent)
5259{
28e8609d 5260#if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
97aff369 5261 dVAR; dSP;
a0d0e21e
LW		 5262 endpwent();
5263 RETPUSHYES;
5264#else
cea2e8a9 5265 DIE(aTHX_ PL_no_func, "endpwent");
a0d0e21e
LW		 5266#endif
5267}
5268
a0d0e21e
LW		 5269PP(pp_ggrent)
5270{
0994c4d0 5271#ifdef HAS_GROUP
97aff369 5272 dVAR; dSP;
6136c704
AL		 5273 const I32 which = PL_op->op_type;
5274 const struct group *grent;
a0d0e21e 5275
edd309b7 5276 if (which == OP_GGRNAM) {
0bcc34c2 5277 const char* const name = POPpbytex;
6136c704 5278 grent = (const struct group *)getgrnam(name);
edd309b7
JH		 5279 }
5280 else if (which == OP_GGRGID) {
0bcc34c2 5281 const Gid_t gid = POPi;
6136c704 5282 grent = (const struct group *)getgrgid(gid);
edd309b7 5283 }
a0d0e21e 5284 else
0994c4d0 5285#ifdef HAS_GETGRENT
a0d0e21e 5286 grent = (struct group *)getgrent();
0994c4d0
JH		 5287#else
5288 DIE(aTHX_ PL_no_func, "getgrent");
5289#endif
a0d0e21e
LW		 5290
5291 EXTEND(SP, 4);
5292 if (GIMME != G_ARRAY) {
6136c704
AL		 5293 SV * const sv = sv_newmortal();
5294
5295 PUSHs(sv);
a0d0e21e
LW		 5296 if (grent) {
5297 if (which == OP_GGRNAM)
1e422769 5298 sv_setiv(sv, (IV)grent->gr_gid);
a0d0e21e
LW		 5299 else
5300 sv_setpv(sv, grent->gr_name);
5301 }
5302 RETURN;
5303 }
5304
5305 if (grent) {
7c58897d 5306 PUSHs(sv_2mortal(newSVpv(grent->gr_name, 0)));
28e8609d 5307
28e8609d 5308#ifdef GRPASSWD
7c58897d
NC		 5309 PUSHs(sv_2mortal(newSVpv(grent->gr_passwd, 0)));
5310#else
5311 PUSHs(sv_mortalcopy(&PL_sv_no));
28e8609d
JH		 5312#endif
5313
7c58897d 5314 PUSHs(sv_2mortal(newSViv((IV)grent->gr_gid)));
28e8609d 5315
5b56e7c5 5316#if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
3d7e8424
JH		 5317 /* In UNICOS/mk (_CRAYMPP) the multithreading
5318 * versions (getgrnam_r, getgrgid_r)
5319 * seem to return an illegal pointer
5320 * as the group members list, gr_mem.
5321 * getgrent() doesn't even have a _r version
5322 * but the gr_mem is poisonous anyway.
5323 * So yes, you cannot get the list of group
5324 * members if building multithreaded in UNICOS/mk. */
931e0695 5325 PUSHs(space_join_names_mortal(grent->gr_mem));
3d7e8424 5326#endif
a0d0e21e
LW		 5327 }
5328
5329 RETURN;
5330#else
af51a00e 5331 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
a0d0e21e
LW		 5332#endif
5333}
5334
5335PP(pp_sgrent)
5336{
28e8609d 5337#if defined(HAS_GROUP) && defined(HAS_SETGRENT)
97aff369 5338 dVAR; dSP;
a0d0e21e
LW		 5339 setgrent();
5340 RETPUSHYES;
5341#else
cea2e8a9 5342 DIE(aTHX_ PL_no_func, "setgrent");
a0d0e21e
LW		 5343#endif
5344}
5345
5346PP(pp_egrent)
5347{
28e8609d 5348#if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
97aff369 5349 dVAR; dSP;
a0d0e21e
LW		 5350 endgrent();
5351 RETPUSHYES;
5352#else
cea2e8a9 5353 DIE(aTHX_ PL_no_func, "endgrent");
a0d0e21e
LW		 5354#endif
5355}
5356
5357PP(pp_getlogin)
5358{
a0d0e21e 5359#ifdef HAS_GETLOGIN
97aff369 5360 dVAR; dSP; dTARGET;
a0d0e21e
LW		 5361 char *tmps;
5362 EXTEND(SP, 1);
76e3520e 5363 if (!(tmps = PerlProc_getlogin()))
a0d0e21e
LW		 5364 RETPUSHUNDEF;
5365 PUSHp(tmps, strlen(tmps));
5366 RETURN;
5367#else
cea2e8a9 5368 DIE(aTHX_ PL_no_func, "getlogin");
a0d0e21e
LW		 5369#endif
5370}
5371
5372/* Miscellaneous. */
5373
5374PP(pp_syscall)
5375{
d2719217 5376#ifdef HAS_SYSCALL
97aff369 5377 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW		 5378 register I32 items = SP - MARK;
5379 unsigned long a[20];
5380 register I32 i = 0;
5381 I32 retval = -1;
5382
3280af22 5383 if (PL_tainting) {
a0d0e21e 5384 while (++MARK <= SP) {
bbce6d69 5385 if (SvTAINTED(*MARK)) {
5386 TAINT;
5387 break;
5388 }
a0d0e21e
LW		 5389 }
5390 MARK = ORIGMARK;
5391 TAINT_PROPER("syscall");
5392 }
5393
5394 /* This probably won't work on machines where sizeof(long) != sizeof(int)
5395 * or where sizeof(long) != sizeof(char*). But such machines will
5396 * not likely have syscall implemented either, so who cares?
5397 */
5398 while (++MARK <= SP) {
5399 if (SvNIOK(*MARK) || !i)
5400 a[i++] = SvIV(*MARK);
3280af22 5401 else if (*MARK == &PL_sv_undef)
748a9306 5402 a[i++] = 0;
301e8125 5403 else
8b6b16e7 5404 a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
a0d0e21e
LW		 5405 if (i > 15)
5406 break;
5407 }
5408 switch (items) {
5409 default:
cea2e8a9 5410 DIE(aTHX_ "Too many args to syscall");
a0d0e21e 5411 case 0:
cea2e8a9 5412 DIE(aTHX_ "Too few args to syscall");
a0d0e21e
LW		 5413 case 1:
5414 retval = syscall(a[0]);
5415 break;
5416 case 2:
5417 retval = syscall(a[0],a[1]);
5418 break;
5419 case 3:
5420 retval = syscall(a[0],a[1],a[2]);
5421 break;
5422 case 4:
5423 retval = syscall(a[0],a[1],a[2],a[3]);
5424 break;
5425 case 5:
5426 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5427 break;
5428 case 6:
5429 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5430 break;
5431 case 7:
5432 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5433 break;
5434 case 8:
5435 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5436 break;
5437#ifdef atarist
5438 case 9:
5439 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5440 break;
5441 case 10:
5442 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
5443 break;
5444 case 11:
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]);
5447 break;
5448 case 12:
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]);
5451 break;
5452 case 13:
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]);
5455 break;
5456 case 14:
5457 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5458 a[10],a[11],a[12],a[13]);
5459 break;
5460#endif /* atarist */
5461 }
5462 SP = ORIGMARK;
5463 PUSHi(retval);
5464 RETURN;
5465#else
cea2e8a9 5466 DIE(aTHX_ PL_no_func, "syscall");
a0d0e21e
LW		 5467#endif
5468}
5469
ff68c719 5470#ifdef FCNTL_EMULATE_FLOCK
301e8125 5471
ff68c719 5472/* XXX Emulate flock() with fcntl().
5473 What's really needed is a good file locking module.
5474*/
5475
cea2e8a9
GS		 5476static int
5477fcntl_emulate_flock(int fd, int operation)
ff68c719 5478{
5479 struct flock flock;
301e8125 5480
ff68c719 5481 switch (operation & ~LOCK_NB) {
5482 case LOCK_SH:
5483 flock.l_type = F_RDLCK;
5484 break;
5485 case LOCK_EX:
5486 flock.l_type = F_WRLCK;
5487 break;
5488 case LOCK_UN:
5489 flock.l_type = F_UNLCK;
5490 break;
5491 default:
5492 errno = EINVAL;
5493 return -1;
5494 }
5495 flock.l_whence = SEEK_SET;
d9b3e12d 5496 flock.l_start = flock.l_len = (Off_t)0;
301e8125 5497
ff68c719 5498 return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5499}
5500
5501#endif /* FCNTL_EMULATE_FLOCK */
5502
5503#ifdef LOCKF_EMULATE_FLOCK
16d20bd9
AD		 5504
5505/* XXX Emulate flock() with lockf(). This is just to increase
5506 portability of scripts. The calls are not completely
5507 interchangeable. What's really needed is a good file
5508 locking module.
5509*/
5510
76c32331 5511/* The lockf() constants might have been defined in <unistd.h>.
5512 Unfortunately, <unistd.h> causes troubles on some mixed
5513 (BSD/POSIX) systems, such as SunOS 4.1.3.
16d20bd9
AD		 5514
5515 Further, the lockf() constants aren't POSIX, so they might not be
5516 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
5517 just stick in the SVID values and be done with it. Sigh.
5518*/
5519
5520# ifndef F_ULOCK
5521# define F_ULOCK 0 /* Unlock a previously locked region */
5522# endif
5523# ifndef F_LOCK
5524# define F_LOCK 1 /* Lock a region for exclusive use */
5525# endif
5526# ifndef F_TLOCK
5527# define F_TLOCK 2 /* Test and lock a region for exclusive use */
5528# endif
5529# ifndef F_TEST
5530# define F_TEST 3 /* Test a region for other processes locks */
5531# endif
5532
cea2e8a9
GS		 5533static int
5534lockf_emulate_flock(int fd, int operation)
16d20bd9
AD		 5535{
5536 int i;
0bcc34c2 5537 const int save_errno = errno;
84902520
TB		 5538 Off_t pos;
5539
5540 /* flock locks entire file so for lockf we need to do the same */
6ad3d225 5541 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
84902520 5542 if (pos > 0) /* is seekable and needs to be repositioned */
6ad3d225 5543 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
08b714dd 5544 pos = -1; /* seek failed, so don't seek back afterwards */
84902520
TB		 5545 errno = save_errno;
5546
16d20bd9
AD		 5547 switch (operation) {
5548
5549 /* LOCK_SH - get a shared lock */
5550 case LOCK_SH:
5551 /* LOCK_EX - get an exclusive lock */
5552 case LOCK_EX:
5553 i = lockf (fd, F_LOCK, 0);
5554 break;
5555
5556 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5557 case LOCK_SH|LOCK_NB:
5558 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5559 case LOCK_EX|LOCK_NB:
5560 i = lockf (fd, F_TLOCK, 0);
5561 if (i == -1)
5562 if ((errno == EAGAIN) || (errno == EACCES))
5563 errno = EWOULDBLOCK;
5564 break;
5565
ff68c719 5566 /* LOCK_UN - unlock (non-blocking is a no-op) */
16d20bd9 5567 case LOCK_UN:
ff68c719 5568 case LOCK_UN|LOCK_NB:
16d20bd9
AD		 5569 i = lockf (fd, F_ULOCK, 0);
5570 break;
5571
5572 /* Default - can't decipher operation */
5573 default:
5574 i = -1;
5575 errno = EINVAL;
5576 break;
5577 }
84902520
TB		 5578
5579 if (pos > 0) /* need to restore position of the handle */
6ad3d225 5580 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
84902520 5581
16d20bd9
AD		 5582 return (i);
5583}
ff68c719 5584
5585#endif /* LOCKF_EMULATE_FLOCK */
241d1a3b
NC		 5586
5587/*
5588 * Local variables:
5589 * c-indentation-style: bsd
5590 * c-basic-offset: 4
5591 * indent-tabs-mode: t
5592 * End:
5593 *
37442d52
RGS		 5594 * ex: set ts=8 sts=4 sw=4 noet:
5595 */
Unnamed repository; edit this file 'description' to name the repository.