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