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