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