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