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