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