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