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