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