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