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