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