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