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