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