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