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
Integrate with Sarathy.
[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 472 SV *file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0));
b448e4fe 473 SV *line = sv_2mortal(newSVuv(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))
b448e4fe 867 PUSHs(sv_2mortal(newSVuv(O_RDWR|O_CREAT)));
a0d0e21e 868 else
b448e4fe 869 PUSHs(sv_2mortal(newSVuv(O_RDWR)));
a0d0e21e 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);
b448e4fe 880 PUSHs(sv_2mortal(newSVuv(O_RDONLY)));
a0d0e21e 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
b448e4fe 1796 XPUSHs(sv_2mortal(newSViv(offset)));
cb50131a 1797#endif
b448e4fe 1798 XPUSHs(sv_2mortal(newSViv(whence)));
4592e6ca
NIS		 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 {
b448e4fe
JH		 1810 Off_t sought = do_sysseek(gv, offset, whence);
1811 if (sought < 0)
146174a9
CB		 1812 PUSHs(&PL_sv_undef);
1813 else {
b448e4fe 1814 SV* sv = sought ?
146174a9 1815#if LSEEKSIZE > IVSIZE
b448e4fe 1816 newSVnv((NV)sought)
146174a9 1817#else
b448e4fe 1818 newSViv(sought)
146174a9
CB		 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)));
b448e4fe
JH		 2544 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_mode)));
2545 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_nlink)));
146174a9
CB		 2546#if Uid_t_size > IVSIZE
2547 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_uid)));
2548#else
23dcd6c8 2549# if Uid_t_sign <= 0
1ff81528 2550 PUSHs(sv_2mortal(newSViv(PL_statcache.st_uid)));
23dcd6c8
JH		 2551# else
2552 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_uid)));
2553# endif
146174a9
CB		 2554#endif
2555#if Gid_t_size > IVSIZE
2556 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_gid)));
2557#else
23dcd6c8 2558# if Gid_t_sign <= 0
1ff81528 2559 PUSHs(sv_2mortal(newSViv(PL_statcache.st_gid)));
23dcd6c8
JH		 2560# else
2561 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_gid)));
2562# endif
146174a9 2563#endif
cbdc8872 2564#ifdef USE_STAT_RDEV
1ff81528 2565 PUSHs(sv_2mortal(newSViv(PL_statcache.st_rdev)));
cbdc8872 2566#else
79cb57f6 2567 PUSHs(sv_2mortal(newSVpvn("", 0)));
cbdc8872 2568#endif
146174a9
CB		 2569#if Off_t_size > IVSIZE
2570 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_size)));
2571#else
1ff81528 2572 PUSHs(sv_2mortal(newSViv(PL_statcache.st_size)));
146174a9 2573#endif
cbdc8872 2574#ifdef BIG_TIME
172ae379
JH		 2575 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_atime)));
2576 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_mtime)));
2577 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_ctime)));
cbdc8872 2578#else
1ff81528
PL		 2579 PUSHs(sv_2mortal(newSViv(PL_statcache.st_atime)));
2580 PUSHs(sv_2mortal(newSViv(PL_statcache.st_mtime)));
2581 PUSHs(sv_2mortal(newSViv(PL_statcache.st_ctime)));
cbdc8872 2582#endif
a0d0e21e 2583#ifdef USE_STAT_BLOCKS
b448e4fe
JH		 2584 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blksize)));
2585 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blocks)));
a0d0e21e 2586#else
79cb57f6
GS		 2587 PUSHs(sv_2mortal(newSVpvn("", 0)));
2588 PUSHs(sv_2mortal(newSVpvn("", 0)));
a0d0e21e
LW		 2589#endif
2590 }
2591 RETURN;
2592}
2593
2594PP(pp_ftrread)
2595{
5ff3f7a4 2596 I32 result;
4e35701f 2597 djSP;
5ff3f7a4 2598#if defined(HAS_ACCESS) && defined(R_OK)
2d8e6c8d 2599 STRLEN n_a;
5ff3f7a4 2600 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2601 result = access(TOPpx, R_OK);
5ff3f7a4
GS		 2602 if (result == 0)
2603 RETPUSHYES;
2604 if (result < 0)
2605 RETPUSHUNDEF;
2606 RETPUSHNO;
22865c03
GS		 2607 }
2608 else
cea2e8a9 2609 result = my_stat();
5ff3f7a4 2610#else
cea2e8a9 2611 result = my_stat();
5ff3f7a4 2612#endif
22865c03 2613 SPAGAIN;
a0d0e21e
LW		 2614 if (result < 0)
2615 RETPUSHUNDEF;
3280af22 2616 if (cando(S_IRUSR, 0, &PL_statcache))
a0d0e21e
LW		 2617 RETPUSHYES;
2618 RETPUSHNO;
2619}
2620
2621PP(pp_ftrwrite)
2622{
5ff3f7a4 2623 I32 result;
4e35701f 2624 djSP;
5ff3f7a4 2625#if defined(HAS_ACCESS) && defined(W_OK)
2d8e6c8d 2626 STRLEN n_a;
5ff3f7a4 2627 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2628 result = access(TOPpx, W_OK);
5ff3f7a4
GS		 2629 if (result == 0)
2630 RETPUSHYES;
2631 if (result < 0)
2632 RETPUSHUNDEF;
2633 RETPUSHNO;
22865c03
GS		 2634 }
2635 else
cea2e8a9 2636 result = my_stat();
5ff3f7a4 2637#else
cea2e8a9 2638 result = my_stat();
5ff3f7a4 2639#endif
22865c03 2640 SPAGAIN;
a0d0e21e
LW		 2641 if (result < 0)
2642 RETPUSHUNDEF;
3280af22 2643 if (cando(S_IWUSR, 0, &PL_statcache))
a0d0e21e
LW		 2644 RETPUSHYES;
2645 RETPUSHNO;
2646}
2647
2648PP(pp_ftrexec)
2649{
5ff3f7a4 2650 I32 result;
4e35701f 2651 djSP;
5ff3f7a4 2652#if defined(HAS_ACCESS) && defined(X_OK)
2d8e6c8d 2653 STRLEN n_a;
5ff3f7a4 2654 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2655 result = access(TOPpx, X_OK);
5ff3f7a4
GS		 2656 if (result == 0)
2657 RETPUSHYES;
2658 if (result < 0)
2659 RETPUSHUNDEF;
2660 RETPUSHNO;
22865c03
GS		 2661 }
2662 else
cea2e8a9 2663 result = my_stat();
5ff3f7a4 2664#else
cea2e8a9 2665 result = my_stat();
5ff3f7a4 2666#endif
22865c03 2667 SPAGAIN;
a0d0e21e
LW		 2668 if (result < 0)
2669 RETPUSHUNDEF;
3280af22 2670 if (cando(S_IXUSR, 0, &PL_statcache))
a0d0e21e
LW		 2671 RETPUSHYES;
2672 RETPUSHNO;
2673}
2674
2675PP(pp_fteread)
2676{
5ff3f7a4 2677 I32 result;
4e35701f 2678 djSP;
5ff3f7a4 2679#ifdef PERL_EFF_ACCESS_R_OK
2d8e6c8d 2680 STRLEN n_a;
5ff3f7a4 2681 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2682 result = PERL_EFF_ACCESS_R_OK(TOPpx);
5ff3f7a4
GS		 2683 if (result == 0)
2684 RETPUSHYES;
2685 if (result < 0)
2686 RETPUSHUNDEF;
2687 RETPUSHNO;
22865c03
GS		 2688 }
2689 else
cea2e8a9 2690 result = my_stat();
5ff3f7a4 2691#else
cea2e8a9 2692 result = my_stat();
5ff3f7a4 2693#endif
22865c03 2694 SPAGAIN;
a0d0e21e
LW		 2695 if (result < 0)
2696 RETPUSHUNDEF;
3280af22 2697 if (cando(S_IRUSR, 1, &PL_statcache))
a0d0e21e
LW		 2698 RETPUSHYES;
2699 RETPUSHNO;
2700}
2701
2702PP(pp_ftewrite)
2703{
5ff3f7a4 2704 I32 result;
4e35701f 2705 djSP;
5ff3f7a4 2706#ifdef PERL_EFF_ACCESS_W_OK
2d8e6c8d 2707 STRLEN n_a;
5ff3f7a4 2708 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2709 result = PERL_EFF_ACCESS_W_OK(TOPpx);
5ff3f7a4
GS		 2710 if (result == 0)
2711 RETPUSHYES;
2712 if (result < 0)
2713 RETPUSHUNDEF;
2714 RETPUSHNO;
22865c03
GS		 2715 }
2716 else
cea2e8a9 2717 result = my_stat();
5ff3f7a4 2718#else
cea2e8a9 2719 result = my_stat();
5ff3f7a4 2720#endif
22865c03 2721 SPAGAIN;
a0d0e21e
LW		 2722 if (result < 0)
2723 RETPUSHUNDEF;
3280af22 2724 if (cando(S_IWUSR, 1, &PL_statcache))
a0d0e21e
LW		 2725 RETPUSHYES;
2726 RETPUSHNO;
2727}
2728
2729PP(pp_fteexec)
2730{
5ff3f7a4 2731 I32 result;
4e35701f 2732 djSP;
5ff3f7a4 2733#ifdef PERL_EFF_ACCESS_X_OK
2d8e6c8d 2734 STRLEN n_a;
5ff3f7a4 2735 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2736 result = PERL_EFF_ACCESS_X_OK(TOPpx);
5ff3f7a4
GS		 2737 if (result == 0)
2738 RETPUSHYES;
2739 if (result < 0)
2740 RETPUSHUNDEF;
2741 RETPUSHNO;
22865c03
GS		 2742 }
2743 else
cea2e8a9 2744 result = my_stat();
5ff3f7a4 2745#else
cea2e8a9 2746 result = my_stat();
5ff3f7a4 2747#endif
22865c03 2748 SPAGAIN;
a0d0e21e
LW		 2749 if (result < 0)
2750 RETPUSHUNDEF;
3280af22 2751 if (cando(S_IXUSR, 1, &PL_statcache))
a0d0e21e
LW		 2752 RETPUSHYES;
2753 RETPUSHNO;
2754}
2755
2756PP(pp_ftis)
2757{
cea2e8a9 2758 I32 result = my_stat();
4e35701f 2759 djSP;
a0d0e21e
LW		 2760 if (result < 0)
2761 RETPUSHUNDEF;
2762 RETPUSHYES;
2763}
2764
2765PP(pp_fteowned)
2766{
cea2e8a9 2767 return pp_ftrowned();
a0d0e21e
LW		 2768}
2769
2770PP(pp_ftrowned)
2771{
cea2e8a9 2772 I32 result = my_stat();
4e35701f 2773 djSP;
a0d0e21e
LW		 2774 if (result < 0)
2775 RETPUSHUNDEF;
146174a9
CB		 2776 if (PL_statcache.st_uid == (PL_op->op_type == OP_FTEOWNED ?
2777 PL_euid : PL_uid) )
a0d0e21e
LW		 2778 RETPUSHYES;
2779 RETPUSHNO;
2780}
2781
2782PP(pp_ftzero)
2783{
cea2e8a9 2784 I32 result = my_stat();
4e35701f 2785 djSP;
a0d0e21e
LW		 2786 if (result < 0)
2787 RETPUSHUNDEF;
146174a9 2788 if (PL_statcache.st_size == 0)
a0d0e21e
LW		 2789 RETPUSHYES;
2790 RETPUSHNO;
2791}
2792
2793PP(pp_ftsize)
2794{
cea2e8a9 2795 I32 result = my_stat();
4e35701f 2796 djSP; dTARGET;
a0d0e21e
LW		 2797 if (result < 0)
2798 RETPUSHUNDEF;
146174a9
CB		 2799#if Off_t_size > IVSIZE
2800 PUSHn(PL_statcache.st_size);
2801#else
3280af22 2802 PUSHi(PL_statcache.st_size);
146174a9 2803#endif
a0d0e21e
LW		 2804 RETURN;
2805}
2806
2807PP(pp_ftmtime)
2808{
cea2e8a9 2809 I32 result = my_stat();
4e35701f 2810 djSP; dTARGET;
a0d0e21e
LW		 2811 if (result < 0)
2812 RETPUSHUNDEF;
c6419e06 2813 PUSHn( (PL_basetime - PL_statcache.st_mtime) / 86400.0 );
a0d0e21e
LW		 2814 RETURN;
2815}
2816
2817PP(pp_ftatime)
2818{
cea2e8a9 2819 I32 result = my_stat();
4e35701f 2820 djSP; dTARGET;
a0d0e21e
LW		 2821 if (result < 0)
2822 RETPUSHUNDEF;
c6419e06 2823 PUSHn( (PL_basetime - PL_statcache.st_atime) / 86400.0 );
a0d0e21e
LW		 2824 RETURN;
2825}
2826
2827PP(pp_ftctime)
2828{
cea2e8a9 2829 I32 result = my_stat();
4e35701f 2830 djSP; dTARGET;
a0d0e21e
LW		 2831 if (result < 0)
2832 RETPUSHUNDEF;
c6419e06 2833 PUSHn( (PL_basetime - PL_statcache.st_ctime) / 86400.0 );
a0d0e21e
LW		 2834 RETURN;
2835}
2836
2837PP(pp_ftsock)
2838{
cea2e8a9 2839 I32 result = my_stat();
4e35701f 2840 djSP;
a0d0e21e
LW		 2841 if (result < 0)
2842 RETPUSHUNDEF;
3280af22 2843 if (S_ISSOCK(PL_statcache.st_mode))
a0d0e21e
LW		 2844 RETPUSHYES;
2845 RETPUSHNO;
2846}
2847
2848PP(pp_ftchr)
2849{
cea2e8a9 2850 I32 result = my_stat();
4e35701f 2851 djSP;
a0d0e21e
LW		 2852 if (result < 0)
2853 RETPUSHUNDEF;
3280af22 2854 if (S_ISCHR(PL_statcache.st_mode))
a0d0e21e
LW		 2855 RETPUSHYES;
2856 RETPUSHNO;
2857}
2858
2859PP(pp_ftblk)
2860{
cea2e8a9 2861 I32 result = my_stat();
4e35701f 2862 djSP;
a0d0e21e
LW		 2863 if (result < 0)
2864 RETPUSHUNDEF;
3280af22 2865 if (S_ISBLK(PL_statcache.st_mode))
a0d0e21e
LW		 2866 RETPUSHYES;
2867 RETPUSHNO;
2868}
2869
2870PP(pp_ftfile)
2871{
cea2e8a9 2872 I32 result = my_stat();
4e35701f 2873 djSP;
a0d0e21e
LW		 2874 if (result < 0)
2875 RETPUSHUNDEF;
3280af22 2876 if (S_ISREG(PL_statcache.st_mode))
a0d0e21e
LW		 2877 RETPUSHYES;
2878 RETPUSHNO;
2879}
2880
2881PP(pp_ftdir)
2882{
cea2e8a9 2883 I32 result = my_stat();
4e35701f 2884 djSP;
a0d0e21e
LW		 2885 if (result < 0)
2886 RETPUSHUNDEF;
3280af22 2887 if (S_ISDIR(PL_statcache.st_mode))
a0d0e21e
LW		 2888 RETPUSHYES;
2889 RETPUSHNO;
2890}
2891
2892PP(pp_ftpipe)
2893{
cea2e8a9 2894 I32 result = my_stat();
4e35701f 2895 djSP;
a0d0e21e
LW		 2896 if (result < 0)
2897 RETPUSHUNDEF;
3280af22 2898 if (S_ISFIFO(PL_statcache.st_mode))
a0d0e21e
LW		 2899 RETPUSHYES;
2900 RETPUSHNO;
2901}
2902
2903PP(pp_ftlink)
2904{
cea2e8a9 2905 I32 result = my_lstat();
4e35701f 2906 djSP;
a0d0e21e
LW		 2907 if (result < 0)
2908 RETPUSHUNDEF;
3280af22 2909 if (S_ISLNK(PL_statcache.st_mode))
a0d0e21e
LW		 2910 RETPUSHYES;
2911 RETPUSHNO;
2912}
2913
2914PP(pp_ftsuid)
2915{
4e35701f 2916 djSP;
a0d0e21e 2917#ifdef S_ISUID
cea2e8a9 2918 I32 result = my_stat();
a0d0e21e
LW		 2919 SPAGAIN;
2920 if (result < 0)
2921 RETPUSHUNDEF;
3280af22 2922 if (PL_statcache.st_mode & S_ISUID)
a0d0e21e
LW		 2923 RETPUSHYES;
2924#endif
2925 RETPUSHNO;
2926}
2927
2928PP(pp_ftsgid)
2929{
4e35701f 2930 djSP;
a0d0e21e 2931#ifdef S_ISGID
cea2e8a9 2932 I32 result = my_stat();
a0d0e21e
LW		 2933 SPAGAIN;
2934 if (result < 0)
2935 RETPUSHUNDEF;
3280af22 2936 if (PL_statcache.st_mode & S_ISGID)
a0d0e21e
LW		 2937 RETPUSHYES;
2938#endif
2939 RETPUSHNO;
2940}
2941
2942PP(pp_ftsvtx)
2943{
4e35701f 2944 djSP;
a0d0e21e 2945#ifdef S_ISVTX
cea2e8a9 2946 I32 result = my_stat();
a0d0e21e
LW		 2947 SPAGAIN;
2948 if (result < 0)
2949 RETPUSHUNDEF;
3280af22 2950 if (PL_statcache.st_mode & S_ISVTX)
a0d0e21e
LW		 2951 RETPUSHYES;
2952#endif
2953 RETPUSHNO;
2954}
2955
2956PP(pp_fttty)
2957{
4e35701f 2958 djSP;
a0d0e21e
LW		 2959 int fd;
2960 GV *gv;
fb73857a 2961 char *tmps = Nullch;
2d8e6c8d 2962 STRLEN n_a;
fb73857a 2963
533c011a 2964 if (PL_op->op_flags & OPf_REF)
146174a9 2965 gv = cGVOP_gv;
fb73857a 2966 else if (isGV(TOPs))
2967 gv = (GV*)POPs;
2968 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
2969 gv = (GV*)SvRV(POPs);
a0d0e21e 2970 else
2d8e6c8d 2971 gv = gv_fetchpv(tmps = POPpx, FALSE, SVt_PVIO);
fb73857a 2972
a0d0e21e 2973 if (GvIO(gv) && IoIFP(GvIOp(gv)))
760ac839 2974 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
fb73857a 2975 else if (tmps && isDIGIT(*tmps))
a0d0e21e
LW		 2976 fd = atoi(tmps);
2977 else
2978 RETPUSHUNDEF;
6ad3d225 2979 if (PerlLIO_isatty(fd))
a0d0e21e
LW		 2980 RETPUSHYES;
2981 RETPUSHNO;
2982}
2983
16d20bd9
AD		 2984#if defined(atarist) /* this will work with atariST. Configure will
2985 make guesses for other systems. */
2986# define FILE_base(f) ((f)->_base)
2987# define FILE_ptr(f) ((f)->_ptr)
2988# define FILE_cnt(f) ((f)->_cnt)
2989# define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
a0d0e21e
LW		 2990#endif
2991
2992PP(pp_fttext)
2993{
4e35701f 2994 djSP;
a0d0e21e
LW		 2995 I32 i;
2996 I32 len;
2997 I32 odd = 0;
2998 STDCHAR tbuf[512];
2999 register STDCHAR *s;
3000 register IO *io;
5f05dabc 3001 register SV *sv;
3002 GV *gv;
2d8e6c8d 3003 STRLEN n_a;
146174a9 3004 PerlIO *fp;
a0d0e21e 3005
533c011a 3006 if (PL_op->op_flags & OPf_REF)
146174a9 3007 gv = cGVOP_gv;
5f05dabc 3008 else if (isGV(TOPs))
3009 gv = (GV*)POPs;
3010 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3011 gv = (GV*)SvRV(POPs);
3012 else
3013 gv = Nullgv;
3014
3015 if (gv) {
a0d0e21e 3016 EXTEND(SP, 1);
3280af22
NIS		 3017 if (gv == PL_defgv) {
3018 if (PL_statgv)
3019 io = GvIO(PL_statgv);
a0d0e21e 3020 else {
3280af22 3021 sv = PL_statname;
a0d0e21e
LW		 3022 goto really_filename;
3023 }
3024 }
3025 else {
3280af22
NIS		 3026 PL_statgv = gv;
3027 PL_laststatval = -1;
3028 sv_setpv(PL_statname, "");
3029 io = GvIO(PL_statgv);
a0d0e21e
LW		 3030 }
3031 if (io && IoIFP(io)) {
5f05dabc 3032 if (! PerlIO_has_base(IoIFP(io)))
cea2e8a9 3033 DIE(aTHX_ "-T and -B not implemented on filehandles");
3280af22
NIS		 3034 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3035 if (PL_laststatval < 0)
5f05dabc 3036 RETPUSHUNDEF;
3280af22 3037 if (S_ISDIR(PL_statcache.st_mode)) /* handle NFS glitch */
533c011a 3038 if (PL_op->op_type == OP_FTTEXT)
a0d0e21e
LW		 3039 RETPUSHNO;
3040 else
3041 RETPUSHYES;
a20bf0c3 3042 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
760ac839 3043 i = PerlIO_getc(IoIFP(io));
a0d0e21e 3044 if (i != EOF)
760ac839 3045 (void)PerlIO_ungetc(IoIFP(io),i);
a0d0e21e 3046 }
a20bf0c3 3047 if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
a0d0e21e 3048 RETPUSHYES;
a20bf0c3
JH		 3049 len = PerlIO_get_bufsiz(IoIFP(io));
3050 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
760ac839
LW		 3051 /* sfio can have large buffers - limit to 512 */
3052 if (len > 512)
3053 len = 512;
a0d0e21e
LW		 3054 }
3055 else {
146174a9
CB		 3056 if (ckWARN(WARN_UNOPENED)) {
3057 gv = cGVOP_gv;
cea2e8a9 3058 Perl_warner(aTHX_ WARN_UNOPENED, "Test on unopened file <%s>",
146174a9
CB		 3059 GvENAME(gv));
3060 }
748a9306 3061 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW		 3062 RETPUSHUNDEF;
3063 }
3064 }
3065 else {
3066 sv = POPs;
5f05dabc 3067 really_filename:
3280af22
NIS		 3068 PL_statgv = Nullgv;
3069 PL_laststatval = -1;
2d8e6c8d 3070 sv_setpv(PL_statname, SvPV(sv, n_a));
146174a9 3071 if (!(fp = PerlIO_open(SvPVX(PL_statname), "r"))) {
2d8e6c8d 3072 if (ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, n_a), '\n'))
cea2e8a9 3073 Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "open");
a0d0e21e
LW		 3074 RETPUSHUNDEF;
3075 }
146174a9
CB		 3076 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3077 if (PL_laststatval < 0) {
3078 (void)PerlIO_close(fp);
5f05dabc 3079 RETPUSHUNDEF;
146174a9
CB		 3080 }
3081 do_binmode(fp, '<', TRUE);
3082 len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3083 (void)PerlIO_close(fp);
a0d0e21e 3084 if (len <= 0) {
533c011a 3085 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
a0d0e21e
LW		 3086 RETPUSHNO; /* special case NFS directories */
3087 RETPUSHYES; /* null file is anything */
3088 }
3089 s = tbuf;
3090 }
3091
3092 /* now scan s to look for textiness */
4633a7c4 3093 /* XXX ASCII dependent code */
a0d0e21e 3094
146174a9
CB		 3095#if defined(DOSISH) || defined(USEMYBINMODE)
3096 /* ignore trailing ^Z on short files */
3097 if (len && len < sizeof(tbuf) && tbuf[len-1] == 26)
3098 --len;
3099#endif
3100
a0d0e21e
LW		 3101 for (i = 0; i < len; i++, s++) {
3102 if (!*s) { /* null never allowed in text */
3103 odd += len;
3104 break;
3105 }
9d116dd7
JH		 3106#ifdef EBCDIC
3107 else if (!(isPRINT(*s) || isSPACE(*s)))
3108 odd++;
3109#else
146174a9
CB		 3110 else if (*s & 128) {
3111#ifdef USE_LOCALE
b3f66c68
GS		 3112 if ((PL_op->op_private & OPpLOCALE) && isALPHA_LC(*s))
3113 continue;
3114#endif
3115 /* utf8 characters don't count as odd */
3116 if (*s & 0x40) {
3117 int ulen = UTF8SKIP(s);
3118 if (ulen < len - i) {
3119 int j;
3120 for (j = 1; j < ulen; j++) {
3121 if ((s[j] & 0xc0) != 0x80)
3122 goto not_utf8;
3123 }
3124 --ulen; /* loop does extra increment */
3125 s += ulen;
3126 i += ulen;
3127 continue;
3128 }
3129 }
3130 not_utf8:
3131 odd++;
146174a9 3132 }
a0d0e21e
LW		 3133 else if (*s < 32 &&
3134 *s != '\n' && *s != '\r' && *s != '\b' &&
3135 *s != '\t' && *s != '\f' && *s != 27)
3136 odd++;
9d116dd7 3137#endif
a0d0e21e
LW		 3138 }
3139
533c011a 3140 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
a0d0e21e
LW		 3141 RETPUSHNO;
3142 else
3143 RETPUSHYES;
3144}
3145
3146PP(pp_ftbinary)
3147{
cea2e8a9 3148 return pp_fttext();
a0d0e21e
LW		 3149}
3150
3151/* File calls. */
3152
3153PP(pp_chdir)
3154{
4e35701f 3155 djSP; dTARGET;
a0d0e21e
LW		 3156 char *tmps;
3157 SV **svp;
2d8e6c8d 3158 STRLEN n_a;
a0d0e21e
LW		 3159
3160 if (MAXARG < 1)
3161 tmps = Nullch;
3162 else
2d8e6c8d 3163 tmps = POPpx;
a0d0e21e 3164 if (!tmps || !*tmps) {
3280af22 3165 svp = hv_fetch(GvHVn(PL_envgv), "HOME", 4, FALSE);
a0d0e21e 3166 if (svp)
2d8e6c8d 3167 tmps = SvPV(*svp, n_a);
a0d0e21e
LW		 3168 }
3169 if (!tmps || !*tmps) {
3280af22 3170 svp = hv_fetch(GvHVn(PL_envgv), "LOGDIR", 6, FALSE);
a0d0e21e 3171 if (svp)
2d8e6c8d 3172 tmps = SvPV(*svp, n_a);
a0d0e21e 3173 }
491527d0
GS		 3174#ifdef VMS
3175 if (!tmps || !*tmps) {
6b88bc9c 3176 svp = hv_fetch(GvHVn(PL_envgv), "SYS$LOGIN", 9, FALSE);
491527d0 3177 if (svp)
2d8e6c8d 3178 tmps = SvPV(*svp, n_a);
491527d0
GS		 3179 }
3180#endif
a0d0e21e 3181 TAINT_PROPER("chdir");
6ad3d225 3182 PUSHi( PerlDir_chdir(tmps) >= 0 );
748a9306
LW		 3183#ifdef VMS
3184 /* Clear the DEFAULT element of ENV so we'll get the new value
3185 * in the future. */
6b88bc9c 3186 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
748a9306 3187#endif
a0d0e21e
LW		 3188 RETURN;
3189}
3190
3191PP(pp_chown)
3192{
4e35701f 3193 djSP; dMARK; dTARGET;
a0d0e21e
LW		 3194 I32 value;
3195#ifdef HAS_CHOWN
533c011a 3196 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 3197 SP = MARK;
3198 PUSHi(value);
3199 RETURN;
3200#else
cea2e8a9 3201 DIE(aTHX_ PL_no_func, "Unsupported function chown");
a0d0e21e
LW		 3202#endif
3203}
3204
3205PP(pp_chroot)
3206{
4e35701f 3207 djSP; dTARGET;
a0d0e21e
LW		 3208 char *tmps;
3209#ifdef HAS_CHROOT
2d8e6c8d
GS		 3210 STRLEN n_a;
3211 tmps = POPpx;
a0d0e21e
LW		 3212 TAINT_PROPER("chroot");
3213 PUSHi( chroot(tmps) >= 0 );
3214 RETURN;
3215#else
cea2e8a9 3216 DIE(aTHX_ PL_no_func, "chroot");
a0d0e21e
LW		 3217#endif
3218}
3219
3220PP(pp_unlink)
3221{
4e35701f 3222 djSP; dMARK; dTARGET;
a0d0e21e 3223 I32 value;
533c011a 3224 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 3225 SP = MARK;
3226 PUSHi(value);
3227 RETURN;
3228}
3229
3230PP(pp_chmod)
3231{
4e35701f 3232 djSP; dMARK; dTARGET;
a0d0e21e 3233 I32 value;
533c011a 3234 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 3235 SP = MARK;
3236 PUSHi(value);
3237 RETURN;
3238}
3239
3240PP(pp_utime)
3241{
4e35701f 3242 djSP; dMARK; dTARGET;
a0d0e21e 3243 I32 value;
533c011a 3244 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 3245 SP = MARK;
3246 PUSHi(value);
3247 RETURN;
3248}
3249
3250PP(pp_rename)
3251{
4e35701f 3252 djSP; dTARGET;
a0d0e21e 3253 int anum;
2d8e6c8d 3254 STRLEN n_a;
a0d0e21e 3255
2d8e6c8d
GS		 3256 char *tmps2 = POPpx;
3257 char *tmps = SvPV(TOPs, n_a);
a0d0e21e
LW		 3258 TAINT_PROPER("rename");
3259#ifdef HAS_RENAME
baed7233 3260 anum = PerlLIO_rename(tmps, tmps2);
a0d0e21e 3261#else
6b88bc9c 3262 if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
ed969818
W		 3263 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3264 anum = 1;
3265 else {
3654eb6c 3266 if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
ed969818
W		 3267 (void)UNLINK(tmps2);
3268 if (!(anum = link(tmps, tmps2)))
3269 anum = UNLINK(tmps);
3270 }
a0d0e21e
LW		 3271 }
3272#endif
3273 SETi( anum >= 0 );
3274 RETURN;
3275}
3276
3277PP(pp_link)
3278{
4e35701f 3279 djSP; dTARGET;
a0d0e21e 3280#ifdef HAS_LINK
2d8e6c8d
GS		 3281 STRLEN n_a;
3282 char *tmps2 = POPpx;
3283 char *tmps = SvPV(TOPs, n_a);
a0d0e21e 3284 TAINT_PROPER("link");
146174a9 3285 SETi( PerlLIO_link(tmps, tmps2) >= 0 );
a0d0e21e 3286#else
cea2e8a9 3287 DIE(aTHX_ PL_no_func, "Unsupported function link");
a0d0e21e
LW		 3288#endif
3289 RETURN;
3290}
3291
3292PP(pp_symlink)
3293{
4e35701f 3294 djSP; dTARGET;
a0d0e21e 3295#ifdef HAS_SYMLINK
2d8e6c8d
GS		 3296 STRLEN n_a;
3297 char *tmps2 = POPpx;
3298 char *tmps = SvPV(TOPs, n_a);
a0d0e21e
LW		 3299 TAINT_PROPER("symlink");
3300 SETi( symlink(tmps, tmps2) >= 0 );
3301 RETURN;
3302#else
cea2e8a9 3303 DIE(aTHX_ PL_no_func, "symlink");
a0d0e21e
LW		 3304#endif
3305}
3306
3307PP(pp_readlink)
3308{
4e35701f 3309 djSP; dTARGET;
a0d0e21e
LW		 3310#ifdef HAS_SYMLINK
3311 char *tmps;
46fc3d4c 3312 char buf[MAXPATHLEN];
a0d0e21e 3313 int len;
2d8e6c8d 3314 STRLEN n_a;
46fc3d4c 3315
fb73857a 3316#ifndef INCOMPLETE_TAINTS
3317 TAINT;
3318#endif
2d8e6c8d 3319 tmps = POPpx;
a0d0e21e
LW		 3320 len = readlink(tmps, buf, sizeof buf);
3321 EXTEND(SP, 1);
3322 if (len < 0)
3323 RETPUSHUNDEF;
3324 PUSHp(buf, len);
3325 RETURN;
3326#else
3327 EXTEND(SP, 1);
3328 RETSETUNDEF; /* just pretend it's a normal file */
3329#endif
3330}
3331
3332#if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
ba106d47 3333STATIC int
cea2e8a9 3334S_dooneliner(pTHX_ char *cmd, char *filename)
a0d0e21e 3335{
1e422769 3336 char *save_filename = filename;
3337 char *cmdline;
3338 char *s;
760ac839 3339 PerlIO *myfp;
1e422769 3340 int anum = 1;
a0d0e21e 3341
1e422769 3342 New(666, cmdline, strlen(cmd) + (strlen(filename) * 2) + 10, char);
3343 strcpy(cmdline, cmd);
3344 strcat(cmdline, " ");
3345 for (s = cmdline + strlen(cmdline); *filename; ) {
a0d0e21e
LW		 3346 *s++ = '\\';
3347 *s++ = *filename++;
3348 }
3349 strcpy(s, " 2>&1");
6ad3d225 3350 myfp = PerlProc_popen(cmdline, "r");
1e422769 3351 Safefree(cmdline);
3352
a0d0e21e 3353 if (myfp) {
1e422769 3354 SV *tmpsv = sv_newmortal();
6b88bc9c 3355 /* Need to save/restore 'PL_rs' ?? */
760ac839 3356 s = sv_gets(tmpsv, myfp, 0);
6ad3d225 3357 (void)PerlProc_pclose(myfp);
a0d0e21e 3358 if (s != Nullch) {
1e422769 3359 int e;
3360 for (e = 1;
a0d0e21e 3361#ifdef HAS_SYS_ERRLIST
1e422769 3362 e <= sys_nerr
3363#endif
3364 ; e++)
3365 {
3366 /* you don't see this */
3367 char *errmsg =
3368#ifdef HAS_SYS_ERRLIST
3369 sys_errlist[e]
a0d0e21e 3370#else
1e422769 3371 strerror(e)
a0d0e21e 3372#endif
1e422769 3373 ;
3374 if (!errmsg)
3375 break;
3376 if (instr(s, errmsg)) {
3377 SETERRNO(e,0);
3378 return 0;
3379 }
a0d0e21e 3380 }
748a9306 3381 SETERRNO(0,0);
a0d0e21e
LW		 3382#ifndef EACCES
3383#define EACCES EPERM
3384#endif
1e422769 3385 if (instr(s, "cannot make"))
748a9306 3386 SETERRNO(EEXIST,RMS$_FEX);
1e422769 3387 else if (instr(s, "existing file"))
748a9306 3388 SETERRNO(EEXIST,RMS$_FEX);
1e422769 3389 else if (instr(s, "ile exists"))
748a9306 3390 SETERRNO(EEXIST,RMS$_FEX);
1e422769 3391 else if (instr(s, "non-exist"))
748a9306 3392 SETERRNO(ENOENT,RMS$_FNF);
1e422769 3393 else if (instr(s, "does not exist"))
748a9306 3394 SETERRNO(ENOENT,RMS$_FNF);
1e422769 3395 else if (instr(s, "not empty"))
748a9306 3396 SETERRNO(EBUSY,SS$_DEVOFFLINE);
1e422769 3397 else if (instr(s, "cannot access"))
748a9306 3398 SETERRNO(EACCES,RMS$_PRV);
a0d0e21e 3399 else
748a9306 3400 SETERRNO(EPERM,RMS$_PRV);
a0d0e21e
LW		 3401 return 0;
3402 }
3403 else { /* some mkdirs return no failure indication */
6b88bc9c 3404 anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
911d147d 3405 if (PL_op->op_type == OP_RMDIR)
a0d0e21e
LW		 3406 anum = !anum;
3407 if (anum)
748a9306 3408 SETERRNO(0,0);
a0d0e21e 3409 else
748a9306 3410 SETERRNO(EACCES,RMS$_PRV); /* a guess */
a0d0e21e
LW		 3411 }
3412 return anum;
3413 }
3414 else
3415 return 0;
3416}
3417#endif
3418
3419PP(pp_mkdir)
3420{
4e35701f 3421 djSP; dTARGET;
5a211162 3422 int mode;
a0d0e21e
LW		 3423#ifndef HAS_MKDIR
3424 int oldumask;
3425#endif
2d8e6c8d 3426 STRLEN n_a;
5a211162
GS		 3427 char *tmps;
3428
3429 if (MAXARG > 1)
3430 mode = POPi;
3431 else
3432 mode = 0777;
3433
3434 tmps = SvPV(TOPs, n_a);
a0d0e21e
LW		 3435
3436 TAINT_PROPER("mkdir");
3437#ifdef HAS_MKDIR
6ad3d225 3438 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
a0d0e21e
LW		 3439#else
3440 SETi( dooneliner("mkdir", tmps) );
6ad3d225
GS		 3441 oldumask = PerlLIO_umask(0);
3442 PerlLIO_umask(oldumask);
3443 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
a0d0e21e
LW		 3444#endif
3445 RETURN;
3446}
3447
3448PP(pp_rmdir)
3449{
4e35701f 3450 djSP; dTARGET;
a0d0e21e 3451 char *tmps;
2d8e6c8d 3452 STRLEN n_a;
a0d0e21e 3453
2d8e6c8d 3454 tmps = POPpx;
a0d0e21e
LW		 3455 TAINT_PROPER("rmdir");
3456#ifdef HAS_RMDIR
6ad3d225 3457 XPUSHi( PerlDir_rmdir(tmps) >= 0 );
a0d0e21e
LW		 3458#else
3459 XPUSHi( dooneliner("rmdir", tmps) );
3460#endif
3461 RETURN;
3462}
3463
3464/* Directory calls. */
3465
3466PP(pp_open_dir)
3467{
4e35701f 3468 djSP;
a0d0e21e 3469#if defined(Direntry_t) && defined(HAS_READDIR)
2d8e6c8d
GS		 3470 STRLEN n_a;
3471 char *dirname = POPpx;
a0d0e21e
LW		 3472 GV *gv = (GV*)POPs;
3473 register IO *io = GvIOn(gv);
3474
3475 if (!io)
3476 goto nope;
3477
3478 if (IoDIRP(io))
6ad3d225
GS		 3479 PerlDir_close(IoDIRP(io));
3480 if (!(IoDIRP(io) = PerlDir_open(dirname)))
a0d0e21e
LW		 3481 goto nope;
3482
3483 RETPUSHYES;
3484nope:
3485 if (!errno)
748a9306 3486 SETERRNO(EBADF,RMS$_DIR);
a0d0e21e
LW		 3487 RETPUSHUNDEF;
3488#else
cea2e8a9 3489 DIE(aTHX_ PL_no_dir_func, "opendir");
a0d0e21e
LW		 3490#endif
3491}
3492
3493PP(pp_readdir)
3494{
4e35701f 3495 djSP;
a0d0e21e
LW		 3496#if defined(Direntry_t) && defined(HAS_READDIR)
3497#ifndef I_DIRENT
20ce7b12 3498 Direntry_t *readdir (DIR *);
a0d0e21e
LW		 3499#endif
3500 register Direntry_t *dp;
3501 GV *gv = (GV*)POPs;
3502 register IO *io = GvIOn(gv);
fb73857a 3503 SV *sv;
a0d0e21e
LW		 3504
3505 if (!io || !IoDIRP(io))
3506 goto nope;
3507
3508 if (GIMME == G_ARRAY) {
3509 /*SUPPRESS 560*/
155aba94 3510 while ((dp = (Direntry_t *)PerlDir_read(IoDIRP(io)))) {
a0d0e21e 3511#ifdef DIRNAMLEN
79cb57f6 3512 sv = newSVpvn(dp->d_name, dp->d_namlen);
a0d0e21e 3513#else
fb73857a 3514 sv = newSVpv(dp->d_name, 0);
3515#endif
3516#ifndef INCOMPLETE_TAINTS
26fb8f1f
GS		 3517 if (!(IoFLAGS(io) & IOf_UNTAINT))
3518 SvTAINTED_on(sv);
a0d0e21e 3519#endif
fb73857a 3520 XPUSHs(sv_2mortal(sv));
a0d0e21e
LW		 3521 }
3522 }
3523 else {
6ad3d225 3524 if (!(dp = (Direntry_t *)PerlDir_read(IoDIRP(io))))
a0d0e21e
LW		 3525 goto nope;
3526#ifdef DIRNAMLEN
79cb57f6 3527 sv = newSVpvn(dp->d_name, dp->d_namlen);
a0d0e21e 3528#else
fb73857a 3529 sv = newSVpv(dp->d_name, 0);
a0d0e21e 3530#endif
fb73857a 3531#ifndef INCOMPLETE_TAINTS
26fb8f1f
GS		 3532 if (!(IoFLAGS(io) & IOf_UNTAINT))
3533 SvTAINTED_on(sv);
fb73857a 3534#endif
3535 XPUSHs(sv_2mortal(sv));
a0d0e21e
LW		 3536 }
3537 RETURN;
3538
3539nope:
3540 if (!errno)
748a9306 3541 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 3542 if (GIMME == G_ARRAY)
3543 RETURN;
3544 else
3545 RETPUSHUNDEF;
3546#else
cea2e8a9 3547 DIE(aTHX_ PL_no_dir_func, "readdir");
a0d0e21e
LW		 3548#endif
3549}
3550
3551PP(pp_telldir)
3552{
4e35701f 3553 djSP; dTARGET;
a0d0e21e 3554#if defined(HAS_TELLDIR) || defined(telldir)
968dcd91
JH		 3555 /* XXX does _anyone_ need this? --AD 2/20/1998 */
3556 /* XXX netbsd still seemed to.
3557 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3558 --JHI 1999-Feb-02 */
3559# if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
20ce7b12 3560 long telldir (DIR *);
dfe9444c 3561# endif
a0d0e21e
LW		 3562 GV *gv = (GV*)POPs;
3563 register IO *io = GvIOn(gv);
3564
3565 if (!io || !IoDIRP(io))
3566 goto nope;
3567
6ad3d225 3568 PUSHi( PerlDir_tell(IoDIRP(io)) );
a0d0e21e
LW		 3569 RETURN;
3570nope:
3571 if (!errno)
748a9306 3572 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 3573 RETPUSHUNDEF;
3574#else
cea2e8a9 3575 DIE(aTHX_ PL_no_dir_func, "telldir");
a0d0e21e
LW		 3576#endif
3577}
3578
3579PP(pp_seekdir)
3580{
4e35701f 3581 djSP;
a0d0e21e
LW		 3582#if defined(HAS_SEEKDIR) || defined(seekdir)
3583 long along = POPl;
3584 GV *gv = (GV*)POPs;
3585 register IO *io = GvIOn(gv);
3586
3587 if (!io || !IoDIRP(io))
3588 goto nope;
3589
6ad3d225 3590 (void)PerlDir_seek(IoDIRP(io), along);
a0d0e21e
LW		 3591
3592 RETPUSHYES;
3593nope:
3594 if (!errno)
748a9306 3595 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 3596 RETPUSHUNDEF;
3597#else
cea2e8a9 3598 DIE(aTHX_ PL_no_dir_func, "seekdir");
a0d0e21e
LW		 3599#endif
3600}
3601
3602PP(pp_rewinddir)
3603{
4e35701f 3604 djSP;
a0d0e21e
LW		 3605#if defined(HAS_REWINDDIR) || defined(rewinddir)
3606 GV *gv = (GV*)POPs;
3607 register IO *io = GvIOn(gv);
3608
3609 if (!io || !IoDIRP(io))
3610 goto nope;
3611
6ad3d225 3612 (void)PerlDir_rewind(IoDIRP(io));
a0d0e21e
LW		 3613 RETPUSHYES;
3614nope:
3615 if (!errno)
748a9306 3616 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 3617 RETPUSHUNDEF;
3618#else
cea2e8a9 3619 DIE(aTHX_ PL_no_dir_func, "rewinddir");
a0d0e21e
LW		 3620#endif
3621}
3622
3623PP(pp_closedir)
3624{
4e35701f 3625 djSP;
a0d0e21e
LW		 3626#if defined(Direntry_t) && defined(HAS_READDIR)
3627 GV *gv = (GV*)POPs;
3628 register IO *io = GvIOn(gv);
3629
3630 if (!io || !IoDIRP(io))
3631 goto nope;
3632
3633#ifdef VOID_CLOSEDIR
6ad3d225 3634 PerlDir_close(IoDIRP(io));
a0d0e21e 3635#else
6ad3d225 3636 if (PerlDir_close(IoDIRP(io)) < 0) {
748a9306 3637 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
a0d0e21e 3638 goto nope;
748a9306 3639 }
a0d0e21e
LW		 3640#endif
3641 IoDIRP(io) = 0;
3642
3643 RETPUSHYES;
3644nope:
3645 if (!errno)
748a9306 3646 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW		 3647 RETPUSHUNDEF;
3648#else
cea2e8a9 3649 DIE(aTHX_ PL_no_dir_func, "closedir");
a0d0e21e
LW		 3650#endif
3651}
3652
3653/* Process control. */
3654
3655PP(pp_fork)
3656{
44a8e56a 3657#ifdef HAS_FORK
4e35701f 3658 djSP; dTARGET;
761237fe 3659 Pid_t childpid;
a0d0e21e
LW		 3660 GV *tmpgv;
3661
3662 EXTEND(SP, 1);
45bc9206 3663 PERL_FLUSHALL_FOR_CHILD;
a0d0e21e
LW		 3664 childpid = fork();
3665 if (childpid < 0)
3666 RETSETUNDEF;
3667 if (!childpid) {
3668 /*SUPPRESS 560*/
155aba94 3669 if ((tmpgv = gv_fetchpv("$", TRUE, SVt_PV)))
146174a9 3670 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3280af22 3671 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
a0d0e21e
LW		 3672 }
3673 PUSHi(childpid);
3674 RETURN;
3675#else
146174a9
CB		 3676# if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3677 djSP; dTARGET;
3678 Pid_t childpid;
3679
3680 EXTEND(SP, 1);
3681 PERL_FLUSHALL_FOR_CHILD;
3682 childpid = PerlProc_fork();
3683 PUSHi(childpid);
3684 RETURN;
3685# else
cea2e8a9 3686 DIE(aTHX_ PL_no_func, "Unsupported function fork");
146174a9 3687# endif
a0d0e21e
LW		 3688#endif
3689}
3690
3691PP(pp_wait)
3692{
146174a9 3693#if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
4e35701f 3694 djSP; dTARGET;
761237fe 3695 Pid_t childpid;
a0d0e21e 3696 int argflags;
a0d0e21e 3697
44a8e56a 3698 childpid = wait4pid(-1, &argflags, 0);
f86702cc 3699 STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
44a8e56a 3700 XPUSHi(childpid);
a0d0e21e
LW		 3701 RETURN;
3702#else
cea2e8a9 3703 DIE(aTHX_ PL_no_func, "Unsupported function wait");
a0d0e21e
LW		 3704#endif
3705}
3706
3707PP(pp_waitpid)
3708{
146174a9 3709#if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
4e35701f 3710 djSP; dTARGET;
761237fe 3711 Pid_t childpid;
a0d0e21e
LW		 3712 int optype;
3713 int argflags;
a0d0e21e 3714
a0d0e21e
LW		 3715 optype = POPi;
3716 childpid = TOPi;
3717 childpid = wait4pid(childpid, &argflags, optype);
f86702cc 3718 STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
44a8e56a 3719 SETi(childpid);
a0d0e21e
LW		 3720 RETURN;
3721#else
cea2e8a9 3722 DIE(aTHX_ PL_no_func, "Unsupported function waitpid");
a0d0e21e
LW		 3723#endif
3724}
3725
3726PP(pp_system)
3727{
4e35701f 3728 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e 3729 I32 value;
761237fe 3730 Pid_t childpid;
a0d0e21e
LW		 3731 int result;
3732 int status;
ff68c719 3733 Sigsave_t ihand,qhand; /* place to save signals during system() */
2d8e6c8d 3734 STRLEN n_a;
d5a9bfb0
IZ		 3735 I32 did_pipes = 0;
3736 int pp[2];
a0d0e21e 3737
a0d0e21e 3738 if (SP - MARK == 1) {
3280af22 3739 if (PL_tainting) {
2d8e6c8d 3740 char *junk = SvPV(TOPs, n_a);
a0d0e21e
LW		 3741 TAINT_ENV();
3742 TAINT_PROPER("system");
3743 }
3744 }
45bc9206 3745 PERL_FLUSHALL_FOR_CHILD;
1e422769 3746#if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2)
d5a9bfb0
IZ		 3747 if (PerlProc_pipe(pp) >= 0)
3748 did_pipes = 1;
a0d0e21e
LW		 3749 while ((childpid = vfork()) == -1) {
3750 if (errno != EAGAIN) {
3751 value = -1;
3752 SP = ORIGMARK;
3753 PUSHi(value);
d5a9bfb0
IZ		 3754 if (did_pipes) {
3755 PerlLIO_close(pp[0]);
3756 PerlLIO_close(pp[1]);
3757 }
a0d0e21e
LW		 3758 RETURN;
3759 }
3760 sleep(5);
3761 }
3762 if (childpid > 0) {
d5a9bfb0
IZ		 3763 if (did_pipes)
3764 PerlLIO_close(pp[1]);
ff68c719 3765 rsignal_save(SIGINT, SIG_IGN, &ihand);
3766 rsignal_save(SIGQUIT, SIG_IGN, &qhand);
748a9306
LW		 3767 do {
3768 result = wait4pid(childpid, &status, 0);
3769 } while (result == -1 && errno == EINTR);
ff68c719 3770 (void)rsignal_restore(SIGINT, &ihand);
3771 (void)rsignal_restore(SIGQUIT, &qhand);
91e9c03f 3772 STATUS_NATIVE_SET(result == -1 ? -1 : status);
a0d0e21e
LW		 3773 do_execfree(); /* free any memory child malloced on vfork */
3774 SP = ORIGMARK;
d5a9bfb0
IZ		 3775 if (did_pipes) {
3776 int errkid;
3777 int n = 0, n1;
3778
3779 while (n < sizeof(int)) {
3780 n1 = PerlLIO_read(pp[0],
3781 (void*)(((char*)&errkid)+n),
3782 (sizeof(int)) - n);
3783 if (n1 <= 0)
3784 break;
3785 n += n1;
3786 }
3787 PerlLIO_close(pp[0]);
3788 if (n) { /* Error */
3789 if (n != sizeof(int))
c529f79d 3790 DIE(aTHX_ "panic: kid popen errno read");
d5a9bfb0
IZ		 3791 errno = errkid; /* Propagate errno from kid */
3792 STATUS_CURRENT = -1;
3793 }
3794 }
ff0cee69 3795 PUSHi(STATUS_CURRENT);
a0d0e21e
LW		 3796 RETURN;
3797 }
d5a9bfb0
IZ		 3798 if (did_pipes) {
3799 PerlLIO_close(pp[0]);
3800#if defined(HAS_FCNTL) && defined(F_SETFD)
3801 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
3802#endif
3803 }
533c011a 3804 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e 3805 SV *really = *++MARK;
d5a9bfb0 3806 value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
a0d0e21e
LW		 3807 }
3808 else if (SP - MARK != 1)
d5a9bfb0 3809 value = (I32)do_aexec5(Nullsv, MARK, SP, pp[1], did_pipes);
a0d0e21e 3810 else {
d5a9bfb0 3811 value = (I32)do_exec3(SvPVx(sv_mortalcopy(*SP), n_a), pp[1], did_pipes);
a0d0e21e 3812 }
6ad3d225 3813 PerlProc__exit(-1);
c3293030 3814#else /* ! FORK or VMS or OS/2 */
911d147d 3815 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e 3816 SV *really = *++MARK;
c5be433b 3817 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
a0d0e21e
LW		 3818 }
3819 else if (SP - MARK != 1)
c5be433b 3820 value = (I32)do_aspawn(Nullsv, (void **)MARK, (void **)SP);
a0d0e21e 3821 else {
c5be433b 3822 value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
a0d0e21e 3823 }
f86702cc 3824 STATUS_NATIVE_SET(value);
a0d0e21e
LW		 3825 do_execfree();
3826 SP = ORIGMARK;
ff0cee69 3827 PUSHi(STATUS_CURRENT);
a0d0e21e
LW		 3828#endif /* !FORK or VMS */
3829 RETURN;
3830}
3831
3832PP(pp_exec)
3833{
4e35701f 3834 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e 3835 I32 value;
2d8e6c8d 3836 STRLEN n_a;
a0d0e21e 3837
45bc9206 3838 PERL_FLUSHALL_FOR_CHILD;
533c011a 3839 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e
LW		 3840 SV *really = *++MARK;
3841 value = (I32)do_aexec(really, MARK, SP);
3842 }
3843 else if (SP - MARK != 1)
3844#ifdef VMS
3845 value = (I32)vms_do_aexec(Nullsv, MARK, SP);
3846#else
092bebab
JH		 3847# ifdef __OPEN_VM
3848 {
c5be433b 3849 (void ) do_aspawn(Nullsv, MARK, SP);
092bebab
JH		 3850 value = 0;
3851 }
3852# else
a0d0e21e 3853 value = (I32)do_aexec(Nullsv, MARK, SP);
092bebab 3854# endif
a0d0e21e
LW		 3855#endif
3856 else {
3280af22 3857 if (PL_tainting) {
2d8e6c8d 3858 char *junk = SvPV(*SP, n_a);
a0d0e21e
LW		 3859 TAINT_ENV();
3860 TAINT_PROPER("exec");
3861 }
3862#ifdef VMS
2d8e6c8d 3863 value = (I32)vms_do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
a0d0e21e 3864#else
092bebab 3865# ifdef __OPEN_VM
c5be433b 3866 (void) do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
092bebab
JH		 3867 value = 0;
3868# else
2d8e6c8d 3869 value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
092bebab 3870# endif
a0d0e21e
LW		 3871#endif
3872 }
146174a9
CB		 3873
3874#if !defined(HAS_FORK) && defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3875 if (value >= 0)
3876 my_exit(value);
3877#endif
3878
a0d0e21e
LW		 3879 SP = ORIGMARK;
3880 PUSHi(value);
3881 RETURN;
3882}
3883
3884PP(pp_kill)
3885{
4e35701f 3886 djSP; dMARK; dTARGET;
a0d0e21e
LW		 3887 I32 value;
3888#ifdef HAS_KILL
533c011a 3889 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 3890 SP = MARK;
3891 PUSHi(value);
3892 RETURN;
3893#else
cea2e8a9 3894 DIE(aTHX_ PL_no_func, "Unsupported function kill");
a0d0e21e
LW		 3895#endif
3896}
3897
3898PP(pp_getppid)
3899{
3900#ifdef HAS_GETPPID
4e35701f 3901 djSP; dTARGET;
a0d0e21e
LW		 3902 XPUSHi( getppid() );
3903 RETURN;
3904#else
cea2e8a9 3905 DIE(aTHX_ PL_no_func, "getppid");
a0d0e21e
LW		 3906#endif
3907}
3908
3909PP(pp_getpgrp)
3910{
3911#ifdef HAS_GETPGRP
4e35701f 3912 djSP; dTARGET;
d8a83dd3 3913 Pid_t pid;
9853a804 3914 Pid_t pgrp;
a0d0e21e
LW		 3915
3916 if (MAXARG < 1)
3917 pid = 0;
3918 else
3919 pid = SvIVx(POPs);
c3293030 3920#ifdef BSD_GETPGRP
9853a804 3921 pgrp = (I32)BSD_GETPGRP(pid);
a0d0e21e 3922#else
146174a9 3923 if (pid != 0 && pid != PerlProc_getpid())
cea2e8a9 3924 DIE(aTHX_ "POSIX getpgrp can't take an argument");
9853a804 3925 pgrp = getpgrp();
a0d0e21e 3926#endif
9853a804 3927 XPUSHi(pgrp);
a0d0e21e
LW		 3928 RETURN;
3929#else
cea2e8a9 3930 DIE(aTHX_ PL_no_func, "getpgrp()");
a0d0e21e
LW		 3931#endif
3932}
3933
3934PP(pp_setpgrp)
3935{
3936#ifdef HAS_SETPGRP
4e35701f 3937 djSP; dTARGET;
d8a83dd3
JH		 3938 Pid_t pgrp;
3939 Pid_t pid;
a0d0e21e
LW		 3940 if (MAXARG < 2) {
3941 pgrp = 0;
3942 pid = 0;
3943 }
3944 else {
3945 pgrp = POPi;
3946 pid = TOPi;
3947 }
3948
3949 TAINT_PROPER("setpgrp");
c3293030
IZ		 3950#ifdef BSD_SETPGRP
3951 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
a0d0e21e 3952#else
146174a9
CB		 3953 if ((pgrp != 0 && pgrp != PerlProc_getpid())
3954 || (pid != 0 && pid != PerlProc_getpid()))
3955 {
3956 DIE(aTHX_ "setpgrp can't take arguments");
3957 }
a0d0e21e
LW		 3958 SETi( setpgrp() >= 0 );
3959#endif /* USE_BSDPGRP */
3960 RETURN;
3961#else
cea2e8a9 3962 DIE(aTHX_ PL_no_func, "setpgrp()");
a0d0e21e
LW		 3963#endif
3964}
3965
3966PP(pp_getpriority)
3967{
4e35701f 3968 djSP; dTARGET;
a0d0e21e
LW		 3969 int which;
3970 int who;
3971#ifdef HAS_GETPRIORITY
3972 who = POPi;
3973 which = TOPi;
3974 SETi( getpriority(which, who) );
3975 RETURN;
3976#else
cea2e8a9 3977 DIE(aTHX_ PL_no_func, "getpriority()");
a0d0e21e
LW		 3978#endif
3979}
3980
3981PP(pp_setpriority)
3982{
4e35701f 3983 djSP; dTARGET;
a0d0e21e
LW		 3984 int which;
3985 int who;
3986 int niceval;
3987#ifdef HAS_SETPRIORITY
3988 niceval = POPi;
3989 who = POPi;
3990 which = TOPi;
3991 TAINT_PROPER("setpriority");
3992 SETi( setpriority(which, who, niceval) >= 0 );
3993 RETURN;
3994#else
cea2e8a9 3995 DIE(aTHX_ PL_no_func, "setpriority()");
a0d0e21e
LW		 3996#endif
3997}
3998
3999/* Time calls. */
4000
4001PP(pp_time)
4002{
4e35701f 4003 djSP; dTARGET;
cbdc8872 4004#ifdef BIG_TIME
4005 XPUSHn( time(Null(Time_t*)) );
4006#else
a0d0e21e 4007 XPUSHi( time(Null(Time_t*)) );
cbdc8872 4008#endif
a0d0e21e
LW		 4009 RETURN;
4010}
4011
cd52b7b2 4012/* XXX The POSIX name is CLK_TCK; it is to be preferred
4013 to HZ. Probably. For now, assume that if the system
4014 defines HZ, it does so correctly. (Will this break
4015 on VMS?)
4016 Probably we ought to use _sysconf(_SC_CLK_TCK), if
4017 it's supported. --AD 9/96.
4018*/
4019
a0d0e21e 4020#ifndef HZ
cd52b7b2 4021# ifdef CLK_TCK
4022# define HZ CLK_TCK
4023# else
4024# define HZ 60
4025# endif
a0d0e21e
LW		 4026#endif
4027
4028PP(pp_tms)
4029{
4e35701f 4030 djSP;
a0d0e21e 4031
55497cff 4032#ifndef HAS_TIMES
cea2e8a9 4033 DIE(aTHX_ "times not implemented");
a0d0e21e
LW		 4034#else
4035 EXTEND(SP, 4);
4036
4037#ifndef VMS
3280af22 4038 (void)PerlProc_times(&PL_timesbuf);
a0d0e21e 4039#else
6b88bc9c 4040 (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */
76e3520e
GS		 4041 /* struct tms, though same data */
4042 /* is returned. */
a0d0e21e
LW		 4043#endif
4044
65202027 4045 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_utime)/HZ)));
a0d0e21e 4046 if (GIMME == G_ARRAY) {
65202027
DS		 4047 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_stime)/HZ)));
4048 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cutime)/HZ)));
4049 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cstime)/HZ)));
a0d0e21e
LW		 4050 }
4051 RETURN;
55497cff 4052#endif /* HAS_TIMES */
a0d0e21e
LW		 4053}
4054
4055PP(pp_localtime)
4056{
cea2e8a9 4057 return pp_gmtime();
a0d0e21e
LW		 4058}
4059
4060PP(pp_gmtime)
4061{
4e35701f 4062 djSP;
a0d0e21e
LW		 4063 Time_t when;
4064 struct tm *tmbuf;
4065 static char *dayname[] = {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4066 static char *monname[] = {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4067 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4068
4069 if (MAXARG < 1)
4070 (void)time(&when);
4071 else
cbdc8872 4072#ifdef BIG_TIME
4073 when = (Time_t)SvNVx(POPs);
4074#else
a0d0e21e 4075 when = (Time_t)SvIVx(POPs);
cbdc8872 4076#endif
a0d0e21e 4077
533c011a 4078 if (PL_op->op_type == OP_LOCALTIME)
a0d0e21e
LW		 4079 tmbuf = localtime(&when);
4080 else
4081 tmbuf = gmtime(&when);
4082
4083 EXTEND(SP, 9);
bbce6d69 4084 EXTEND_MORTAL(9);
a0d0e21e 4085 if (GIMME != G_ARRAY) {
46fc3d4c 4086 SV *tsv;
a0d0e21e
LW		 4087 if (!tmbuf)
4088 RETPUSHUNDEF;
cea2e8a9 4089 tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %d",
f5a29b03
RB		 4090 dayname[tmbuf->tm_wday],
4091 monname[tmbuf->tm_mon],
c529f79d
CB		 4092 tmbuf->tm_mday,
4093 tmbuf->tm_hour,
4094 tmbuf->tm_min,
4095 tmbuf->tm_sec,
4096 tmbuf->tm_year + 1900);
46fc3d4c 4097 PUSHs(sv_2mortal(tsv));
a0d0e21e
LW		 4098 }
4099 else if (tmbuf) {
c6419e06
JH		 4100 PUSHs(sv_2mortal(newSViv(tmbuf->tm_sec)));
4101 PUSHs(sv_2mortal(newSViv(tmbuf->tm_min)));
4102 PUSHs(sv_2mortal(newSViv(tmbuf->tm_hour)));
4103 PUSHs(sv_2mortal(newSViv(tmbuf->tm_mday)));
4104 PUSHs(sv_2mortal(newSViv(tmbuf->tm_mon)));
4105 PUSHs(sv_2mortal(newSViv(tmbuf->tm_year)));
4106 PUSHs(sv_2mortal(newSViv(tmbuf->tm_wday)));
4107 PUSHs(sv_2mortal(newSViv(tmbuf->tm_yday)));
4108 PUSHs(sv_2mortal(newSViv(tmbuf->tm_isdst)));
a0d0e21e
LW		 4109 }
4110 RETURN;
4111}
4112
4113PP(pp_alarm)
4114{
4e35701f 4115 djSP; dTARGET;
a0d0e21e
LW		 4116 int anum;
4117#ifdef HAS_ALARM
4118 anum = POPi;
4119 anum = alarm((unsigned int)anum);
4120 EXTEND(SP, 1);
4121 if (anum < 0)
4122 RETPUSHUNDEF;
c6419e06 4123 PUSHi(anum);
a0d0e21e
LW		 4124 RETURN;
4125#else
cea2e8a9 4126 DIE(aTHX_ PL_no_func, "Unsupported function alarm");
a0d0e21e
LW		 4127#endif
4128}
4129
4130PP(pp_sleep)
4131{
4e35701f 4132 djSP; dTARGET;
a0d0e21e
LW		 4133 I32 duration;
4134 Time_t lasttime;
4135 Time_t when;
4136
4137 (void)time(&lasttime);
4138 if (MAXARG < 1)
76e3520e 4139 PerlProc_pause();
a0d0e21e
LW		 4140 else {
4141 duration = POPi;
76e3520e 4142 PerlProc_sleep((unsigned int)duration);
a0d0e21e
LW		 4143 }
4144 (void)time(&when);
4145 XPUSHi(when - lasttime);
4146 RETURN;
4147}
4148
4149/* Shared memory. */
4150
4151PP(pp_shmget)
4152{
cea2e8a9 4153 return pp_semget();
a0d0e21e
LW		 4154}
4155
4156PP(pp_shmctl)
4157{
cea2e8a9 4158 return pp_semctl();
a0d0e21e
LW		 4159}
4160
4161PP(pp_shmread)
4162{
cea2e8a9 4163 return pp_shmwrite();
a0d0e21e
LW		 4164}
4165
4166PP(pp_shmwrite)
4167{
4168#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 4169 djSP; dMARK; dTARGET;
533c011a 4170 I32 value = (I32)(do_shmio(PL_op->op_type, MARK, SP) >= 0);
a0d0e21e
LW		 4171 SP = MARK;
4172 PUSHi(value);
4173 RETURN;
4174#else
cea2e8a9 4175 return pp_semget();
a0d0e21e
LW		 4176#endif
4177}
4178
4179/* Message passing. */
4180
4181PP(pp_msgget)
4182{
cea2e8a9 4183 return pp_semget();
a0d0e21e
LW		 4184}
4185
4186PP(pp_msgctl)
4187{
cea2e8a9 4188 return pp_semctl();
a0d0e21e
LW		 4189}
4190
4191PP(pp_msgsnd)
4192{
4193#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 4194 djSP; dMARK; dTARGET;
a0d0e21e
LW		 4195 I32 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4196 SP = MARK;
4197 PUSHi(value);
4198 RETURN;
4199#else
cea2e8a9 4200 return pp_semget();
a0d0e21e
LW		 4201#endif
4202}
4203
4204PP(pp_msgrcv)
4205{
4206#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 4207 djSP; dMARK; dTARGET;
a0d0e21e
LW		 4208 I32 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4209 SP = MARK;
4210 PUSHi(value);
4211 RETURN;
4212#else
cea2e8a9 4213 return pp_semget();
a0d0e21e
LW		 4214#endif
4215}
4216
4217/* Semaphores. */
4218
4219PP(pp_semget)
4220{
4221#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 4222 djSP; dMARK; dTARGET;
533c011a 4223 int anum = do_ipcget(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 4224 SP = MARK;
4225 if (anum == -1)
4226 RETPUSHUNDEF;
4227 PUSHi(anum);
4228 RETURN;
4229#else
cea2e8a9 4230 DIE(aTHX_ "System V IPC is not implemented on this machine");
a0d0e21e
LW		 4231#endif
4232}
4233
4234PP(pp_semctl)
4235{
4236#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 4237 djSP; dMARK; dTARGET;
533c011a 4238 int anum = do_ipcctl(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 4239 SP = MARK;
4240 if (anum == -1)
4241 RETSETUNDEF;
4242 if (anum != 0) {
4243 PUSHi(anum);
4244 }
4245 else {
8903cb82 4246 PUSHp(zero_but_true, ZBTLEN);
a0d0e21e
LW		 4247 }
4248 RETURN;
4249#else
cea2e8a9 4250 return pp_semget();
a0d0e21e
LW		 4251#endif
4252}
4253
4254PP(pp_semop)
4255{
4256#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 4257 djSP; dMARK; dTARGET;
a0d0e21e
LW		 4258 I32 value = (I32)(do_semop(MARK, SP) >= 0);
4259 SP = MARK;
4260 PUSHi(value);
4261 RETURN;
4262#else
cea2e8a9 4263 return pp_semget();
a0d0e21e
LW		 4264#endif
4265}
4266
4267/* Get system info. */
4268
4269PP(pp_ghbyname)
4270{
693762b4 4271#ifdef HAS_GETHOSTBYNAME
cea2e8a9 4272 return pp_ghostent();
a0d0e21e 4273#else
cea2e8a9 4274 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
a0d0e21e
LW		 4275#endif
4276}
4277
4278PP(pp_ghbyaddr)
4279{
693762b4 4280#ifdef HAS_GETHOSTBYADDR
cea2e8a9 4281 return pp_ghostent();
a0d0e21e 4282#else
cea2e8a9 4283 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
a0d0e21e
LW		 4284#endif
4285}
4286
4287PP(pp_ghostent)
4288{
4e35701f 4289 djSP;
693762b4 4290#if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
533c011a 4291 I32 which = PL_op->op_type;
a0d0e21e
LW		 4292 register char **elem;
4293 register SV *sv;
dc45a647 4294#ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4599a1de
JH		 4295 struct hostent *PerlSock_gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4296 struct hostent *PerlSock_gethostbyname(Netdb_name_t);
6ad3d225 4297 struct hostent *PerlSock_gethostent(void);
a0d0e21e
LW		 4298#endif
4299 struct hostent *hent;
4300 unsigned long len;
2d8e6c8d 4301 STRLEN n_a;
a0d0e21e
LW		 4302
4303 EXTEND(SP, 10);
dc45a647
MB		 4304 if (which == OP_GHBYNAME)
4305#ifdef HAS_GETHOSTBYNAME
2d8e6c8d 4306 hent = PerlSock_gethostbyname(POPpx);
dc45a647 4307#else
cea2e8a9 4308 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
dc45a647 4309#endif
a0d0e21e 4310 else if (which == OP_GHBYADDR) {
dc45a647 4311#ifdef HAS_GETHOSTBYADDR
a0d0e21e 4312 int addrtype = POPi;
748a9306 4313 SV *addrsv = POPs;
a0d0e21e 4314 STRLEN addrlen;
4599a1de 4315 Netdb_host_t addr = (Netdb_host_t) SvPV(addrsv, addrlen);
a0d0e21e 4316
4599a1de 4317 hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
dc45a647 4318#else
cea2e8a9 4319 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
dc45a647 4320#endif
a0d0e21e
LW		 4321 }
4322 else
4323#ifdef HAS_GETHOSTENT
6ad3d225 4324 hent = PerlSock_gethostent();
a0d0e21e 4325#else
cea2e8a9 4326 DIE(aTHX_ PL_no_sock_func, "gethostent");
a0d0e21e
LW		 4327#endif
4328
4329#ifdef HOST_NOT_FOUND
4330 if (!hent)
f86702cc 4331 STATUS_NATIVE_SET(h_errno);
a0d0e21e
LW		 4332#endif
4333
4334 if (GIMME != G_ARRAY) {
4335 PUSHs(sv = sv_newmortal());
4336 if (hent) {
4337 if (which == OP_GHBYNAME) {
fd0af264 4338 if (hent->h_addr)
4339 sv_setpvn(sv, hent->h_addr, hent->h_length);
a0d0e21e
LW		 4340 }
4341 else
4342 sv_setpv(sv, (char*)hent->h_name);
4343 }
4344 RETURN;
4345 }
4346
4347 if (hent) {
3280af22 4348 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4349 sv_setpv(sv, (char*)hent->h_name);
3280af22 4350 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 4351 for (elem = hent->h_aliases; elem && *elem; elem++) {
4352 sv_catpv(sv, *elem);
4353 if (elem[1])
4354 sv_catpvn(sv, " ", 1);
4355 }
3280af22 4356 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4357 sv_setiv(sv, (IV)hent->h_addrtype);
3280af22 4358 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4359 len = hent->h_length;
1e422769 4360 sv_setiv(sv, (IV)len);
a0d0e21e
LW		 4361#ifdef h_addr
4362 for (elem = hent->h_addr_list; elem && *elem; elem++) {
3280af22 4363 XPUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 4364 sv_setpvn(sv, *elem, len);
4365 }
4366#else
6b88bc9c 4367 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
fd0af264 4368 if (hent->h_addr)
4369 sv_setpvn(sv, hent->h_addr, len);
a0d0e21e
LW		 4370#endif /* h_addr */
4371 }
4372 RETURN;
4373#else
cea2e8a9 4374 DIE(aTHX_ PL_no_sock_func, "gethostent");
a0d0e21e
LW		 4375#endif
4376}
4377
4378PP(pp_gnbyname)
4379{
693762b4 4380#ifdef HAS_GETNETBYNAME
cea2e8a9 4381 return pp_gnetent();
a0d0e21e 4382#else
cea2e8a9 4383 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
a0d0e21e
LW		 4384#endif
4385}
4386
4387PP(pp_gnbyaddr)
4388{
693762b4 4389#ifdef HAS_GETNETBYADDR
cea2e8a9 4390 return pp_gnetent();
a0d0e21e 4391#else
cea2e8a9 4392 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
a0d0e21e
LW		 4393#endif
4394}
4395
4396PP(pp_gnetent)
4397{
4e35701f 4398 djSP;
693762b4 4399#if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
533c011a 4400 I32 which = PL_op->op_type;
a0d0e21e
LW		 4401 register char **elem;
4402 register SV *sv;
dc45a647
MB		 4403#ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4404 struct netent *PerlSock_getnetbyaddr(Netdb_net_t, int);
4405 struct netent *PerlSock_getnetbyname(Netdb_name_t);
4406 struct netent *PerlSock_getnetent(void);
8ac85365 4407#endif
a0d0e21e 4408 struct netent *nent;
2d8e6c8d 4409 STRLEN n_a;
a0d0e21e
LW		 4410
4411 if (which == OP_GNBYNAME)
dc45a647 4412#ifdef HAS_GETNETBYNAME
2d8e6c8d 4413 nent = PerlSock_getnetbyname(POPpx);
dc45a647 4414#else
cea2e8a9 4415 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
dc45a647 4416#endif
a0d0e21e 4417 else if (which == OP_GNBYADDR) {
dc45a647 4418#ifdef HAS_GETNETBYADDR
a0d0e21e 4419 int addrtype = POPi;
4599a1de 4420 Netdb_net_t addr = (Netdb_net_t) U_L(POPn);
76e3520e 4421 nent = PerlSock_getnetbyaddr(addr, addrtype);
dc45a647 4422#else
cea2e8a9 4423 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
dc45a647 4424#endif
a0d0e21e
LW		 4425 }
4426 else
dc45a647 4427#ifdef HAS_GETNETENT
76e3520e 4428 nent = PerlSock_getnetent();
dc45a647 4429#else
cea2e8a9 4430 DIE(aTHX_ PL_no_sock_func, "getnetent");
dc45a647 4431#endif
a0d0e21e
LW		 4432
4433 EXTEND(SP, 4);
4434 if (GIMME != G_ARRAY) {
4435 PUSHs(sv = sv_newmortal());
4436 if (nent) {
4437 if (which == OP_GNBYNAME)
1e422769 4438 sv_setiv(sv, (IV)nent->n_net);
a0d0e21e
LW		 4439 else
4440 sv_setpv(sv, nent->n_name);
4441 }
4442 RETURN;
4443 }
4444
4445 if (nent) {
3280af22 4446 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4447 sv_setpv(sv, nent->n_name);
3280af22 4448 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 4449 for (elem = nent->n_aliases; elem && *elem; elem++) {
a0d0e21e
LW		 4450 sv_catpv(sv, *elem);
4451 if (elem[1])
4452 sv_catpvn(sv, " ", 1);
4453 }
3280af22 4454 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4455 sv_setiv(sv, (IV)nent->n_addrtype);
3280af22 4456 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4457 sv_setiv(sv, (IV)nent->n_net);
a0d0e21e
LW		 4458 }
4459
4460 RETURN;
4461#else
cea2e8a9 4462 DIE(aTHX_ PL_no_sock_func, "getnetent");
a0d0e21e
LW		 4463#endif
4464}
4465
4466PP(pp_gpbyname)
4467{
693762b4 4468#ifdef HAS_GETPROTOBYNAME
cea2e8a9 4469 return pp_gprotoent();
a0d0e21e 4470#else
cea2e8a9 4471 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
a0d0e21e
LW		 4472#endif
4473}
4474
4475PP(pp_gpbynumber)
4476{
693762b4 4477#ifdef HAS_GETPROTOBYNUMBER
cea2e8a9 4478 return pp_gprotoent();
a0d0e21e 4479#else
cea2e8a9 4480 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
a0d0e21e
LW		 4481#endif
4482}
4483
4484PP(pp_gprotoent)
4485{
4e35701f 4486 djSP;
693762b4 4487#if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
533c011a 4488 I32 which = PL_op->op_type;
a0d0e21e 4489 register char **elem;
8ac85365 4490 register SV *sv;
dc45a647 4491#ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4599a1de 4492 struct protoent *PerlSock_getprotobyname(Netdb_name_t);
6ad3d225
GS		 4493 struct protoent *PerlSock_getprotobynumber(int);
4494 struct protoent *PerlSock_getprotoent(void);
8ac85365 4495#endif
a0d0e21e 4496 struct protoent *pent;
2d8e6c8d 4497 STRLEN n_a;
a0d0e21e
LW		 4498
4499 if (which == OP_GPBYNAME)
e5c9fcd0 4500#ifdef HAS_GETPROTOBYNAME
2d8e6c8d 4501 pent = PerlSock_getprotobyname(POPpx);
e5c9fcd0 4502#else
cea2e8a9 4503 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
e5c9fcd0 4504#endif
a0d0e21e 4505 else if (which == OP_GPBYNUMBER)
e5c9fcd0 4506#ifdef HAS_GETPROTOBYNUMBER
6ad3d225 4507 pent = PerlSock_getprotobynumber(POPi);
e5c9fcd0 4508#else
cea2e8a9 4509 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
e5c9fcd0 4510#endif
a0d0e21e 4511 else
e5c9fcd0 4512#ifdef HAS_GETPROTOENT
6ad3d225 4513 pent = PerlSock_getprotoent();
e5c9fcd0 4514#else
cea2e8a9 4515 DIE(aTHX_ PL_no_sock_func, "getprotoent");
e5c9fcd0 4516#endif
a0d0e21e
LW		 4517
4518 EXTEND(SP, 3);
4519 if (GIMME != G_ARRAY) {
4520 PUSHs(sv = sv_newmortal());
4521 if (pent) {
4522 if (which == OP_GPBYNAME)
1e422769 4523 sv_setiv(sv, (IV)pent->p_proto);
a0d0e21e
LW		 4524 else
4525 sv_setpv(sv, pent->p_name);
4526 }
4527 RETURN;
4528 }
4529
4530 if (pent) {
3280af22 4531 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4532 sv_setpv(sv, pent->p_name);
3280af22 4533 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 4534 for (elem = pent->p_aliases; elem && *elem; elem++) {
a0d0e21e
LW		 4535 sv_catpv(sv, *elem);
4536 if (elem[1])
4537 sv_catpvn(sv, " ", 1);
4538 }
3280af22 4539 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4540 sv_setiv(sv, (IV)pent->p_proto);
a0d0e21e
LW		 4541 }
4542
4543 RETURN;
4544#else
cea2e8a9 4545 DIE(aTHX_ PL_no_sock_func, "getprotoent");
a0d0e21e
LW		 4546#endif
4547}
4548
4549PP(pp_gsbyname)
4550{
9ec75305 4551#ifdef HAS_GETSERVBYNAME
cea2e8a9 4552 return pp_gservent();
a0d0e21e 4553#else
cea2e8a9 4554 DIE(aTHX_ PL_no_sock_func, "getservbyname");
a0d0e21e
LW		 4555#endif
4556}
4557
4558PP(pp_gsbyport)
4559{
9ec75305 4560#ifdef HAS_GETSERVBYPORT
cea2e8a9 4561 return pp_gservent();
a0d0e21e 4562#else
cea2e8a9 4563 DIE(aTHX_ PL_no_sock_func, "getservbyport");
a0d0e21e
LW		 4564#endif
4565}
4566
4567PP(pp_gservent)
4568{
4e35701f 4569 djSP;
693762b4 4570#if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
533c011a 4571 I32 which = PL_op->op_type;
a0d0e21e
LW		 4572 register char **elem;
4573 register SV *sv;
dc45a647 4574#ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4599a1de
JH		 4575 struct servent *PerlSock_getservbyname(Netdb_name_t, Netdb_name_t);
4576 struct servent *PerlSock_getservbyport(int, Netdb_name_t);
6ad3d225 4577 struct servent *PerlSock_getservent(void);
8ac85365 4578#endif
a0d0e21e 4579 struct servent *sent;
2d8e6c8d 4580 STRLEN n_a;
a0d0e21e
LW		 4581
4582 if (which == OP_GSBYNAME) {
dc45a647 4583#ifdef HAS_GETSERVBYNAME
2d8e6c8d
GS		 4584 char *proto = POPpx;
4585 char *name = POPpx;
a0d0e21e
LW		 4586
4587 if (proto && !*proto)
4588 proto = Nullch;
4589
6ad3d225 4590 sent = PerlSock_getservbyname(name, proto);
dc45a647 4591#else
cea2e8a9 4592 DIE(aTHX_ PL_no_sock_func, "getservbyname");
dc45a647 4593#endif
a0d0e21e
LW		 4594 }
4595 else if (which == OP_GSBYPORT) {
dc45a647 4596#ifdef HAS_GETSERVBYPORT
2d8e6c8d 4597 char *proto = POPpx;
36477c24 4598 unsigned short port = POPu;
a0d0e21e 4599
36477c24 4600#ifdef HAS_HTONS
6ad3d225 4601 port = PerlSock_htons(port);
36477c24 4602#endif
6ad3d225 4603 sent = PerlSock_getservbyport(port, proto);
dc45a647 4604#else
cea2e8a9 4605 DIE(aTHX_ PL_no_sock_func, "getservbyport");
dc45a647 4606#endif
a0d0e21e
LW		 4607 }
4608 else
e5c9fcd0 4609#ifdef HAS_GETSERVENT
6ad3d225 4610 sent = PerlSock_getservent();
e5c9fcd0 4611#else
cea2e8a9 4612 DIE(aTHX_ PL_no_sock_func, "getservent");
e5c9fcd0 4613#endif
a0d0e21e
LW		 4614
4615 EXTEND(SP, 4);
4616 if (GIMME != G_ARRAY) {
4617 PUSHs(sv = sv_newmortal());
4618 if (sent) {
4619 if (which == OP_GSBYNAME) {
4620#ifdef HAS_NTOHS
6ad3d225 4621 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
a0d0e21e 4622#else
1e422769 4623 sv_setiv(sv, (IV)(sent->s_port));
a0d0e21e
LW		 4624#endif
4625 }
4626 else
4627 sv_setpv(sv, sent->s_name);
4628 }
4629 RETURN;
4630 }
4631
4632 if (sent) {
3280af22 4633 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4634 sv_setpv(sv, sent->s_name);
3280af22 4635 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 4636 for (elem = sent->s_aliases; elem && *elem; elem++) {
a0d0e21e
LW		 4637 sv_catpv(sv, *elem);
4638 if (elem[1])
4639 sv_catpvn(sv, " ", 1);
4640 }
3280af22 4641 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4642#ifdef HAS_NTOHS
76e3520e 4643 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
a0d0e21e 4644#else
1e422769 4645 sv_setiv(sv, (IV)(sent->s_port));
a0d0e21e 4646#endif
3280af22 4647 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 4648 sv_setpv(sv, sent->s_proto);
4649 }
4650
4651 RETURN;
4652#else
cea2e8a9 4653 DIE(aTHX_ PL_no_sock_func, "getservent");
a0d0e21e
LW		 4654#endif
4655}
4656
4657PP(pp_shostent)
4658{
4e35701f 4659 djSP;
693762b4 4660#ifdef HAS_SETHOSTENT
76e3520e 4661 PerlSock_sethostent(TOPi);
a0d0e21e
LW		 4662 RETSETYES;
4663#else
cea2e8a9 4664 DIE(aTHX_ PL_no_sock_func, "sethostent");
a0d0e21e
LW		 4665#endif
4666}
4667
4668PP(pp_snetent)
4669{
4e35701f 4670 djSP;
693762b4 4671#ifdef HAS_SETNETENT
76e3520e 4672 PerlSock_setnetent(TOPi);
a0d0e21e
LW		 4673 RETSETYES;
4674#else
cea2e8a9 4675 DIE(aTHX_ PL_no_sock_func, "setnetent");
a0d0e21e
LW		 4676#endif
4677}
4678
4679PP(pp_sprotoent)
4680{
4e35701f 4681 djSP;
693762b4 4682#ifdef HAS_SETPROTOENT
76e3520e 4683 PerlSock_setprotoent(TOPi);
a0d0e21e
LW		 4684 RETSETYES;
4685#else
cea2e8a9 4686 DIE(aTHX_ PL_no_sock_func, "setprotoent");
a0d0e21e
LW		 4687#endif
4688}
4689
4690PP(pp_sservent)
4691{
4e35701f 4692 djSP;
693762b4 4693#ifdef HAS_SETSERVENT
76e3520e 4694 PerlSock_setservent(TOPi);
a0d0e21e
LW		 4695 RETSETYES;
4696#else
cea2e8a9 4697 DIE(aTHX_ PL_no_sock_func, "setservent");
a0d0e21e
LW		 4698#endif
4699}
4700
4701PP(pp_ehostent)
4702{
4e35701f 4703 djSP;
693762b4 4704#ifdef HAS_ENDHOSTENT
76e3520e 4705 PerlSock_endhostent();
924508f0 4706 EXTEND(SP,1);
a0d0e21e
LW		 4707 RETPUSHYES;
4708#else
cea2e8a9 4709 DIE(aTHX_ PL_no_sock_func, "endhostent");
a0d0e21e
LW		 4710#endif
4711}
4712
4713PP(pp_enetent)
4714{
4e35701f 4715 djSP;
693762b4 4716#ifdef HAS_ENDNETENT
76e3520e 4717 PerlSock_endnetent();
924508f0 4718 EXTEND(SP,1);
a0d0e21e
LW		 4719 RETPUSHYES;
4720#else
cea2e8a9 4721 DIE(aTHX_ PL_no_sock_func, "endnetent");
a0d0e21e
LW		 4722#endif
4723}
4724
4725PP(pp_eprotoent)
4726{
4e35701f 4727 djSP;
693762b4 4728#ifdef HAS_ENDPROTOENT
76e3520e 4729 PerlSock_endprotoent();
924508f0 4730 EXTEND(SP,1);
a0d0e21e
LW		 4731 RETPUSHYES;
4732#else
cea2e8a9 4733 DIE(aTHX_ PL_no_sock_func, "endprotoent");
a0d0e21e
LW		 4734#endif
4735}
4736
4737PP(pp_eservent)
4738{
4e35701f 4739 djSP;
693762b4 4740#ifdef HAS_ENDSERVENT
76e3520e 4741 PerlSock_endservent();
924508f0 4742 EXTEND(SP,1);
a0d0e21e
LW		 4743 RETPUSHYES;
4744#else
cea2e8a9 4745 DIE(aTHX_ PL_no_sock_func, "endservent");
a0d0e21e
LW		 4746#endif
4747}
4748
4749PP(pp_gpwnam)
4750{
4751#ifdef HAS_PASSWD
cea2e8a9 4752 return pp_gpwent();
a0d0e21e 4753#else
cea2e8a9 4754 DIE(aTHX_ PL_no_func, "getpwnam");
a0d0e21e
LW		 4755#endif
4756}
4757
4758PP(pp_gpwuid)
4759{
4760#ifdef HAS_PASSWD
cea2e8a9 4761 return pp_gpwent();
a0d0e21e 4762#else
cea2e8a9 4763 DIE(aTHX_ PL_no_func, "getpwuid");
a0d0e21e
LW		 4764#endif
4765}
4766
4767PP(pp_gpwent)
4768{
4e35701f 4769 djSP;
0994c4d0 4770#ifdef HAS_PASSWD
533c011a 4771 I32 which = PL_op->op_type;
a0d0e21e
LW		 4772 register SV *sv;
4773 struct passwd *pwent;
2d8e6c8d 4774 STRLEN n_a;
6a5e2de5 4775#if defined(HAS_GETSPENT) || defined(HAS_GETSPNAM)
eff96b52 4776 struct spwd *spwent = NULL;
8c0bfa08 4777#endif
a0d0e21e
LW		 4778
4779 if (which == OP_GPWNAM)
2d8e6c8d 4780 pwent = getpwnam(POPpx);
a0d0e21e
LW		 4781 else if (which == OP_GPWUID)
4782 pwent = getpwuid(POPi);
4783 else
0994c4d0 4784#ifdef HAS_GETPWENT
a0d0e21e 4785 pwent = (struct passwd *)getpwent();
0994c4d0
JH		 4786#else
4787 DIE(aTHX_ PL_no_func, "getpwent");
4788#endif
a0d0e21e 4789
f1066039 4790#ifdef HAS_GETSPNAM
eff96b52
GS		 4791 if (which == OP_GPWNAM) {
4792 if (pwent)
4793 spwent = getspnam(pwent->pw_name);
4794 }
f1066039 4795# ifdef HAS_GETSPUID /* AFAIK there isn't any anywhere. --jhi */
eff96b52
GS		 4796 else if (which == OP_GPWUID) {
4797 if (pwent)
4798 spwent = getspnam(pwent->pw_name);
4799 }
f1066039 4800# endif
6a5e2de5 4801# ifdef HAS_GETSPENT
eff96b52
GS		 4802 else
4803 spwent = (struct spwd *)getspent();
6a5e2de5 4804# endif
8c0bfa08
PB		 4805#endif
4806
a0d0e21e
LW		 4807 EXTEND(SP, 10);
4808 if (GIMME != G_ARRAY) {
4809 PUSHs(sv = sv_newmortal());
4810 if (pwent) {
4811 if (which == OP_GPWNAM)
23dcd6c8 4812#if Uid_t_sign <= 0
1e422769 4813 sv_setiv(sv, (IV)pwent->pw_uid);
23dcd6c8
JH		 4814#else
4815 sv_setuv(sv, (UV)pwent->pw_uid);
4816#endif
a0d0e21e
LW		 4817 else
4818 sv_setpv(sv, pwent->pw_name);
4819 }
4820 RETURN;
4821 }
4822
4823 if (pwent) {
3280af22 4824 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4825 sv_setpv(sv, pwent->pw_name);
6ee623d5 4826
3280af22 4827 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
28e8609d 4828#ifdef PWPASSWD
6a5e2de5 4829# if defined(HAS_GETSPENT) || defined(HAS_GETSPNAM)
8c0bfa08
PB		 4830 if (spwent)
4831 sv_setpv(sv, spwent->sp_pwdp);
4832 else
4833 sv_setpv(sv, pwent->pw_passwd);
f1066039 4834# else
a0d0e21e 4835 sv_setpv(sv, pwent->pw_passwd);
f1066039 4836# endif
8c0bfa08 4837#endif
6ee623d5 4838
3280af22 4839 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
23dcd6c8 4840#if Uid_t_sign <= 0
1e422769 4841 sv_setiv(sv, (IV)pwent->pw_uid);
23dcd6c8
JH		 4842#else
4843 sv_setuv(sv, (UV)pwent->pw_uid);
4844#endif
6ee623d5 4845
3280af22 4846 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
23dcd6c8 4847#if Uid_t_sign <= 0
1e422769 4848 sv_setiv(sv, (IV)pwent->pw_gid);
23dcd6c8
JH		 4849#else
4850 sv_setuv(sv, (UV)pwent->pw_gid);
4851#endif
6ee623d5 4852 /* pw_change, pw_quota, and pw_age are mutually exclusive. */
3280af22 4853 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4854#ifdef PWCHANGE
1e422769 4855 sv_setiv(sv, (IV)pwent->pw_change);
a0d0e21e 4856#else
6ee623d5 4857# ifdef PWQUOTA
1e422769 4858 sv_setiv(sv, (IV)pwent->pw_quota);
6ee623d5
GS		 4859# else
4860# ifdef PWAGE
a0d0e21e 4861 sv_setpv(sv, pwent->pw_age);
6ee623d5
GS		 4862# endif
4863# endif
a0d0e21e 4864#endif
6ee623d5
GS		 4865
4866 /* pw_class and pw_comment are mutually exclusive. */
3280af22 4867 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 4868#ifdef PWCLASS
4869 sv_setpv(sv, pwent->pw_class);
4870#else
6ee623d5 4871# ifdef PWCOMMENT
a0d0e21e 4872 sv_setpv(sv, pwent->pw_comment);
6ee623d5 4873# endif
a0d0e21e 4874#endif
6ee623d5 4875
3280af22 4876 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
6ee623d5 4877#ifdef PWGECOS
a0d0e21e 4878 sv_setpv(sv, pwent->pw_gecos);
6ee623d5 4879#endif
fb73857a 4880#ifndef INCOMPLETE_TAINTS
d2719217 4881 /* pw_gecos is tainted because user himself can diddle with it. */
fb73857a 4882 SvTAINTED_on(sv);
4883#endif
6ee623d5 4884
3280af22 4885 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4886 sv_setpv(sv, pwent->pw_dir);
6ee623d5 4887
3280af22 4888 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4889 sv_setpv(sv, pwent->pw_shell);
4602f195
JH		 4890#ifndef INCOMPLETE_TAINTS
4891 /* pw_shell is tainted because user himself can diddle with it. */
4892 SvTAINTED_on(sv);
4893#endif
6ee623d5 4894
a0d0e21e 4895#ifdef PWEXPIRE
6b88bc9c 4896 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4897 sv_setiv(sv, (IV)pwent->pw_expire);
a0d0e21e
LW		 4898#endif
4899 }
4900 RETURN;
4901#else
cea2e8a9 4902 DIE(aTHX_ PL_no_func, "getpwent");
a0d0e21e
LW		 4903#endif
4904}
4905
4906PP(pp_spwent)
4907{
4e35701f 4908 djSP;
d493b042 4909#if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
a0d0e21e 4910 setpwent();
f1066039 4911# ifdef HAS_SETSPENT
8c0bfa08 4912 setspent();
f1066039 4913# endif
a0d0e21e
LW		 4914 RETPUSHYES;
4915#else
cea2e8a9 4916 DIE(aTHX_ PL_no_func, "setpwent");
a0d0e21e
LW		 4917#endif
4918}
4919
4920PP(pp_epwent)
4921{
4e35701f 4922 djSP;
28e8609d 4923#if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
a0d0e21e 4924 endpwent();
f1066039 4925# ifdef HAS_ENDSPENT
8c0bfa08 4926 endspent();
f1066039 4927# endif
a0d0e21e
LW		 4928 RETPUSHYES;
4929#else
cea2e8a9 4930 DIE(aTHX_ PL_no_func, "endpwent");
a0d0e21e
LW		 4931#endif
4932}
4933
4934PP(pp_ggrnam)
4935{
4936#ifdef HAS_GROUP
cea2e8a9 4937 return pp_ggrent();
a0d0e21e 4938#else
cea2e8a9 4939 DIE(aTHX_ PL_no_func, "getgrnam");
a0d0e21e
LW		 4940#endif
4941}
4942
4943PP(pp_ggrgid)
4944{
4945#ifdef HAS_GROUP
cea2e8a9 4946 return pp_ggrent();
a0d0e21e 4947#else
cea2e8a9 4948 DIE(aTHX_ PL_no_func, "getgrgid");
a0d0e21e
LW		 4949#endif
4950}
4951
4952PP(pp_ggrent)
4953{
4e35701f 4954 djSP;
0994c4d0 4955#ifdef HAS_GROUP
533c011a 4956 I32 which = PL_op->op_type;
a0d0e21e
LW		 4957 register char **elem;
4958 register SV *sv;
4959 struct group *grent;
2d8e6c8d 4960 STRLEN n_a;
a0d0e21e
LW		 4961
4962 if (which == OP_GGRNAM)
2d8e6c8d 4963 grent = (struct group *)getgrnam(POPpx);
a0d0e21e
LW		 4964 else if (which == OP_GGRGID)
4965 grent = (struct group *)getgrgid(POPi);
4966 else
0994c4d0 4967#ifdef HAS_GETGRENT
a0d0e21e 4968 grent = (struct group *)getgrent();
0994c4d0
JH		 4969#else
4970 DIE(aTHX_ PL_no_func, "getgrent");
4971#endif
a0d0e21e
LW		 4972
4973 EXTEND(SP, 4);
4974 if (GIMME != G_ARRAY) {
4975 PUSHs(sv = sv_newmortal());
4976 if (grent) {
4977 if (which == OP_GGRNAM)
1e422769 4978 sv_setiv(sv, (IV)grent->gr_gid);
a0d0e21e
LW		 4979 else
4980 sv_setpv(sv, grent->gr_name);
4981 }
4982 RETURN;
4983 }
4984
4985 if (grent) {
3280af22 4986 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4987 sv_setpv(sv, grent->gr_name);
28e8609d 4988
3280af22 4989 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
28e8609d 4990#ifdef GRPASSWD
a0d0e21e 4991 sv_setpv(sv, grent->gr_passwd);
28e8609d
JH		 4992#endif
4993
3280af22 4994 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4995 sv_setiv(sv, (IV)grent->gr_gid);
28e8609d 4996
3280af22 4997 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 4998 for (elem = grent->gr_mem; elem && *elem; elem++) {
a0d0e21e
LW		 4999 sv_catpv(sv, *elem);
5000 if (elem[1])
5001 sv_catpvn(sv, " ", 1);
5002 }
5003 }
5004
5005 RETURN;
5006#else
cea2e8a9 5007 DIE(aTHX_ PL_no_func, "getgrent");
a0d0e21e
LW		 5008#endif
5009}
5010
5011PP(pp_sgrent)
5012{
4e35701f 5013 djSP;
28e8609d 5014#if defined(HAS_GROUP) && defined(HAS_SETGRENT)
a0d0e21e
LW		 5015 setgrent();
5016 RETPUSHYES;
5017#else
cea2e8a9 5018 DIE(aTHX_ PL_no_func, "setgrent");
a0d0e21e
LW		 5019#endif
5020}
5021
5022PP(pp_egrent)
5023{
4e35701f 5024 djSP;
28e8609d 5025#if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
a0d0e21e
LW		 5026 endgrent();
5027 RETPUSHYES;
5028#else
cea2e8a9 5029 DIE(aTHX_ PL_no_func, "endgrent");
a0d0e21e
LW		 5030#endif
5031}
5032
5033PP(pp_getlogin)
5034{
4e35701f 5035 djSP; dTARGET;
a0d0e21e
LW		 5036#ifdef HAS_GETLOGIN
5037 char *tmps;
5038 EXTEND(SP, 1);
76e3520e 5039 if (!(tmps = PerlProc_getlogin()))
a0d0e21e
LW		 5040 RETPUSHUNDEF;
5041 PUSHp(tmps, strlen(tmps));
5042 RETURN;
5043#else
cea2e8a9 5044 DIE(aTHX_ PL_no_func, "getlogin");
a0d0e21e
LW		 5045#endif
5046}
5047
5048/* Miscellaneous. */
5049
5050PP(pp_syscall)
5051{
d2719217 5052#ifdef HAS_SYSCALL
4e35701f 5053 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW		 5054 register I32 items = SP - MARK;
5055 unsigned long a[20];
5056 register I32 i = 0;
5057 I32 retval = -1;
2d8e6c8d 5058 STRLEN n_a;
a0d0e21e 5059
3280af22 5060 if (PL_tainting) {
a0d0e21e 5061 while (++MARK <= SP) {
bbce6d69 5062 if (SvTAINTED(*MARK)) {
5063 TAINT;
5064 break;
5065 }
a0d0e21e
LW		 5066 }
5067 MARK = ORIGMARK;
5068 TAINT_PROPER("syscall");
5069 }
5070
5071 /* This probably won't work on machines where sizeof(long) != sizeof(int)
5072 * or where sizeof(long) != sizeof(char*). But such machines will
5073 * not likely have syscall implemented either, so who cares?
5074 */
5075 while (++MARK <= SP) {
5076 if (SvNIOK(*MARK) || !i)
5077 a[i++] = SvIV(*MARK);
3280af22 5078 else if (*MARK == &PL_sv_undef)
748a9306
LW		 5079 a[i++] = 0;
5080 else
2d8e6c8d 5081 a[i++] = (unsigned long)SvPV_force(*MARK, n_a);
a0d0e21e
LW		 5082 if (i > 15)
5083 break;
5084 }
5085 switch (items) {
5086 default:
cea2e8a9 5087 DIE(aTHX_ "Too many args to syscall");
a0d0e21e 5088 case 0:
cea2e8a9 5089 DIE(aTHX_ "Too few args to syscall");
a0d0e21e
LW		 5090 case 1:
5091 retval = syscall(a[0]);
5092 break;
5093 case 2:
5094 retval = syscall(a[0],a[1]);
5095 break;
5096 case 3:
5097 retval = syscall(a[0],a[1],a[2]);
5098 break;
5099 case 4:
5100 retval = syscall(a[0],a[1],a[2],a[3]);
5101 break;
5102 case 5:
5103 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5104 break;
5105 case 6:
5106 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5107 break;
5108 case 7:
5109 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5110 break;
5111 case 8:
5112 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5113 break;
5114#ifdef atarist
5115 case 9:
5116 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5117 break;
5118 case 10:
5119 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
5120 break;
5121 case 11:
5122 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5123 a[10]);
5124 break;
5125 case 12:
5126 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5127 a[10],a[11]);
5128 break;
5129 case 13:
5130 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5131 a[10],a[11],a[12]);
5132 break;
5133 case 14:
5134 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5135 a[10],a[11],a[12],a[13]);
5136 break;
5137#endif /* atarist */
5138 }
5139 SP = ORIGMARK;
5140 PUSHi(retval);
5141 RETURN;
5142#else
cea2e8a9 5143 DIE(aTHX_ PL_no_func, "syscall");
a0d0e21e
LW		 5144#endif
5145}
5146
ff68c719 5147#ifdef FCNTL_EMULATE_FLOCK
5148
5149/* XXX Emulate flock() with fcntl().
5150 What's really needed is a good file locking module.
5151*/
5152
cea2e8a9
GS		 5153static int
5154fcntl_emulate_flock(int fd, int operation)
ff68c719 5155{
5156 struct flock flock;
5157
5158 switch (operation & ~LOCK_NB) {
5159 case LOCK_SH:
5160 flock.l_type = F_RDLCK;
5161 break;
5162 case LOCK_EX:
5163 flock.l_type = F_WRLCK;
5164 break;
5165 case LOCK_UN:
5166 flock.l_type = F_UNLCK;
5167 break;
5168 default:
5169 errno = EINVAL;
5170 return -1;
5171 }
5172 flock.l_whence = SEEK_SET;
d9b3e12d 5173 flock.l_start = flock.l_len = (Off_t)0;
ff68c719 5174
5175 return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5176}
5177
5178#endif /* FCNTL_EMULATE_FLOCK */
5179
5180#ifdef LOCKF_EMULATE_FLOCK
16d20bd9
AD		 5181
5182/* XXX Emulate flock() with lockf(). This is just to increase
5183 portability of scripts. The calls are not completely
5184 interchangeable. What's really needed is a good file
5185 locking module.
5186*/
5187
76c32331 5188/* The lockf() constants might have been defined in <unistd.h>.
5189 Unfortunately, <unistd.h> causes troubles on some mixed
5190 (BSD/POSIX) systems, such as SunOS 4.1.3.
16d20bd9
AD		 5191
5192 Further, the lockf() constants aren't POSIX, so they might not be
5193 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
5194 just stick in the SVID values and be done with it. Sigh.
5195*/
5196
5197# ifndef F_ULOCK
5198# define F_ULOCK 0 /* Unlock a previously locked region */
5199# endif
5200# ifndef F_LOCK
5201# define F_LOCK 1 /* Lock a region for exclusive use */
5202# endif
5203# ifndef F_TLOCK
5204# define F_TLOCK 2 /* Test and lock a region for exclusive use */
5205# endif
5206# ifndef F_TEST
5207# define F_TEST 3 /* Test a region for other processes locks */
5208# endif
5209
cea2e8a9
GS		 5210static int
5211lockf_emulate_flock(int fd, int operation)
16d20bd9
AD		 5212{
5213 int i;
84902520
TB		 5214 int save_errno;
5215 Off_t pos;
5216
5217 /* flock locks entire file so for lockf we need to do the same */
5218 save_errno = errno;
6ad3d225 5219 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
84902520 5220 if (pos > 0) /* is seekable and needs to be repositioned */
6ad3d225 5221 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
08b714dd 5222 pos = -1; /* seek failed, so don't seek back afterwards */
84902520
TB		 5223 errno = save_errno;
5224
16d20bd9
AD		 5225 switch (operation) {
5226
5227 /* LOCK_SH - get a shared lock */
5228 case LOCK_SH:
5229 /* LOCK_EX - get an exclusive lock */
5230 case LOCK_EX:
5231 i = lockf (fd, F_LOCK, 0);
5232 break;
5233
5234 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5235 case LOCK_SH|LOCK_NB:
5236 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5237 case LOCK_EX|LOCK_NB:
5238 i = lockf (fd, F_TLOCK, 0);
5239 if (i == -1)
5240 if ((errno == EAGAIN) || (errno == EACCES))
5241 errno = EWOULDBLOCK;
5242 break;
5243
ff68c719 5244 /* LOCK_UN - unlock (non-blocking is a no-op) */
16d20bd9 5245 case LOCK_UN:
ff68c719 5246 case LOCK_UN|LOCK_NB:
16d20bd9
AD		 5247 i = lockf (fd, F_ULOCK, 0);
5248 break;
5249
5250 /* Default - can't decipher operation */
5251 default:
5252 i = -1;
5253 errno = EINVAL;
5254 break;
5255 }
84902520
TB		 5256
5257 if (pos > 0) /* need to restore position of the handle */
6ad3d225 5258 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
84902520 5259
16d20bd9
AD		 5260 return (i);
5261}
ff68c719 5262
5263#endif /* LOCKF_EMULATE_FLOCK */
Unnamed repository; edit this file 'description' to name the repository.