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