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
various fixes for race conditions under threads: mutex locks based
[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) {
a7092146
GS		 1425#ifdef PERL_SOCK_SYSREAD_IS_RECV
1426 if (IoTYPE(io) == 's') {
1427 length = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
1428 buffer+offset, length, 0);
1429 }
1430 else
1431#endif
1432 {
1433 length = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
1434 buffer+offset, length);
1435 }
a0d0e21e
LW		 1436 }
1437 else
1438#ifdef HAS_SOCKET__bad_code_maybe
1439 if (IoTYPE(io) == 's') {
46fc3d4c 1440 char namebuf[MAXPATHLEN];
490ab354
JH		 1441#if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
1442 bufsize = sizeof (struct sockaddr_in);
1443#else
46fc3d4c 1444 bufsize = sizeof namebuf;
490ab354 1445#endif
6ad3d225 1446 length = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer+offset, length, 0,
46fc3d4c 1447 (struct sockaddr *)namebuf, &bufsize);
a0d0e21e
LW		 1448 }
1449 else
1450#endif
3b02c43c 1451 {
760ac839 1452 length = PerlIO_read(IoIFP(io), buffer+offset, length);
3b02c43c 1453 /* fread() returns 0 on both error and EOF */
5c7a8c78 1454 if (length == 0 && PerlIO_error(IoIFP(io)))
3b02c43c
GS		 1455 length = -1;
1456 }
a0d0e21e
LW		 1457 if (length < 0)
1458 goto say_undef;
748a9306
LW		 1459 SvCUR_set(bufsv, length+offset);
1460 *SvEND(bufsv) = '\0';
1461 (void)SvPOK_only(bufsv);
1462 SvSETMAGIC(bufsv);
aac0dd9a 1463 /* This should not be marked tainted if the fp is marked clean */
bbce6d69 1464 if (!(IoFLAGS(io) & IOf_UNTAINT))
1465 SvTAINTED_on(bufsv);
a0d0e21e
LW		 1466 SP = ORIGMARK;
1467 PUSHi(length);
1468 RETURN;
1469
1470 say_undef:
1471 SP = ORIGMARK;
1472 RETPUSHUNDEF;
1473}
1474
1475PP(pp_syswrite)
1476{
092bebab
JH		 1477 djSP;
1478 int items = (SP - PL_stack_base) - TOPMARK;
1479 if (items == 2) {
9f089d78 1480 SV *sv;
092bebab 1481 EXTEND(SP, 1);
9f089d78
SB		 1482 sv = sv_2mortal(newSViv(sv_len(*SP)));
1483 PUSHs(sv);
092bebab
JH		 1484 PUTBACK;
1485 }
a0d0e21e
LW		 1486 return pp_send(ARGS);
1487}
1488
1489PP(pp_send)
1490{
4e35701f 1491 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW		 1492 GV *gv;
1493 IO *io;
1494 int offset;
748a9306 1495 SV *bufsv;
a0d0e21e
LW		 1496 char *buffer;
1497 int length;
1498 STRLEN blen;
1d603a67 1499 MAGIC *mg;
a0d0e21e
LW		 1500
1501 gv = (GV*)*++MARK;
33c27489 1502 if (PL_op->op_type == OP_SYSWRITE && (mg = SvTIED_mg((SV*)gv, 'q'))) {
1d603a67
GB		 1503 SV *sv;
1504
1505 PUSHMARK(MARK-1);
33c27489 1506 *MARK = SvTIED_obj((SV*)gv, mg);
1d603a67
GB		 1507 ENTER;
1508 perl_call_method("WRITE", G_SCALAR);
1509 LEAVE;
1510 SPAGAIN;
1511 sv = POPs;
1512 SP = ORIGMARK;
1513 PUSHs(sv);
1514 RETURN;
1515 }
a0d0e21e
LW		 1516 if (!gv)
1517 goto say_undef;
748a9306
LW		 1518 bufsv = *++MARK;
1519 buffer = SvPV(bufsv, blen);
a0d0e21e
LW		 1520 length = SvIVx(*++MARK);
1521 if (length < 0)
1522 DIE("Negative length");
748a9306 1523 SETERRNO(0,0);
a0d0e21e
LW		 1524 io = GvIO(gv);
1525 if (!io || !IoIFP(io)) {
1526 length = -1;
599cee73 1527 if (ckWARN(WARN_CLOSED)) {
533c011a 1528 if (PL_op->op_type == OP_SYSWRITE)
599cee73 1529 warner(WARN_CLOSED, "Syswrite on closed filehandle");
a0d0e21e 1530 else
599cee73 1531 warner(WARN_CLOSED, "Send on closed socket");
a0d0e21e
LW		 1532 }
1533 }
533c011a 1534 else if (PL_op->op_type == OP_SYSWRITE) {
bbce6d69 1535 if (MARK < SP) {
a0d0e21e 1536 offset = SvIVx(*++MARK);
bbce6d69 1537 if (offset < 0) {
1538 if (-offset > blen)
1539 DIE("Offset outside string");
1540 offset += blen;
fb73857a 1541 } else if (offset >= blen && blen > 0)
bbce6d69 1542 DIE("Offset outside string");
1543 } else
a0d0e21e
LW		 1544 offset = 0;
1545 if (length > blen - offset)
1546 length = blen - offset;
a7092146
GS		 1547#ifdef PERL_SOCK_SYSWRITE_IS_SEND
1548 if (IoTYPE(io) == 's') {
1549 length = PerlSock_send(PerlIO_fileno(IoIFP(io)),
1550 buffer+offset, length, 0);
1551 }
1552 else
1553#endif
1554 {
1555 length = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
1556 buffer+offset, length);
1557 }
a0d0e21e
LW		 1558 }
1559#ifdef HAS_SOCKET
1560 else if (SP > MARK) {
1561 char *sockbuf;
1562 STRLEN mlen;
1563 sockbuf = SvPVx(*++MARK, mlen);
6ad3d225 1564 length = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen, length,
a0d0e21e
LW		 1565 (struct sockaddr *)sockbuf, mlen);
1566 }
1567 else
6ad3d225 1568 length = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, length);
490ab354 1569
a0d0e21e
LW		 1570#else
1571 else
22c35a8c 1572 DIE(PL_no_sock_func, "send");
a0d0e21e
LW		 1573#endif
1574 if (length < 0)
1575 goto say_undef;
1576 SP = ORIGMARK;
1577 PUSHi(length);
1578 RETURN;
1579
1580 say_undef:
1581 SP = ORIGMARK;
1582 RETPUSHUNDEF;
1583}
1584
1585PP(pp_recv)
1586{
1587 return pp_sysread(ARGS);
1588}
1589
1590PP(pp_eof)
1591{
4e35701f 1592 djSP;
a0d0e21e
LW		 1593 GV *gv;
1594
1595 if (MAXARG <= 0)
3280af22 1596 gv = PL_last_in_gv;
a0d0e21e 1597 else
3280af22 1598 gv = PL_last_in_gv = (GV*)POPs;
54310121 1599 PUSHs(boolSV(!gv || do_eof(gv)));
a0d0e21e
LW		 1600 RETURN;
1601}
1602
1603PP(pp_tell)
1604{
4e35701f 1605 djSP; dTARGET;
a0d0e21e
LW		 1606 GV *gv;
1607
1608 if (MAXARG <= 0)
3280af22 1609 gv = PL_last_in_gv;
a0d0e21e 1610 else
3280af22 1611 gv = PL_last_in_gv = (GV*)POPs;
a0d0e21e
LW		 1612 PUSHi( do_tell(gv) );
1613 RETURN;
1614}
1615
1616PP(pp_seek)
1617{
137443ea 1618 return pp_sysseek(ARGS);
1619}
1620
1621PP(pp_sysseek)
1622{
4e35701f 1623 djSP;
a0d0e21e
LW		 1624 GV *gv;
1625 int whence = POPi;
97cc44eb 1626 Off_t offset = POPl;
a0d0e21e 1627
3280af22 1628 gv = PL_last_in_gv = (GV*)POPs;
533c011a 1629 if (PL_op->op_type == OP_SEEK)
8903cb82 1630 PUSHs(boolSV(do_seek(gv, offset, whence)));
1631 else {
97cc44eb 1632 Off_t n = do_sysseek(gv, offset, whence);
3280af22 1633 PUSHs((n < 0) ? &PL_sv_undef
8903cb82 1634 : sv_2mortal(n ? newSViv((IV)n)
1635 : newSVpv(zero_but_true, ZBTLEN)));
1636 }
a0d0e21e
LW		 1637 RETURN;
1638}
1639
1640PP(pp_truncate)
1641{
4e35701f 1642 djSP;
a0d0e21e
LW		 1643 Off_t len = (Off_t)POPn;
1644 int result = 1;
1645 GV *tmpgv;
1646
748a9306 1647 SETERRNO(0,0);
5d94fbed 1648#if defined(HAS_TRUNCATE) || defined(HAS_CHSIZE) || defined(F_FREESP)
533c011a 1649 if (PL_op->op_flags & OPf_SPECIAL) {
1e422769 1650 tmpgv = gv_fetchpv(POPp, FALSE, SVt_PVIO);
cbdc8872 1651 do_ftruncate:
1e422769 1652 TAINT_PROPER("truncate");
a0d0e21e 1653 if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv)) ||
cbdc8872 1654#ifdef HAS_TRUNCATE
760ac839 1655 ftruncate(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
cbdc8872 1656#else
760ac839 1657 my_chsize(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
cbdc8872 1658#endif
a0d0e21e
LW		 1659 result = 0;
1660 }
1661 else {
cbdc8872 1662 SV *sv = POPs;
1e422769 1663 char *name;
1664
cbdc8872 1665 if (SvTYPE(sv) == SVt_PVGV) {
1666 tmpgv = (GV*)sv; /* *main::FRED for example */
1667 goto do_ftruncate;
1668 }
1669 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
1670 tmpgv = (GV*) SvRV(sv); /* \*main::FRED for example */
1671 goto do_ftruncate;
1672 }
1e422769 1673
3280af22 1674 name = SvPV(sv, PL_na);
1e422769 1675 TAINT_PROPER("truncate");
cbdc8872 1676#ifdef HAS_TRUNCATE
1e422769 1677 if (truncate(name, len) < 0)
a0d0e21e 1678 result = 0;
cbdc8872 1679#else
1680 {
1681 int tmpfd;
6ad3d225 1682 if ((tmpfd = PerlLIO_open(name, O_RDWR)) < 0)
bbce6d69 1683 result = 0;
cbdc8872 1684 else {
1685 if (my_chsize(tmpfd, len) < 0)
1686 result = 0;
6ad3d225 1687 PerlLIO_close(tmpfd);
cbdc8872 1688 }
a0d0e21e 1689 }
a0d0e21e 1690#endif
cbdc8872 1691 }
a0d0e21e
LW		 1692
1693 if (result)
1694 RETPUSHYES;
1695 if (!errno)
748a9306 1696 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW		 1697 RETPUSHUNDEF;
1698#else
1699 DIE("truncate not implemented");
1700#endif
1701}
1702
1703PP(pp_fcntl)
1704{
1705 return pp_ioctl(ARGS);
1706}
1707
1708PP(pp_ioctl)
1709{
4e35701f 1710 djSP; dTARGET;
748a9306 1711 SV *argsv = POPs;
a0d0e21e 1712 unsigned int func = U_I(POPn);
533c011a 1713 int optype = PL_op->op_type;
a0d0e21e 1714 char *s;
324aa91a 1715 IV retval;
a0d0e21e
LW		 1716 GV *gv = (GV*)POPs;
1717 IO *io = GvIOn(gv);
1718
748a9306
LW		 1719 if (!io || !argsv || !IoIFP(io)) {
1720 SETERRNO(EBADF,RMS$_IFI); /* well, sort of... */
a0d0e21e
LW		 1721 RETPUSHUNDEF;
1722 }
1723
748a9306 1724 if (SvPOK(argsv) || !SvNIOK(argsv)) {
a0d0e21e 1725 STRLEN len;
324aa91a 1726 STRLEN need;
748a9306 1727 s = SvPV_force(argsv, len);
324aa91a
HF		 1728 need = IOCPARM_LEN(func);
1729 if (len < need) {
1730 s = Sv_Grow(argsv, need + 1);
1731 SvCUR_set(argsv, need);
a0d0e21e
LW		 1732 }
1733
748a9306 1734 s[SvCUR(argsv)] = 17; /* a little sanity check here */
a0d0e21e
LW		 1735 }
1736 else {
748a9306 1737 retval = SvIV(argsv);
a0d0e21e 1738 s = (char*)retval; /* ouch */
a0d0e21e
LW		 1739 }
1740
1741 TAINT_PROPER(optype == OP_IOCTL ? "ioctl" : "fcntl");
1742
1743 if (optype == OP_IOCTL)
1744#ifdef HAS_IOCTL
76e3520e 1745 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
a0d0e21e
LW		 1746#else
1747 DIE("ioctl is not implemented");
1748#endif
1749 else
55497cff 1750#ifdef HAS_FCNTL
1751#if defined(OS2) && defined(__EMX__)
760ac839 1752 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
55497cff 1753#else
760ac839 1754 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
55497cff 1755#endif
1756#else
a0d0e21e 1757 DIE("fcntl is not implemented");
a0d0e21e
LW		 1758#endif
1759
748a9306
LW		 1760 if (SvPOK(argsv)) {
1761 if (s[SvCUR(argsv)] != 17)
a0d0e21e 1762 DIE("Possible memory corruption: %s overflowed 3rd argument",
22c35a8c 1763 PL_op_name[optype]);
748a9306
LW		 1764 s[SvCUR(argsv)] = 0; /* put our null back */
1765 SvSETMAGIC(argsv); /* Assume it has changed */
a0d0e21e
LW		 1766 }
1767
1768 if (retval == -1)
1769 RETPUSHUNDEF;
1770 if (retval != 0) {
1771 PUSHi(retval);
1772 }
1773 else {
8903cb82 1774 PUSHp(zero_but_true, ZBTLEN);
a0d0e21e
LW		 1775 }
1776 RETURN;
1777}
1778
1779PP(pp_flock)
1780{
4e35701f 1781 djSP; dTARGET;
a0d0e21e
LW		 1782 I32 value;
1783 int argtype;
1784 GV *gv;
760ac839 1785 PerlIO *fp;
16d20bd9 1786
ff68c719 1787#ifdef FLOCK
a0d0e21e
LW		 1788 argtype = POPi;
1789 if (MAXARG <= 0)
3280af22 1790 gv = PL_last_in_gv;
a0d0e21e
LW		 1791 else
1792 gv = (GV*)POPs;
1793 if (gv && GvIO(gv))
1794 fp = IoIFP(GvIOp(gv));
1795 else
1796 fp = Nullfp;
1797 if (fp) {
68dc0745 1798 (void)PerlIO_flush(fp);
76e3520e 1799 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
a0d0e21e
LW		 1800 }
1801 else
1802 value = 0;
1803 PUSHi(value);
1804 RETURN;
1805#else
22c35a8c 1806 DIE(PL_no_func, "flock()");
a0d0e21e
LW		 1807#endif
1808}
1809
1810/* Sockets. */
1811
1812PP(pp_socket)
1813{
4e35701f 1814 djSP;
a0d0e21e
LW		 1815#ifdef HAS_SOCKET
1816 GV *gv;
1817 register IO *io;
1818 int protocol = POPi;
1819 int type = POPi;
1820 int domain = POPi;
1821 int fd;
1822
1823 gv = (GV*)POPs;
1824
1825 if (!gv) {
748a9306 1826 SETERRNO(EBADF,LIB$_INVARG);
a0d0e21e
LW		 1827 RETPUSHUNDEF;
1828 }
1829
1830 io = GvIOn(gv);
1831 if (IoIFP(io))
1832 do_close(gv, FALSE);
1833
1834 TAINT_PROPER("socket");
6ad3d225 1835 fd = PerlSock_socket(domain, type, protocol);
a0d0e21e
LW		 1836 if (fd < 0)
1837 RETPUSHUNDEF;
760ac839
LW		 1838 IoIFP(io) = PerlIO_fdopen(fd, "r"); /* stdio gets confused about sockets */
1839 IoOFP(io) = PerlIO_fdopen(fd, "w");
a0d0e21e
LW		 1840 IoTYPE(io) = 's';
1841 if (!IoIFP(io) || !IoOFP(io)) {
760ac839
LW		 1842 if (IoIFP(io)) PerlIO_close(IoIFP(io));
1843 if (IoOFP(io)) PerlIO_close(IoOFP(io));
6ad3d225 1844 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
a0d0e21e
LW		 1845 RETPUSHUNDEF;
1846 }
1847
1848 RETPUSHYES;
1849#else
22c35a8c 1850 DIE(PL_no_sock_func, "socket");
a0d0e21e
LW		 1851#endif
1852}
1853
1854PP(pp_sockpair)
1855{
4e35701f 1856 djSP;
a0d0e21e
LW		 1857#ifdef HAS_SOCKETPAIR
1858 GV *gv1;
1859 GV *gv2;
1860 register IO *io1;
1861 register IO *io2;
1862 int protocol = POPi;
1863 int type = POPi;
1864 int domain = POPi;
1865 int fd[2];
1866
1867 gv2 = (GV*)POPs;
1868 gv1 = (GV*)POPs;
1869 if (!gv1 || !gv2)
1870 RETPUSHUNDEF;
1871
1872 io1 = GvIOn(gv1);
1873 io2 = GvIOn(gv2);
1874 if (IoIFP(io1))
1875 do_close(gv1, FALSE);
1876 if (IoIFP(io2))
1877 do_close(gv2, FALSE);
1878
1879 TAINT_PROPER("socketpair");
6ad3d225 1880 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
a0d0e21e 1881 RETPUSHUNDEF;
760ac839
LW		 1882 IoIFP(io1) = PerlIO_fdopen(fd[0], "r");
1883 IoOFP(io1) = PerlIO_fdopen(fd[0], "w");
a0d0e21e 1884 IoTYPE(io1) = 's';
760ac839
LW		 1885 IoIFP(io2) = PerlIO_fdopen(fd[1], "r");
1886 IoOFP(io2) = PerlIO_fdopen(fd[1], "w");
a0d0e21e
LW		 1887 IoTYPE(io2) = 's';
1888 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
760ac839
LW		 1889 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
1890 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
6ad3d225 1891 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
760ac839
LW		 1892 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
1893 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
6ad3d225 1894 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
a0d0e21e
LW		 1895 RETPUSHUNDEF;
1896 }
1897
1898 RETPUSHYES;
1899#else
22c35a8c 1900 DIE(PL_no_sock_func, "socketpair");
a0d0e21e
LW		 1901#endif
1902}
1903
1904PP(pp_bind)
1905{
4e35701f 1906 djSP;
a0d0e21e 1907#ifdef HAS_SOCKET
eec2d3df
GS		 1908#ifdef MPE /* Requires PRIV mode to bind() to ports < 1024 */
1909 extern GETPRIVMODE();
1910 extern GETUSERMODE();
1911#endif
748a9306 1912 SV *addrsv = POPs;
a0d0e21e
LW		 1913 char *addr;
1914 GV *gv = (GV*)POPs;
1915 register IO *io = GvIOn(gv);
1916 STRLEN len;
eec2d3df
GS		 1917 int bind_ok = 0;
1918#ifdef MPE
1919 int mpeprivmode = 0;
1920#endif
a0d0e21e
LW		 1921
1922 if (!io || !IoIFP(io))
1923 goto nuts;
1924
748a9306 1925 addr = SvPV(addrsv, len);
a0d0e21e 1926 TAINT_PROPER("bind");
eec2d3df
GS		 1927#ifdef MPE /* Deal with MPE bind() peculiarities */
1928 if (((struct sockaddr *)addr)->sa_family == AF_INET) {
1929 /* The address *MUST* stupidly be zero. */
1930 ((struct sockaddr_in *)addr)->sin_addr.s_addr = INADDR_ANY;
1931 /* PRIV mode is required to bind() to ports < 1024. */
1932 if (((struct sockaddr_in *)addr)->sin_port < 1024 &&
1933 ((struct sockaddr_in *)addr)->sin_port > 0) {
1934 GETPRIVMODE(); /* If this fails, we are aborted by MPE/iX. */
1935 mpeprivmode = 1;
1936 }
1937 }
1938#endif /* MPE */
1939 if (PerlSock_bind(PerlIO_fileno(IoIFP(io)),
1940 (struct sockaddr *)addr, len) >= 0)
1941 bind_ok = 1;
1942
1943#ifdef MPE /* Switch back to USER mode */
1944 if (mpeprivmode)
1945 GETUSERMODE();
1946#endif /* MPE */
1947
1948 if (bind_ok)
a0d0e21e
LW		 1949 RETPUSHYES;
1950 else
1951 RETPUSHUNDEF;
1952
1953nuts:
599cee73
PM		 1954 if (ckWARN(WARN_CLOSED))
1955 warner(WARN_CLOSED, "bind() on closed fd");
748a9306 1956 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 1957 RETPUSHUNDEF;
1958#else
22c35a8c 1959 DIE(PL_no_sock_func, "bind");
a0d0e21e
LW		 1960#endif
1961}
1962
1963PP(pp_connect)
1964{
4e35701f 1965 djSP;
a0d0e21e 1966#ifdef HAS_SOCKET
748a9306 1967 SV *addrsv = POPs;
a0d0e21e
LW		 1968 char *addr;
1969 GV *gv = (GV*)POPs;
1970 register IO *io = GvIOn(gv);
1971 STRLEN len;
1972
1973 if (!io || !IoIFP(io))
1974 goto nuts;
1975
748a9306 1976 addr = SvPV(addrsv, len);
a0d0e21e 1977 TAINT_PROPER("connect");
6ad3d225 1978 if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
a0d0e21e
LW		 1979 RETPUSHYES;
1980 else
1981 RETPUSHUNDEF;
1982
1983nuts:
599cee73
PM		 1984 if (ckWARN(WARN_CLOSED))
1985 warner(WARN_CLOSED, "connect() on closed fd");
748a9306 1986 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 1987 RETPUSHUNDEF;
1988#else
22c35a8c 1989 DIE(PL_no_sock_func, "connect");
a0d0e21e
LW		 1990#endif
1991}
1992
1993PP(pp_listen)
1994{
4e35701f 1995 djSP;
a0d0e21e
LW		 1996#ifdef HAS_SOCKET
1997 int backlog = POPi;
1998 GV *gv = (GV*)POPs;
1999 register IO *io = GvIOn(gv);
2000
2001 if (!io || !IoIFP(io))
2002 goto nuts;
2003
6ad3d225 2004 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
a0d0e21e
LW		 2005 RETPUSHYES;
2006 else
2007 RETPUSHUNDEF;
2008
2009nuts:
599cee73
PM		 2010 if (ckWARN(WARN_CLOSED))
2011 warner(WARN_CLOSED, "listen() on closed fd");
748a9306 2012 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2013 RETPUSHUNDEF;
2014#else
22c35a8c 2015 DIE(PL_no_sock_func, "listen");
a0d0e21e
LW		 2016#endif
2017}
2018
2019PP(pp_accept)
2020{
4e35701f 2021 djSP; dTARGET;
a0d0e21e
LW		 2022#ifdef HAS_SOCKET
2023 GV *ngv;
2024 GV *ggv;
2025 register IO *nstio;
2026 register IO *gstio;
4633a7c4 2027 struct sockaddr saddr; /* use a struct to avoid alignment problems */
1e422769 2028 Sock_size_t len = sizeof saddr;
a0d0e21e
LW		 2029 int fd;
2030
2031 ggv = (GV*)POPs;
2032 ngv = (GV*)POPs;
2033
2034 if (!ngv)
2035 goto badexit;
2036 if (!ggv)
2037 goto nuts;
2038
2039 gstio = GvIO(ggv);
2040 if (!gstio || !IoIFP(gstio))
2041 goto nuts;
2042
2043 nstio = GvIOn(ngv);
2044 if (IoIFP(nstio))
2045 do_close(ngv, FALSE);
2046
6ad3d225 2047 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *)&saddr, &len);
a0d0e21e
LW		 2048 if (fd < 0)
2049 goto badexit;
760ac839
LW		 2050 IoIFP(nstio) = PerlIO_fdopen(fd, "r");
2051 IoOFP(nstio) = PerlIO_fdopen(fd, "w");
a0d0e21e
LW		 2052 IoTYPE(nstio) = 's';
2053 if (!IoIFP(nstio) || !IoOFP(nstio)) {
760ac839
LW		 2054 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2055 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
6ad3d225 2056 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
a0d0e21e
LW		 2057 goto badexit;
2058 }
2059
748a9306 2060 PUSHp((char *)&saddr, len);
a0d0e21e
LW		 2061 RETURN;
2062
2063nuts:
599cee73
PM		 2064 if (ckWARN(WARN_CLOSED))
2065 warner(WARN_CLOSED, "accept() on closed fd");
748a9306 2066 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2067
2068badexit:
2069 RETPUSHUNDEF;
2070
2071#else
22c35a8c 2072 DIE(PL_no_sock_func, "accept");
a0d0e21e
LW		 2073#endif
2074}
2075
2076PP(pp_shutdown)
2077{
4e35701f 2078 djSP; dTARGET;
a0d0e21e
LW		 2079#ifdef HAS_SOCKET
2080 int how = POPi;
2081 GV *gv = (GV*)POPs;
2082 register IO *io = GvIOn(gv);
2083
2084 if (!io || !IoIFP(io))
2085 goto nuts;
2086
6ad3d225 2087 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
a0d0e21e
LW		 2088 RETURN;
2089
2090nuts:
599cee73
PM		 2091 if (ckWARN(WARN_CLOSED))
2092 warner(WARN_CLOSED, "shutdown() on closed fd");
748a9306 2093 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2094 RETPUSHUNDEF;
2095#else
22c35a8c 2096 DIE(PL_no_sock_func, "shutdown");
a0d0e21e
LW		 2097#endif
2098}
2099
2100PP(pp_gsockopt)
2101{
2102#ifdef HAS_SOCKET
2103 return pp_ssockopt(ARGS);
2104#else
22c35a8c 2105 DIE(PL_no_sock_func, "getsockopt");
a0d0e21e
LW		 2106#endif
2107}
2108
2109PP(pp_ssockopt)
2110{
4e35701f 2111 djSP;
a0d0e21e 2112#ifdef HAS_SOCKET
533c011a 2113 int optype = PL_op->op_type;
a0d0e21e
LW		 2114 SV *sv;
2115 int fd;
2116 unsigned int optname;
2117 unsigned int lvl;
2118 GV *gv;
2119 register IO *io;
1e422769 2120 Sock_size_t len;
a0d0e21e
LW		 2121
2122 if (optype == OP_GSOCKOPT)
2123 sv = sv_2mortal(NEWSV(22, 257));
2124 else
2125 sv = POPs;
2126 optname = (unsigned int) POPi;
2127 lvl = (unsigned int) POPi;
2128
2129 gv = (GV*)POPs;
2130 io = GvIOn(gv);
2131 if (!io || !IoIFP(io))
2132 goto nuts;
2133
760ac839 2134 fd = PerlIO_fileno(IoIFP(io));
a0d0e21e
LW		 2135 switch (optype) {
2136 case OP_GSOCKOPT:
748a9306 2137 SvGROW(sv, 257);
a0d0e21e 2138 (void)SvPOK_only(sv);
748a9306
LW		 2139 SvCUR_set(sv,256);
2140 *SvEND(sv) ='\0';
1e422769 2141 len = SvCUR(sv);
6ad3d225 2142 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
a0d0e21e 2143 goto nuts2;
1e422769 2144 SvCUR_set(sv, len);
748a9306 2145 *SvEND(sv) ='\0';
a0d0e21e
LW		 2146 PUSHs(sv);
2147 break;
2148 case OP_SSOCKOPT: {
1e422769 2149 char *buf;
2150 int aint;
2151 if (SvPOKp(sv)) {
3280af22
NIS		 2152 buf = SvPV(sv, PL_na);
2153 len = PL_na;
1e422769 2154 }
56ee1660 2155 else {
a0d0e21e
LW		 2156 aint = (int)SvIV(sv);
2157 buf = (char*)&aint;
2158 len = sizeof(int);
2159 }
6ad3d225 2160 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
a0d0e21e 2161 goto nuts2;
3280af22 2162 PUSHs(&PL_sv_yes);
a0d0e21e
LW		 2163 }
2164 break;
2165 }
2166 RETURN;
2167
2168nuts:
599cee73
PM		 2169 if (ckWARN(WARN_CLOSED))
2170 warner(WARN_CLOSED, "[gs]etsockopt() on closed fd");
748a9306 2171 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2172nuts2:
2173 RETPUSHUNDEF;
2174
2175#else
22c35a8c 2176 DIE(PL_no_sock_func, "setsockopt");
a0d0e21e
LW		 2177#endif
2178}
2179
2180PP(pp_getsockname)
2181{
2182#ifdef HAS_SOCKET
2183 return pp_getpeername(ARGS);
2184#else
22c35a8c 2185 DIE(PL_no_sock_func, "getsockname");
a0d0e21e
LW		 2186#endif
2187}
2188
2189PP(pp_getpeername)
2190{
4e35701f 2191 djSP;
a0d0e21e 2192#ifdef HAS_SOCKET
533c011a 2193 int optype = PL_op->op_type;
a0d0e21e
LW		 2194 SV *sv;
2195 int fd;
2196 GV *gv = (GV*)POPs;
2197 register IO *io = GvIOn(gv);
1e422769 2198 Sock_size_t len;
a0d0e21e
LW		 2199
2200 if (!io || !IoIFP(io))
2201 goto nuts;
2202
2203 sv = sv_2mortal(NEWSV(22, 257));
748a9306 2204 (void)SvPOK_only(sv);
1e422769 2205 len = 256;
2206 SvCUR_set(sv, len);
748a9306 2207 *SvEND(sv) ='\0';
760ac839 2208 fd = PerlIO_fileno(IoIFP(io));
a0d0e21e
LW		 2209 switch (optype) {
2210 case OP_GETSOCKNAME:
6ad3d225 2211 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
a0d0e21e
LW		 2212 goto nuts2;
2213 break;
2214 case OP_GETPEERNAME:
6ad3d225 2215 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
a0d0e21e 2216 goto nuts2;
490ab354
JH		 2217#if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2218 {
2219 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";
2220 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2221 if (((struct sockaddr *)SvPVX(sv))->sa_family == AF_INET &&
2222 !memcmp((char *)SvPVX(sv) + sizeof(u_short), nowhere,
2223 sizeof(u_short) + sizeof(struct in_addr))) {
2224 goto nuts2;
2225 }
2226 }
2227#endif
a0d0e21e
LW		 2228 break;
2229 }
13826f2c
CS		 2230#ifdef BOGUS_GETNAME_RETURN
2231 /* Interactive Unix, getpeername() and getsockname()
2232 does not return valid namelen */
1e422769 2233 if (len == BOGUS_GETNAME_RETURN)
2234 len = sizeof(struct sockaddr);
13826f2c 2235#endif
1e422769 2236 SvCUR_set(sv, len);
748a9306 2237 *SvEND(sv) ='\0';
a0d0e21e
LW		 2238 PUSHs(sv);
2239 RETURN;
2240
2241nuts:
599cee73
PM		 2242 if (ckWARN(WARN_CLOSED))
2243 warner(WARN_CLOSED, "get{sock, peer}name() on closed fd");
748a9306 2244 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2245nuts2:
2246 RETPUSHUNDEF;
2247
2248#else
22c35a8c 2249 DIE(PL_no_sock_func, "getpeername");
a0d0e21e
LW		 2250#endif
2251}
2252
2253/* Stat calls. */
2254
2255PP(pp_lstat)
2256{
2257 return pp_stat(ARGS);
2258}
2259
2260PP(pp_stat)
2261{
4e35701f 2262 djSP;
a0d0e21e 2263 GV *tmpgv;
54310121 2264 I32 gimme;
a0d0e21e
LW		 2265 I32 max = 13;
2266
533c011a 2267 if (PL_op->op_flags & OPf_REF) {
a0d0e21e 2268 tmpgv = cGVOP->op_gv;
748a9306 2269 do_fstat:
3280af22
NIS		 2270 if (tmpgv != PL_defgv) {
2271 PL_laststype = OP_STAT;
2272 PL_statgv = tmpgv;
2273 sv_setpv(PL_statname, "");
2274 PL_laststatval = (GvIO(tmpgv) && IoIFP(GvIOp(tmpgv))
2275 ? PerlLIO_fstat(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), &PL_statcache) : -1);
a0d0e21e 2276 }
3280af22 2277 if (PL_laststatval < 0)
a0d0e21e
LW		 2278 max = 0;
2279 }
2280 else {
748a9306
LW		 2281 SV* sv = POPs;
2282 if (SvTYPE(sv) == SVt_PVGV) {
2283 tmpgv = (GV*)sv;
2284 goto do_fstat;
2285 }
2286 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2287 tmpgv = (GV*)SvRV(sv);
2288 goto do_fstat;
2289 }
3280af22
NIS		 2290 sv_setpv(PL_statname, SvPV(sv,PL_na));
2291 PL_statgv = Nullgv;
a0d0e21e 2292#ifdef HAS_LSTAT
533c011a
NIS		 2293 PL_laststype = PL_op->op_type;
2294 if (PL_op->op_type == OP_LSTAT)
3280af22 2295 PL_laststatval = PerlLIO_lstat(SvPV(PL_statname, PL_na), &PL_statcache);
a0d0e21e
LW		 2296 else
2297#endif
3280af22
NIS		 2298 PL_laststatval = PerlLIO_stat(SvPV(PL_statname, PL_na), &PL_statcache);
2299 if (PL_laststatval < 0) {
599cee73 2300 if (ckWARN(WARN_NEWLINE) && strchr(SvPV(PL_statname, PL_na), '\n'))
22c35a8c 2301 warner(WARN_NEWLINE, PL_warn_nl, "stat");
a0d0e21e
LW		 2302 max = 0;
2303 }
2304 }
2305
54310121 2306 gimme = GIMME_V;
2307 if (gimme != G_ARRAY) {
2308 if (gimme != G_VOID)
2309 XPUSHs(boolSV(max));
2310 RETURN;
a0d0e21e
LW		 2311 }
2312 if (max) {
36477c24 2313 EXTEND(SP, max);
2314 EXTEND_MORTAL(max);
3280af22
NIS		 2315 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_dev)));
2316 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_ino)));
2317 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_mode)));
2318 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_nlink)));
2319 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_uid)));
2320 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_gid)));
cbdc8872 2321#ifdef USE_STAT_RDEV
3280af22 2322 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_rdev)));
cbdc8872 2323#else
2324 PUSHs(sv_2mortal(newSVpv("", 0)));
2325#endif
3280af22 2326 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_size)));
cbdc8872 2327#ifdef BIG_TIME
6b88bc9c
GS		 2328 PUSHs(sv_2mortal(newSVnv((U32)PL_statcache.st_atime)));
2329 PUSHs(sv_2mortal(newSVnv((U32)PL_statcache.st_mtime)));
2330 PUSHs(sv_2mortal(newSVnv((U32)PL_statcache.st_ctime)));
cbdc8872 2331#else
3280af22
NIS		 2332 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_atime)));
2333 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_mtime)));
2334 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_ctime)));
cbdc8872 2335#endif
a0d0e21e 2336#ifdef USE_STAT_BLOCKS
3280af22
NIS		 2337 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_blksize)));
2338 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_blocks)));
a0d0e21e
LW		 2339#else
2340 PUSHs(sv_2mortal(newSVpv("", 0)));
2341 PUSHs(sv_2mortal(newSVpv("", 0)));
2342#endif
2343 }
2344 RETURN;
2345}
2346
2347PP(pp_ftrread)
2348{
5ff3f7a4 2349 I32 result;
4e35701f 2350 djSP;
5ff3f7a4
GS		 2351#if defined(HAS_ACCESS) && defined(R_OK)
2352 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2353 result = access(TOPp, R_OK);
2354 if (result == 0)
2355 RETPUSHYES;
2356 if (result < 0)
2357 RETPUSHUNDEF;
2358 RETPUSHNO;
22865c03
GS		 2359 }
2360 else
5ff3f7a4
GS		 2361 result = my_stat(ARGS);
2362#else
2363 result = my_stat(ARGS);
2364#endif
22865c03 2365 SPAGAIN;
a0d0e21e
LW		 2366 if (result < 0)
2367 RETPUSHUNDEF;
3280af22 2368 if (cando(S_IRUSR, 0, &PL_statcache))
a0d0e21e
LW		 2369 RETPUSHYES;
2370 RETPUSHNO;
2371}
2372
2373PP(pp_ftrwrite)
2374{
5ff3f7a4 2375 I32 result;
4e35701f 2376 djSP;
5ff3f7a4
GS		 2377#if defined(HAS_ACCESS) && defined(W_OK)
2378 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2379 result = access(TOPp, W_OK);
2380 if (result == 0)
2381 RETPUSHYES;
2382 if (result < 0)
2383 RETPUSHUNDEF;
2384 RETPUSHNO;
22865c03
GS		 2385 }
2386 else
5ff3f7a4
GS		 2387 result = my_stat(ARGS);
2388#else
2389 result = my_stat(ARGS);
2390#endif
22865c03 2391 SPAGAIN;
a0d0e21e
LW		 2392 if (result < 0)
2393 RETPUSHUNDEF;
3280af22 2394 if (cando(S_IWUSR, 0, &PL_statcache))
a0d0e21e
LW		 2395 RETPUSHYES;
2396 RETPUSHNO;
2397}
2398
2399PP(pp_ftrexec)
2400{
5ff3f7a4 2401 I32 result;
4e35701f 2402 djSP;
5ff3f7a4
GS		 2403#if defined(HAS_ACCESS) && defined(X_OK)
2404 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2405 result = access(TOPp, X_OK);
2406 if (result == 0)
2407 RETPUSHYES;
2408 if (result < 0)
2409 RETPUSHUNDEF;
2410 RETPUSHNO;
22865c03
GS		 2411 }
2412 else
5ff3f7a4
GS		 2413 result = my_stat(ARGS);
2414#else
2415 result = my_stat(ARGS);
2416#endif
22865c03 2417 SPAGAIN;
a0d0e21e
LW		 2418 if (result < 0)
2419 RETPUSHUNDEF;
3280af22 2420 if (cando(S_IXUSR, 0, &PL_statcache))
a0d0e21e
LW		 2421 RETPUSHYES;
2422 RETPUSHNO;
2423}
2424
2425PP(pp_fteread)
2426{
5ff3f7a4 2427 I32 result;
4e35701f 2428 djSP;
5ff3f7a4
GS		 2429#ifdef PERL_EFF_ACCESS_R_OK
2430 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2431 result = PERL_EFF_ACCESS_R_OK(TOPp);
2432 if (result == 0)
2433 RETPUSHYES;
2434 if (result < 0)
2435 RETPUSHUNDEF;
2436 RETPUSHNO;
22865c03
GS		 2437 }
2438 else
5ff3f7a4
GS		 2439 result = my_stat(ARGS);
2440#else
2441 result = my_stat(ARGS);
2442#endif
22865c03 2443 SPAGAIN;
a0d0e21e
LW		 2444 if (result < 0)
2445 RETPUSHUNDEF;
3280af22 2446 if (cando(S_IRUSR, 1, &PL_statcache))
a0d0e21e
LW		 2447 RETPUSHYES;
2448 RETPUSHNO;
2449}
2450
2451PP(pp_ftewrite)
2452{
5ff3f7a4 2453 I32 result;
4e35701f 2454 djSP;
5ff3f7a4
GS		 2455#ifdef PERL_EFF_ACCESS_W_OK
2456 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2457 result = PERL_EFF_ACCESS_W_OK(TOPp);
2458 if (result == 0)
2459 RETPUSHYES;
2460 if (result < 0)
2461 RETPUSHUNDEF;
2462 RETPUSHNO;
22865c03
GS		 2463 }
2464 else
5ff3f7a4
GS		 2465 result = my_stat(ARGS);
2466#else
2467 result = my_stat(ARGS);
2468#endif
22865c03 2469 SPAGAIN;
a0d0e21e
LW		 2470 if (result < 0)
2471 RETPUSHUNDEF;
3280af22 2472 if (cando(S_IWUSR, 1, &PL_statcache))
a0d0e21e
LW		 2473 RETPUSHYES;
2474 RETPUSHNO;
2475}
2476
2477PP(pp_fteexec)
2478{
5ff3f7a4 2479 I32 result;
4e35701f 2480 djSP;
5ff3f7a4
GS		 2481#ifdef PERL_EFF_ACCESS_X_OK
2482 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2483 result = PERL_EFF_ACCESS_X_OK(TOPp);
2484 if (result == 0)
2485 RETPUSHYES;
2486 if (result < 0)
2487 RETPUSHUNDEF;
2488 RETPUSHNO;
22865c03
GS		 2489 }
2490 else
5ff3f7a4
GS		 2491 result = my_stat(ARGS);
2492#else
2493 result = my_stat(ARGS);
2494#endif
22865c03 2495 SPAGAIN;
a0d0e21e
LW		 2496 if (result < 0)
2497 RETPUSHUNDEF;
3280af22 2498 if (cando(S_IXUSR, 1, &PL_statcache))
a0d0e21e
LW		 2499 RETPUSHYES;
2500 RETPUSHNO;
2501}
2502
2503PP(pp_ftis)
2504{
2505 I32 result = my_stat(ARGS);
4e35701f 2506 djSP;
a0d0e21e
LW		 2507 if (result < 0)
2508 RETPUSHUNDEF;
2509 RETPUSHYES;
2510}
2511
2512PP(pp_fteowned)
2513{
2514 return pp_ftrowned(ARGS);
2515}
2516
2517PP(pp_ftrowned)
2518{
2519 I32 result = my_stat(ARGS);
4e35701f 2520 djSP;
a0d0e21e
LW		 2521 if (result < 0)
2522 RETPUSHUNDEF;
533c011a 2523 if (PL_statcache.st_uid == (PL_op->op_type == OP_FTEOWNED ? PL_euid : PL_uid) )
a0d0e21e
LW		 2524 RETPUSHYES;
2525 RETPUSHNO;
2526}
2527
2528PP(pp_ftzero)
2529{
2530 I32 result = my_stat(ARGS);
4e35701f 2531 djSP;
a0d0e21e
LW		 2532 if (result < 0)
2533 RETPUSHUNDEF;
3280af22 2534 if (!PL_statcache.st_size)
a0d0e21e
LW		 2535 RETPUSHYES;
2536 RETPUSHNO;
2537}
2538
2539PP(pp_ftsize)
2540{
2541 I32 result = my_stat(ARGS);
4e35701f 2542 djSP; dTARGET;
a0d0e21e
LW		 2543 if (result < 0)
2544 RETPUSHUNDEF;
3280af22 2545 PUSHi(PL_statcache.st_size);
a0d0e21e
LW		 2546 RETURN;
2547}
2548
2549PP(pp_ftmtime)
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_mtime) / 86400.0 );
a0d0e21e
LW		 2556 RETURN;
2557}
2558
2559PP(pp_ftatime)
2560{
2561 I32 result = my_stat(ARGS);
4e35701f 2562 djSP; dTARGET;
a0d0e21e
LW		 2563 if (result < 0)
2564 RETPUSHUNDEF;
3280af22 2565 PUSHn( ((I32)PL_basetime - (I32)PL_statcache.st_atime) / 86400.0 );
a0d0e21e
LW		 2566 RETURN;
2567}
2568
2569PP(pp_ftctime)
2570{
2571 I32 result = my_stat(ARGS);
4e35701f 2572 djSP; dTARGET;
a0d0e21e
LW		 2573 if (result < 0)
2574 RETPUSHUNDEF;
3280af22 2575 PUSHn( ((I32)PL_basetime - (I32)PL_statcache.st_ctime) / 86400.0 );
a0d0e21e
LW		 2576 RETURN;
2577}
2578
2579PP(pp_ftsock)
2580{
2581 I32 result = my_stat(ARGS);
4e35701f 2582 djSP;
a0d0e21e
LW		 2583 if (result < 0)
2584 RETPUSHUNDEF;
3280af22 2585 if (S_ISSOCK(PL_statcache.st_mode))
a0d0e21e
LW		 2586 RETPUSHYES;
2587 RETPUSHNO;
2588}
2589
2590PP(pp_ftchr)
2591{
2592 I32 result = my_stat(ARGS);
4e35701f 2593 djSP;
a0d0e21e
LW		 2594 if (result < 0)
2595 RETPUSHUNDEF;
3280af22 2596 if (S_ISCHR(PL_statcache.st_mode))
a0d0e21e
LW		 2597 RETPUSHYES;
2598 RETPUSHNO;
2599}
2600
2601PP(pp_ftblk)
2602{
2603 I32 result = my_stat(ARGS);
4e35701f 2604 djSP;
a0d0e21e
LW		 2605 if (result < 0)
2606 RETPUSHUNDEF;
3280af22 2607 if (S_ISBLK(PL_statcache.st_mode))
a0d0e21e
LW		 2608 RETPUSHYES;
2609 RETPUSHNO;
2610}
2611
2612PP(pp_ftfile)
2613{
2614 I32 result = my_stat(ARGS);
4e35701f 2615 djSP;
a0d0e21e
LW		 2616 if (result < 0)
2617 RETPUSHUNDEF;
3280af22 2618 if (S_ISREG(PL_statcache.st_mode))
a0d0e21e
LW		 2619 RETPUSHYES;
2620 RETPUSHNO;
2621}
2622
2623PP(pp_ftdir)
2624{
2625 I32 result = my_stat(ARGS);
4e35701f 2626 djSP;
a0d0e21e
LW		 2627 if (result < 0)
2628 RETPUSHUNDEF;
3280af22 2629 if (S_ISDIR(PL_statcache.st_mode))
a0d0e21e
LW		 2630 RETPUSHYES;
2631 RETPUSHNO;
2632}
2633
2634PP(pp_ftpipe)
2635{
2636 I32 result = my_stat(ARGS);
4e35701f 2637 djSP;
a0d0e21e
LW		 2638 if (result < 0)
2639 RETPUSHUNDEF;
3280af22 2640 if (S_ISFIFO(PL_statcache.st_mode))
a0d0e21e
LW		 2641 RETPUSHYES;
2642 RETPUSHNO;
2643}
2644
2645PP(pp_ftlink)
2646{
2647 I32 result = my_lstat(ARGS);
4e35701f 2648 djSP;
a0d0e21e
LW		 2649 if (result < 0)
2650 RETPUSHUNDEF;
3280af22 2651 if (S_ISLNK(PL_statcache.st_mode))
a0d0e21e
LW		 2652 RETPUSHYES;
2653 RETPUSHNO;
2654}
2655
2656PP(pp_ftsuid)
2657{
4e35701f 2658 djSP;
a0d0e21e
LW		 2659#ifdef S_ISUID
2660 I32 result = my_stat(ARGS);
2661 SPAGAIN;
2662 if (result < 0)
2663 RETPUSHUNDEF;
3280af22 2664 if (PL_statcache.st_mode & S_ISUID)
a0d0e21e
LW		 2665 RETPUSHYES;
2666#endif
2667 RETPUSHNO;
2668}
2669
2670PP(pp_ftsgid)
2671{
4e35701f 2672 djSP;
a0d0e21e
LW		 2673#ifdef S_ISGID
2674 I32 result = my_stat(ARGS);
2675 SPAGAIN;
2676 if (result < 0)
2677 RETPUSHUNDEF;
3280af22 2678 if (PL_statcache.st_mode & S_ISGID)
a0d0e21e
LW		 2679 RETPUSHYES;
2680#endif
2681 RETPUSHNO;
2682}
2683
2684PP(pp_ftsvtx)
2685{
4e35701f 2686 djSP;
a0d0e21e
LW		 2687#ifdef S_ISVTX
2688 I32 result = my_stat(ARGS);
2689 SPAGAIN;
2690 if (result < 0)
2691 RETPUSHUNDEF;
3280af22 2692 if (PL_statcache.st_mode & S_ISVTX)
a0d0e21e
LW		 2693 RETPUSHYES;
2694#endif
2695 RETPUSHNO;
2696}
2697
2698PP(pp_fttty)
2699{
4e35701f 2700 djSP;
a0d0e21e
LW		 2701 int fd;
2702 GV *gv;
fb73857a 2703 char *tmps = Nullch;
2704
533c011a 2705 if (PL_op->op_flags & OPf_REF)
a0d0e21e 2706 gv = cGVOP->op_gv;
fb73857a 2707 else if (isGV(TOPs))
2708 gv = (GV*)POPs;
2709 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
2710 gv = (GV*)SvRV(POPs);
a0d0e21e
LW		 2711 else
2712 gv = gv_fetchpv(tmps = POPp, FALSE, SVt_PVIO);
fb73857a 2713
a0d0e21e 2714 if (GvIO(gv) && IoIFP(GvIOp(gv)))
760ac839 2715 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
fb73857a 2716 else if (tmps && isDIGIT(*tmps))
a0d0e21e
LW		 2717 fd = atoi(tmps);
2718 else
2719 RETPUSHUNDEF;
6ad3d225 2720 if (PerlLIO_isatty(fd))
a0d0e21e
LW		 2721 RETPUSHYES;
2722 RETPUSHNO;
2723}
2724
16d20bd9
AD		 2725#if defined(atarist) /* this will work with atariST. Configure will
2726 make guesses for other systems. */
2727# define FILE_base(f) ((f)->_base)
2728# define FILE_ptr(f) ((f)->_ptr)
2729# define FILE_cnt(f) ((f)->_cnt)
2730# define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
a0d0e21e
LW		 2731#endif
2732
2733PP(pp_fttext)
2734{
4e35701f 2735 djSP;
a0d0e21e
LW		 2736 I32 i;
2737 I32 len;
2738 I32 odd = 0;
2739 STDCHAR tbuf[512];
2740 register STDCHAR *s;
2741 register IO *io;
5f05dabc 2742 register SV *sv;
2743 GV *gv;
a0d0e21e 2744
533c011a 2745 if (PL_op->op_flags & OPf_REF)
5f05dabc 2746 gv = cGVOP->op_gv;
2747 else if (isGV(TOPs))
2748 gv = (GV*)POPs;
2749 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
2750 gv = (GV*)SvRV(POPs);
2751 else
2752 gv = Nullgv;
2753
2754 if (gv) {
a0d0e21e 2755 EXTEND(SP, 1);
3280af22
NIS		 2756 if (gv == PL_defgv) {
2757 if (PL_statgv)
2758 io = GvIO(PL_statgv);
a0d0e21e 2759 else {
3280af22 2760 sv = PL_statname;
a0d0e21e
LW		 2761 goto really_filename;
2762 }
2763 }
2764 else {
3280af22
NIS		 2765 PL_statgv = gv;
2766 PL_laststatval = -1;
2767 sv_setpv(PL_statname, "");
2768 io = GvIO(PL_statgv);
a0d0e21e
LW		 2769 }
2770 if (io && IoIFP(io)) {
5f05dabc 2771 if (! PerlIO_has_base(IoIFP(io)))
2772 DIE("-T and -B not implemented on filehandles");
3280af22
NIS		 2773 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
2774 if (PL_laststatval < 0)
5f05dabc 2775 RETPUSHUNDEF;
3280af22 2776 if (S_ISDIR(PL_statcache.st_mode)) /* handle NFS glitch */
533c011a 2777 if (PL_op->op_type == OP_FTTEXT)
a0d0e21e
LW		 2778 RETPUSHNO;
2779 else
2780 RETPUSHYES;
760ac839
LW		 2781 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
2782 i = PerlIO_getc(IoIFP(io));
a0d0e21e 2783 if (i != EOF)
760ac839 2784 (void)PerlIO_ungetc(IoIFP(io),i);
a0d0e21e 2785 }
760ac839 2786 if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
a0d0e21e 2787 RETPUSHYES;
760ac839
LW		 2788 len = PerlIO_get_bufsiz(IoIFP(io));
2789 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
2790 /* sfio can have large buffers - limit to 512 */
2791 if (len > 512)
2792 len = 512;
a0d0e21e
LW		 2793 }
2794 else {
599cee73
PM		 2795 if (ckWARN(WARN_UNOPENED))
2796 warner(WARN_UNOPENED, "Test on unopened file <%s>",
a0d0e21e 2797 GvENAME(cGVOP->op_gv));
748a9306 2798 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW		 2799 RETPUSHUNDEF;
2800 }
2801 }
2802 else {
2803 sv = POPs;
5f05dabc 2804 really_filename:
3280af22
NIS		 2805 PL_statgv = Nullgv;
2806 PL_laststatval = -1;
2807 sv_setpv(PL_statname, SvPV(sv, PL_na));
a0d0e21e 2808#ifdef HAS_OPEN3
3280af22 2809 i = PerlLIO_open3(SvPV(sv, PL_na), O_RDONLY, 0);
a0d0e21e 2810#else
b28d0864 2811 i = PerlLIO_open(SvPV(sv, PL_na), 0);
a0d0e21e
LW		 2812#endif
2813 if (i < 0) {
599cee73 2814 if (ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, PL_na), '\n'))
22c35a8c 2815 warner(WARN_NEWLINE, PL_warn_nl, "open");
a0d0e21e
LW		 2816 RETPUSHUNDEF;
2817 }
3280af22
NIS		 2818 PL_laststatval = PerlLIO_fstat(i, &PL_statcache);
2819 if (PL_laststatval < 0)
5f05dabc 2820 RETPUSHUNDEF;
6ad3d225
GS		 2821 len = PerlLIO_read(i, tbuf, 512);
2822 (void)PerlLIO_close(i);
a0d0e21e 2823 if (len <= 0) {
533c011a 2824 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
a0d0e21e
LW		 2825 RETPUSHNO; /* special case NFS directories */
2826 RETPUSHYES; /* null file is anything */
2827 }
2828 s = tbuf;
2829 }
2830
2831 /* now scan s to look for textiness */
4633a7c4 2832 /* XXX ASCII dependent code */
a0d0e21e
LW		 2833
2834 for (i = 0; i < len; i++, s++) {
2835 if (!*s) { /* null never allowed in text */
2836 odd += len;
2837 break;
2838 }
9d116dd7
JH		 2839#ifdef EBCDIC
2840 else if (!(isPRINT(*s) || isSPACE(*s)))
2841 odd++;
2842#else
a0d0e21e
LW		 2843 else if (*s & 128)
2844 odd++;
2845 else if (*s < 32 &&
2846 *s != '\n' && *s != '\r' && *s != '\b' &&
2847 *s != '\t' && *s != '\f' && *s != 27)
2848 odd++;
9d116dd7 2849#endif
a0d0e21e
LW		 2850 }
2851
533c011a 2852 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
a0d0e21e
LW		 2853 RETPUSHNO;
2854 else
2855 RETPUSHYES;
2856}
2857
2858PP(pp_ftbinary)
2859{
2860 return pp_fttext(ARGS);
2861}
2862
2863/* File calls. */
2864
2865PP(pp_chdir)
2866{
4e35701f 2867 djSP; dTARGET;
a0d0e21e
LW		 2868 char *tmps;
2869 SV **svp;
2870
2871 if (MAXARG < 1)
2872 tmps = Nullch;
2873 else
2874 tmps = POPp;
2875 if (!tmps || !*tmps) {
3280af22 2876 svp = hv_fetch(GvHVn(PL_envgv), "HOME", 4, FALSE);
a0d0e21e 2877 if (svp)
3280af22 2878 tmps = SvPV(*svp, PL_na);
a0d0e21e
LW		 2879 }
2880 if (!tmps || !*tmps) {
3280af22 2881 svp = hv_fetch(GvHVn(PL_envgv), "LOGDIR", 6, FALSE);
a0d0e21e 2882 if (svp)
3280af22 2883 tmps = SvPV(*svp, PL_na);
a0d0e21e 2884 }
491527d0
GS		 2885#ifdef VMS
2886 if (!tmps || !*tmps) {
6b88bc9c 2887 svp = hv_fetch(GvHVn(PL_envgv), "SYS$LOGIN", 9, FALSE);
491527d0 2888 if (svp)
b28d0864 2889 tmps = SvPV(*svp, PL_na);
491527d0
GS		 2890 }
2891#endif
a0d0e21e 2892 TAINT_PROPER("chdir");
6ad3d225 2893 PUSHi( PerlDir_chdir(tmps) >= 0 );
748a9306
LW		 2894#ifdef VMS
2895 /* Clear the DEFAULT element of ENV so we'll get the new value
2896 * in the future. */
6b88bc9c 2897 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
748a9306 2898#endif
a0d0e21e
LW		 2899 RETURN;
2900}
2901
2902PP(pp_chown)
2903{
4e35701f 2904 djSP; dMARK; dTARGET;
a0d0e21e
LW		 2905 I32 value;
2906#ifdef HAS_CHOWN
533c011a 2907 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 2908 SP = MARK;
2909 PUSHi(value);
2910 RETURN;
2911#else
22c35a8c 2912 DIE(PL_no_func, "Unsupported function chown");
a0d0e21e
LW		 2913#endif
2914}
2915
2916PP(pp_chroot)
2917{
4e35701f 2918 djSP; dTARGET;
a0d0e21e
LW		 2919 char *tmps;
2920#ifdef HAS_CHROOT
2921 tmps = POPp;
2922 TAINT_PROPER("chroot");
2923 PUSHi( chroot(tmps) >= 0 );
2924 RETURN;
2925#else
22c35a8c 2926 DIE(PL_no_func, "chroot");
a0d0e21e
LW		 2927#endif
2928}
2929
2930PP(pp_unlink)
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_chmod)
2941{
4e35701f 2942 djSP; dMARK; dTARGET;
a0d0e21e 2943 I32 value;
533c011a 2944 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 2945 SP = MARK;
2946 PUSHi(value);
2947 RETURN;
2948}
2949
2950PP(pp_utime)
2951{
4e35701f 2952 djSP; dMARK; dTARGET;
a0d0e21e 2953 I32 value;
533c011a 2954 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 2955 SP = MARK;
2956 PUSHi(value);
2957 RETURN;
2958}
2959
2960PP(pp_rename)
2961{
4e35701f 2962 djSP; dTARGET;
a0d0e21e
LW		 2963 int anum;
2964
2965 char *tmps2 = POPp;
3280af22 2966 char *tmps = SvPV(TOPs, PL_na);
a0d0e21e
LW		 2967 TAINT_PROPER("rename");
2968#ifdef HAS_RENAME
baed7233 2969 anum = PerlLIO_rename(tmps, tmps2);
a0d0e21e 2970#else
6b88bc9c 2971 if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
ed969818
W		 2972 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
2973 anum = 1;
2974 else {
3654eb6c 2975 if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
ed969818
W		 2976 (void)UNLINK(tmps2);
2977 if (!(anum = link(tmps, tmps2)))
2978 anum = UNLINK(tmps);
2979 }
a0d0e21e
LW		 2980 }
2981#endif
2982 SETi( anum >= 0 );
2983 RETURN;
2984}
2985
2986PP(pp_link)
2987{
4e35701f 2988 djSP; dTARGET;
a0d0e21e
LW		 2989#ifdef HAS_LINK
2990 char *tmps2 = POPp;
3280af22 2991 char *tmps = SvPV(TOPs, PL_na);
a0d0e21e
LW		 2992 TAINT_PROPER("link");
2993 SETi( link(tmps, tmps2) >= 0 );
2994#else
22c35a8c 2995 DIE(PL_no_func, "Unsupported function link");
a0d0e21e
LW		 2996#endif
2997 RETURN;
2998}
2999
3000PP(pp_symlink)
3001{
4e35701f 3002 djSP; dTARGET;
a0d0e21e
LW		 3003#ifdef HAS_SYMLINK
3004 char *tmps2 = POPp;
3280af22 3005 char *tmps = SvPV(TOPs, PL_na);
a0d0e21e
LW		 3006 TAINT_PROPER("symlink");
3007 SETi( symlink(tmps, tmps2) >= 0 );
3008 RETURN;
3009#else
22c35a8c 3010 DIE(PL_no_func, "symlink");
a0d0e21e
LW		 3011#endif
3012}
3013
3014PP(pp_readlink)
3015{
4e35701f 3016 djSP; dTARGET;
a0d0e21e
LW		 3017#ifdef HAS_SYMLINK
3018 char *tmps;
46fc3d4c 3019 char buf[MAXPATHLEN];
a0d0e21e 3020 int len;
46fc3d4c 3021
fb73857a 3022#ifndef INCOMPLETE_TAINTS
3023 TAINT;
3024#endif
a0d0e21e
LW		 3025 tmps = POPp;
3026 len = readlink(tmps, buf, sizeof buf);
3027 EXTEND(SP, 1);
3028 if (len < 0)
3029 RETPUSHUNDEF;
3030 PUSHp(buf, len);
3031 RETURN;
3032#else
3033 EXTEND(SP, 1);
3034 RETSETUNDEF; /* just pretend it's a normal file */
3035#endif
3036}
3037
3038#if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3039static int
3040dooneliner(cmd, filename)
3041char *cmd;
3042char *filename;
3043{
1e422769 3044 char *save_filename = filename;
3045 char *cmdline;
3046 char *s;
760ac839 3047 PerlIO *myfp;
1e422769 3048 int anum = 1;
a0d0e21e 3049
1e422769 3050 New(666, cmdline, strlen(cmd) + (strlen(filename) * 2) + 10, char);
3051 strcpy(cmdline, cmd);
3052 strcat(cmdline, " ");
3053 for (s = cmdline + strlen(cmdline); *filename; ) {
a0d0e21e
LW		 3054 *s++ = '\\';
3055 *s++ = *filename++;
3056 }
3057 strcpy(s, " 2>&1");
6ad3d225 3058 myfp = PerlProc_popen(cmdline, "r");
1e422769 3059 Safefree(cmdline);
3060
a0d0e21e 3061 if (myfp) {
1e422769 3062 SV *tmpsv = sv_newmortal();
6b88bc9c 3063 /* Need to save/restore 'PL_rs' ?? */
760ac839 3064 s = sv_gets(tmpsv, myfp, 0);
6ad3d225 3065 (void)PerlProc_pclose(myfp);
a0d0e21e 3066 if (s != Nullch) {
1e422769 3067 int e;
3068 for (e = 1;
a0d0e21e 3069#ifdef HAS_SYS_ERRLIST
1e422769 3070 e <= sys_nerr
3071#endif
3072 ; e++)
3073 {
3074 /* you don't see this */
3075 char *errmsg =
3076#ifdef HAS_SYS_ERRLIST
3077 sys_errlist[e]
a0d0e21e 3078#else
1e422769 3079 strerror(e)
a0d0e21e 3080#endif
1e422769 3081 ;
3082 if (!errmsg)
3083 break;
3084 if (instr(s, errmsg)) {
3085 SETERRNO(e,0);
3086 return 0;
3087 }
a0d0e21e 3088 }
748a9306 3089 SETERRNO(0,0);
a0d0e21e
LW		 3090#ifndef EACCES
3091#define EACCES EPERM
3092#endif
1e422769 3093 if (instr(s, "cannot make"))
748a9306 3094 SETERRNO(EEXIST,RMS$_FEX);
1e422769 3095 else if (instr(s, "existing file"))
748a9306 3096 SETERRNO(EEXIST,RMS$_FEX);
1e422769 3097 else if (instr(s, "ile exists"))
748a9306 3098 SETERRNO(EEXIST,RMS$_FEX);
1e422769 3099 else if (instr(s, "non-exist"))
748a9306 3100 SETERRNO(ENOENT,RMS$_FNF);
1e422769 3101 else if (instr(s, "does not exist"))
748a9306 3102 SETERRNO(ENOENT,RMS$_FNF);
1e422769 3103 else if (instr(s, "not empty"))
748a9306 3104 SETERRNO(EBUSY,SS$_DEVOFFLINE);
1e422769 3105 else if (instr(s, "cannot access"))
748a9306 3106 SETERRNO(EACCES,RMS$_PRV);
a0d0e21e 3107 else
748a9306 3108 SETERRNO(EPERM,RMS$_PRV);
a0d0e21e
LW		 3109 return 0;
3110 }
3111 else { /* some mkdirs return no failure indication */
6b88bc9c 3112 anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
911d147d 3113 if (PL_op->op_type == OP_RMDIR)
a0d0e21e
LW		 3114 anum = !anum;
3115 if (anum)
748a9306 3116 SETERRNO(0,0);
a0d0e21e 3117 else
748a9306 3118 SETERRNO(EACCES,RMS$_PRV); /* a guess */
a0d0e21e
LW		 3119 }
3120 return anum;
3121 }
3122 else
3123 return 0;
3124}
3125#endif
3126
3127PP(pp_mkdir)
3128{
4e35701f 3129 djSP; dTARGET;
a0d0e21e
LW		 3130 int mode = POPi;
3131#ifndef HAS_MKDIR
3132 int oldumask;
3133#endif
3280af22 3134 char *tmps = SvPV(TOPs, PL_na);
a0d0e21e
LW		 3135
3136 TAINT_PROPER("mkdir");
3137#ifdef HAS_MKDIR
6ad3d225 3138 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
a0d0e21e
LW		 3139#else
3140 SETi( dooneliner("mkdir", tmps) );
6ad3d225
GS		 3141 oldumask = PerlLIO_umask(0);
3142 PerlLIO_umask(oldumask);
3143 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
a0d0e21e
LW		 3144#endif
3145 RETURN;
3146}
3147
3148PP(pp_rmdir)
3149{
4e35701f 3150 djSP; dTARGET;
a0d0e21e
LW		 3151 char *tmps;
3152
3153 tmps = POPp;
3154 TAINT_PROPER("rmdir");
3155#ifdef HAS_RMDIR
6ad3d225 3156 XPUSHi( PerlDir_rmdir(tmps) >= 0 );
a0d0e21e
LW		 3157#else
3158 XPUSHi( dooneliner("rmdir", tmps) );
3159#endif
3160 RETURN;
3161}
3162
3163/* Directory calls. */
3164
3165PP(pp_open_dir)
3166{
4e35701f 3167 djSP;
a0d0e21e
LW		 3168#if defined(Direntry_t) && defined(HAS_READDIR)
3169 char *dirname = POPp;
3170 GV *gv = (GV*)POPs;
3171 register IO *io = GvIOn(gv);
3172
3173 if (!io)
3174 goto nope;
3175
3176 if (IoDIRP(io))
6ad3d225
GS		 3177 PerlDir_close(IoDIRP(io));
3178 if (!(IoDIRP(io) = PerlDir_open(dirname)))
a0d0e21e
LW		 3179 goto nope;
3180
3181 RETPUSHYES;
3182nope:
3183 if (!errno)
748a9306 3184 SETERRNO(EBADF,RMS$_DIR);
a0d0e21e
LW		 3185 RETPUSHUNDEF;
3186#else
22c35a8c 3187 DIE(PL_no_dir_func, "opendir");
a0d0e21e
LW		 3188#endif
3189}
3190
3191PP(pp_readdir)
3192{
4e35701f 3193 djSP;
a0d0e21e
LW		 3194#if defined(Direntry_t) && defined(HAS_READDIR)
3195#ifndef I_DIRENT
3196 Direntry_t *readdir _((DIR *));
3197#endif
3198 register Direntry_t *dp;
3199 GV *gv = (GV*)POPs;
3200 register IO *io = GvIOn(gv);
fb73857a 3201 SV *sv;
a0d0e21e
LW		 3202
3203 if (!io || !IoDIRP(io))
3204 goto nope;
3205
3206 if (GIMME == G_ARRAY) {
3207 /*SUPPRESS 560*/
6ad3d225 3208 while (dp = (Direntry_t *)PerlDir_read(IoDIRP(io))) {
a0d0e21e 3209#ifdef DIRNAMLEN
fb73857a 3210 sv = newSVpv(dp->d_name, dp->d_namlen);
a0d0e21e 3211#else
fb73857a 3212 sv = newSVpv(dp->d_name, 0);
3213#endif
3214#ifndef INCOMPLETE_TAINTS
3215 SvTAINTED_on(sv);
a0d0e21e 3216#endif
fb73857a 3217 XPUSHs(sv_2mortal(sv));
a0d0e21e
LW		 3218 }
3219 }
3220 else {
6ad3d225 3221 if (!(dp = (Direntry_t *)PerlDir_read(IoDIRP(io))))
a0d0e21e
LW		 3222 goto nope;
3223#ifdef DIRNAMLEN
fb73857a 3224 sv = newSVpv(dp->d_name, dp->d_namlen);
a0d0e21e 3225#else
fb73857a 3226 sv = newSVpv(dp->d_name, 0);
a0d0e21e 3227#endif
fb73857a 3228#ifndef INCOMPLETE_TAINTS
3229 SvTAINTED_on(sv);
3230#endif
3231 XPUSHs(sv_2mortal(sv));
a0d0e21e
LW		 3232 }
3233 RETURN;
3234
3235nope:
3236 if (!errno)
748a9306 3237 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 3238 if (GIMME == G_ARRAY)
3239 RETURN;
3240 else
3241 RETPUSHUNDEF;
3242#else
22c35a8c 3243 DIE(PL_no_dir_func, "readdir");
a0d0e21e
LW		 3244#endif
3245}
3246
3247PP(pp_telldir)
3248{
4e35701f 3249 djSP; dTARGET;
a0d0e21e 3250#if defined(HAS_TELLDIR) || defined(telldir)
dfe9444c 3251# ifdef NEED_TELLDIR_PROTO /* XXX does _anyone_ need this? --AD 2/20/1998 */
a0d0e21e 3252 long telldir _((DIR *));
dfe9444c 3253# endif
a0d0e21e
LW		 3254 GV *gv = (GV*)POPs;
3255 register IO *io = GvIOn(gv);
3256
3257 if (!io || !IoDIRP(io))
3258 goto nope;
3259
6ad3d225 3260 PUSHi( PerlDir_tell(IoDIRP(io)) );
a0d0e21e
LW		 3261 RETURN;
3262nope:
3263 if (!errno)
748a9306 3264 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 3265 RETPUSHUNDEF;
3266#else
22c35a8c 3267 DIE(PL_no_dir_func, "telldir");
a0d0e21e
LW		 3268#endif
3269}
3270
3271PP(pp_seekdir)
3272{
4e35701f 3273 djSP;
a0d0e21e
LW		 3274#if defined(HAS_SEEKDIR) || defined(seekdir)
3275 long along = POPl;
3276 GV *gv = (GV*)POPs;
3277 register IO *io = GvIOn(gv);
3278
3279 if (!io || !IoDIRP(io))
3280 goto nope;
3281
6ad3d225 3282 (void)PerlDir_seek(IoDIRP(io), along);
a0d0e21e
LW		 3283
3284 RETPUSHYES;
3285nope:
3286 if (!errno)
748a9306 3287 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 3288 RETPUSHUNDEF;
3289#else
22c35a8c 3290 DIE(PL_no_dir_func, "seekdir");
a0d0e21e
LW		 3291#endif
3292}
3293
3294PP(pp_rewinddir)
3295{
4e35701f 3296 djSP;
a0d0e21e
LW		 3297#if defined(HAS_REWINDDIR) || defined(rewinddir)
3298 GV *gv = (GV*)POPs;
3299 register IO *io = GvIOn(gv);
3300
3301 if (!io || !IoDIRP(io))
3302 goto nope;
3303
6ad3d225 3304 (void)PerlDir_rewind(IoDIRP(io));
a0d0e21e
LW		 3305 RETPUSHYES;
3306nope:
3307 if (!errno)
748a9306 3308 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 3309 RETPUSHUNDEF;
3310#else
22c35a8c 3311 DIE(PL_no_dir_func, "rewinddir");
a0d0e21e
LW		 3312#endif
3313}
3314
3315PP(pp_closedir)
3316{
4e35701f 3317 djSP;
a0d0e21e
LW		 3318#if defined(Direntry_t) && defined(HAS_READDIR)
3319 GV *gv = (GV*)POPs;
3320 register IO *io = GvIOn(gv);
3321
3322 if (!io || !IoDIRP(io))
3323 goto nope;
3324
3325#ifdef VOID_CLOSEDIR
6ad3d225 3326 PerlDir_close(IoDIRP(io));
a0d0e21e 3327#else
6ad3d225 3328 if (PerlDir_close(IoDIRP(io)) < 0) {
748a9306 3329 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
a0d0e21e 3330 goto nope;
748a9306 3331 }
a0d0e21e
LW		 3332#endif
3333 IoDIRP(io) = 0;
3334
3335 RETPUSHYES;
3336nope:
3337 if (!errno)
748a9306 3338 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW		 3339 RETPUSHUNDEF;
3340#else
22c35a8c 3341 DIE(PL_no_dir_func, "closedir");
a0d0e21e
LW		 3342#endif
3343}
3344
3345/* Process control. */
3346
3347PP(pp_fork)
3348{
44a8e56a 3349#ifdef HAS_FORK
4e35701f 3350 djSP; dTARGET;
a0d0e21e
LW		 3351 int childpid;
3352 GV *tmpgv;
3353
3354 EXTEND(SP, 1);
a0d0e21e
LW		 3355 childpid = fork();
3356 if (childpid < 0)
3357 RETSETUNDEF;
3358 if (!childpid) {
3359 /*SUPPRESS 560*/
3360 if (tmpgv = gv_fetchpv("$", TRUE, SVt_PV))
1e422769 3361 sv_setiv(GvSV(tmpgv), (IV)getpid());
3280af22 3362 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
a0d0e21e
LW		 3363 }
3364 PUSHi(childpid);
3365 RETURN;
3366#else
22c35a8c 3367 DIE(PL_no_func, "Unsupported function fork");
a0d0e21e
LW		 3368#endif
3369}
3370
3371PP(pp_wait)
3372{
2d7a9237 3373#if !defined(DOSISH) || defined(OS2) || defined(WIN32)
4e35701f 3374 djSP; dTARGET;
a0d0e21e
LW		 3375 int childpid;
3376 int argflags;
a0d0e21e 3377
44a8e56a 3378 childpid = wait4pid(-1, &argflags, 0);
f86702cc 3379 STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
44a8e56a 3380 XPUSHi(childpid);
a0d0e21e
LW		 3381 RETURN;
3382#else
22c35a8c 3383 DIE(PL_no_func, "Unsupported function wait");
a0d0e21e
LW		 3384#endif
3385}
3386
3387PP(pp_waitpid)
3388{
2d7a9237 3389#if !defined(DOSISH) || defined(OS2) || defined(WIN32)
4e35701f 3390 djSP; dTARGET;
a0d0e21e
LW		 3391 int childpid;
3392 int optype;
3393 int argflags;
a0d0e21e 3394
a0d0e21e
LW		 3395 optype = POPi;
3396 childpid = TOPi;
3397 childpid = wait4pid(childpid, &argflags, optype);
f86702cc 3398 STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
44a8e56a 3399 SETi(childpid);
a0d0e21e
LW		 3400 RETURN;
3401#else
22c35a8c 3402 DIE(PL_no_func, "Unsupported function waitpid");
a0d0e21e
LW		 3403#endif
3404}
3405
3406PP(pp_system)
3407{
4e35701f 3408 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW		 3409 I32 value;
3410 int childpid;
3411 int result;
3412 int status;
ff68c719 3413 Sigsave_t ihand,qhand; /* place to save signals during system() */
a0d0e21e 3414
a0d0e21e 3415 if (SP - MARK == 1) {
3280af22
NIS		 3416 if (PL_tainting) {
3417 char *junk = SvPV(TOPs, PL_na);
a0d0e21e
LW		 3418 TAINT_ENV();
3419 TAINT_PROPER("system");
3420 }
3421 }
1e422769 3422#if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2)
a0d0e21e
LW		 3423 while ((childpid = vfork()) == -1) {
3424 if (errno != EAGAIN) {
3425 value = -1;
3426 SP = ORIGMARK;
3427 PUSHi(value);
3428 RETURN;
3429 }
3430 sleep(5);
3431 }
3432 if (childpid > 0) {
ff68c719 3433 rsignal_save(SIGINT, SIG_IGN, &ihand);
3434 rsignal_save(SIGQUIT, SIG_IGN, &qhand);
748a9306
LW		 3435 do {
3436 result = wait4pid(childpid, &status, 0);
3437 } while (result == -1 && errno == EINTR);
ff68c719 3438 (void)rsignal_restore(SIGINT, &ihand);
3439 (void)rsignal_restore(SIGQUIT, &qhand);
91e9c03f 3440 STATUS_NATIVE_SET(result == -1 ? -1 : status);
a0d0e21e
LW		 3441 do_execfree(); /* free any memory child malloced on vfork */
3442 SP = ORIGMARK;
ff0cee69 3443 PUSHi(STATUS_CURRENT);
a0d0e21e
LW		 3444 RETURN;
3445 }
533c011a 3446 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e
LW		 3447 SV *really = *++MARK;
3448 value = (I32)do_aexec(really, MARK, SP);
3449 }
3450 else if (SP - MARK != 1)
3451 value = (I32)do_aexec(Nullsv, MARK, SP);
3452 else {
3280af22 3453 value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), PL_na));
a0d0e21e 3454 }
6ad3d225 3455 PerlProc__exit(-1);
c3293030 3456#else /* ! FORK or VMS or OS/2 */
911d147d 3457 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e 3458 SV *really = *++MARK;
4e35701f 3459 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
a0d0e21e
LW		 3460 }
3461 else if (SP - MARK != 1)
4e35701f 3462 value = (I32)do_aspawn(Nullsv, (void **)MARK, (void **)SP);
a0d0e21e 3463 else {
b28d0864 3464 value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), PL_na));
a0d0e21e 3465 }
f86702cc 3466 STATUS_NATIVE_SET(value);
a0d0e21e
LW		 3467 do_execfree();
3468 SP = ORIGMARK;
ff0cee69 3469 PUSHi(STATUS_CURRENT);
a0d0e21e
LW		 3470#endif /* !FORK or VMS */
3471 RETURN;
3472}
3473
3474PP(pp_exec)
3475{
4e35701f 3476 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW		 3477 I32 value;
3478
533c011a 3479 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e
LW		 3480 SV *really = *++MARK;
3481 value = (I32)do_aexec(really, MARK, SP);
3482 }
3483 else if (SP - MARK != 1)
3484#ifdef VMS
3485 value = (I32)vms_do_aexec(Nullsv, MARK, SP);
3486#else
092bebab
JH		 3487# ifdef __OPEN_VM
3488 {
3489 (void ) do_aspawn(Nullsv, MARK, SP);
3490 value = 0;
3491 }
3492# else
a0d0e21e 3493 value = (I32)do_aexec(Nullsv, MARK, SP);
092bebab 3494# endif
a0d0e21e
LW		 3495#endif
3496 else {
3280af22
NIS		 3497 if (PL_tainting) {
3498 char *junk = SvPV(*SP, PL_na);
a0d0e21e
LW		 3499 TAINT_ENV();
3500 TAINT_PROPER("exec");
3501 }
3502#ifdef VMS
b28d0864 3503 value = (I32)vms_do_exec(SvPVx(sv_mortalcopy(*SP), PL_na));
a0d0e21e 3504#else
092bebab
JH		 3505# ifdef __OPEN_VM
3506 (void) do_spawn(SvPVx(sv_mortalcopy(*SP), PL_na));
3507 value = 0;
3508# else
3280af22 3509 value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), PL_na));
092bebab 3510# endif
a0d0e21e
LW		 3511#endif
3512 }
3513 SP = ORIGMARK;
3514 PUSHi(value);
3515 RETURN;
3516}
3517
3518PP(pp_kill)
3519{
4e35701f 3520 djSP; dMARK; dTARGET;
a0d0e21e
LW		 3521 I32 value;
3522#ifdef HAS_KILL
533c011a 3523 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 3524 SP = MARK;
3525 PUSHi(value);
3526 RETURN;
3527#else
22c35a8c 3528 DIE(PL_no_func, "Unsupported function kill");
a0d0e21e
LW		 3529#endif
3530}
3531
3532PP(pp_getppid)
3533{
3534#ifdef HAS_GETPPID
4e35701f 3535 djSP; dTARGET;
a0d0e21e
LW		 3536 XPUSHi( getppid() );
3537 RETURN;
3538#else
22c35a8c 3539 DIE(PL_no_func, "getppid");
a0d0e21e
LW		 3540#endif
3541}
3542
3543PP(pp_getpgrp)
3544{
3545#ifdef HAS_GETPGRP
4e35701f 3546 djSP; dTARGET;
a0d0e21e
LW		 3547 int pid;
3548 I32 value;
3549
3550 if (MAXARG < 1)
3551 pid = 0;
3552 else
3553 pid = SvIVx(POPs);
c3293030
IZ		 3554#ifdef BSD_GETPGRP
3555 value = (I32)BSD_GETPGRP(pid);
a0d0e21e 3556#else
aa689395 3557 if (pid != 0 && pid != getpid())
a0d0e21e
LW		 3558 DIE("POSIX getpgrp can't take an argument");
3559 value = (I32)getpgrp();
3560#endif
3561 XPUSHi(value);
3562 RETURN;
3563#else
22c35a8c 3564 DIE(PL_no_func, "getpgrp()");
a0d0e21e
LW		 3565#endif
3566}
3567
3568PP(pp_setpgrp)
3569{
3570#ifdef HAS_SETPGRP
4e35701f 3571 djSP; dTARGET;
a0d0e21e
LW		 3572 int pgrp;
3573 int pid;
3574 if (MAXARG < 2) {
3575 pgrp = 0;
3576 pid = 0;
3577 }
3578 else {
3579 pgrp = POPi;
3580 pid = TOPi;
3581 }
3582
3583 TAINT_PROPER("setpgrp");
c3293030
IZ		 3584#ifdef BSD_SETPGRP
3585 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
a0d0e21e 3586#else
c90c0ff4 3587 if ((pgrp != 0 && pgrp != getpid()) || (pid != 0 && pid != getpid()))
a0d0e21e 3588 DIE("POSIX setpgrp can't take an argument");
a0d0e21e
LW		 3589 SETi( setpgrp() >= 0 );
3590#endif /* USE_BSDPGRP */
3591 RETURN;
3592#else
22c35a8c 3593 DIE(PL_no_func, "setpgrp()");
a0d0e21e
LW		 3594#endif
3595}
3596
3597PP(pp_getpriority)
3598{
4e35701f 3599 djSP; dTARGET;
a0d0e21e
LW		 3600 int which;
3601 int who;
3602#ifdef HAS_GETPRIORITY
3603 who = POPi;
3604 which = TOPi;
3605 SETi( getpriority(which, who) );
3606 RETURN;
3607#else
22c35a8c 3608 DIE(PL_no_func, "getpriority()");
a0d0e21e
LW		 3609#endif
3610}
3611
3612PP(pp_setpriority)
3613{
4e35701f 3614 djSP; dTARGET;
a0d0e21e
LW		 3615 int which;
3616 int who;
3617 int niceval;
3618#ifdef HAS_SETPRIORITY
3619 niceval = POPi;
3620 who = POPi;
3621 which = TOPi;
3622 TAINT_PROPER("setpriority");
3623 SETi( setpriority(which, who, niceval) >= 0 );
3624 RETURN;
3625#else
22c35a8c 3626 DIE(PL_no_func, "setpriority()");
a0d0e21e
LW		 3627#endif
3628}
3629
3630/* Time calls. */
3631
3632PP(pp_time)
3633{
4e35701f 3634 djSP; dTARGET;
cbdc8872 3635#ifdef BIG_TIME
3636 XPUSHn( time(Null(Time_t*)) );
3637#else
a0d0e21e 3638 XPUSHi( time(Null(Time_t*)) );
cbdc8872 3639#endif
a0d0e21e
LW		 3640 RETURN;
3641}
3642
cd52b7b2 3643/* XXX The POSIX name is CLK_TCK; it is to be preferred
3644 to HZ. Probably. For now, assume that if the system
3645 defines HZ, it does so correctly. (Will this break
3646 on VMS?)
3647 Probably we ought to use _sysconf(_SC_CLK_TCK), if
3648 it's supported. --AD 9/96.
3649*/
3650
a0d0e21e 3651#ifndef HZ
cd52b7b2 3652# ifdef CLK_TCK
3653# define HZ CLK_TCK
3654# else
3655# define HZ 60
3656# endif
a0d0e21e
LW		 3657#endif
3658
3659PP(pp_tms)
3660{
4e35701f 3661 djSP;
a0d0e21e 3662
55497cff 3663#ifndef HAS_TIMES
a0d0e21e
LW		 3664 DIE("times not implemented");
3665#else
3666 EXTEND(SP, 4);
3667
3668#ifndef VMS
3280af22 3669 (void)PerlProc_times(&PL_timesbuf);
a0d0e21e 3670#else
6b88bc9c 3671 (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */
76e3520e
GS		 3672 /* struct tms, though same data */
3673 /* is returned. */
a0d0e21e
LW		 3674#endif
3675
3280af22 3676 PUSHs(sv_2mortal(newSVnv(((double)PL_timesbuf.tms_utime)/HZ)));
a0d0e21e 3677 if (GIMME == G_ARRAY) {
3280af22
NIS		 3678 PUSHs(sv_2mortal(newSVnv(((double)PL_timesbuf.tms_stime)/HZ)));
3679 PUSHs(sv_2mortal(newSVnv(((double)PL_timesbuf.tms_cutime)/HZ)));
3680 PUSHs(sv_2mortal(newSVnv(((double)PL_timesbuf.tms_cstime)/HZ)));
a0d0e21e
LW		 3681 }
3682 RETURN;
55497cff 3683#endif /* HAS_TIMES */
a0d0e21e
LW		 3684}
3685
3686PP(pp_localtime)
3687{
3688 return pp_gmtime(ARGS);
3689}
3690
3691PP(pp_gmtime)
3692{
4e35701f 3693 djSP;
a0d0e21e
LW		 3694 Time_t when;
3695 struct tm *tmbuf;
3696 static char *dayname[] = {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
3697 static char *monname[] = {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
3698 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
3699
3700 if (MAXARG < 1)
3701 (void)time(&when);
3702 else
cbdc8872 3703#ifdef BIG_TIME
3704 when = (Time_t)SvNVx(POPs);
3705#else
a0d0e21e 3706 when = (Time_t)SvIVx(POPs);
cbdc8872 3707#endif
a0d0e21e 3708
533c011a 3709 if (PL_op->op_type == OP_LOCALTIME)
a0d0e21e
LW		 3710 tmbuf = localtime(&when);
3711 else
3712 tmbuf = gmtime(&when);
3713
3714 EXTEND(SP, 9);
bbce6d69 3715 EXTEND_MORTAL(9);
a0d0e21e
LW		 3716 if (GIMME != G_ARRAY) {
3717 dTARGET;
46fc3d4c 3718 SV *tsv;
a0d0e21e
LW		 3719 if (!tmbuf)
3720 RETPUSHUNDEF;
46fc3d4c 3721 tsv = newSVpvf("%s %s %2d %02d:%02d:%02d %d",
3722 dayname[tmbuf->tm_wday],
3723 monname[tmbuf->tm_mon],
3724 tmbuf->tm_mday,
3725 tmbuf->tm_hour,
3726 tmbuf->tm_min,
3727 tmbuf->tm_sec,
3728 tmbuf->tm_year + 1900);
3729 PUSHs(sv_2mortal(tsv));
a0d0e21e
LW		 3730 }
3731 else if (tmbuf) {
3732 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_sec)));
3733 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_min)));
3734 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_hour)));
3735 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_mday)));
3736 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_mon)));
3737 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_year)));
3738 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_wday)));
3739 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_yday)));
3740 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_isdst)));
3741 }
3742 RETURN;
3743}
3744
3745PP(pp_alarm)
3746{
4e35701f 3747 djSP; dTARGET;
a0d0e21e
LW		 3748 int anum;
3749#ifdef HAS_ALARM
3750 anum = POPi;
3751 anum = alarm((unsigned int)anum);
3752 EXTEND(SP, 1);
3753 if (anum < 0)
3754 RETPUSHUNDEF;
3755 PUSHi((I32)anum);
3756 RETURN;
3757#else
22c35a8c 3758 DIE(PL_no_func, "Unsupported function alarm");
a0d0e21e
LW		 3759#endif
3760}
3761
3762PP(pp_sleep)
3763{
4e35701f 3764 djSP; dTARGET;
a0d0e21e
LW		 3765 I32 duration;
3766 Time_t lasttime;
3767 Time_t when;
3768
3769 (void)time(&lasttime);
3770 if (MAXARG < 1)
76e3520e 3771 PerlProc_pause();
a0d0e21e
LW		 3772 else {
3773 duration = POPi;
76e3520e 3774 PerlProc_sleep((unsigned int)duration);
a0d0e21e
LW		 3775 }
3776 (void)time(&when);
3777 XPUSHi(when - lasttime);
3778 RETURN;
3779}
3780
3781/* Shared memory. */
3782
3783PP(pp_shmget)
3784{
3785 return pp_semget(ARGS);
3786}
3787
3788PP(pp_shmctl)
3789{
3790 return pp_semctl(ARGS);
3791}
3792
3793PP(pp_shmread)
3794{
3795 return pp_shmwrite(ARGS);
3796}
3797
3798PP(pp_shmwrite)
3799{
3800#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 3801 djSP; dMARK; dTARGET;
533c011a 3802 I32 value = (I32)(do_shmio(PL_op->op_type, MARK, SP) >= 0);
a0d0e21e
LW		 3803 SP = MARK;
3804 PUSHi(value);
3805 RETURN;
3806#else
748a9306 3807 return pp_semget(ARGS);
a0d0e21e
LW		 3808#endif
3809}
3810
3811/* Message passing. */
3812
3813PP(pp_msgget)
3814{
3815 return pp_semget(ARGS);
3816}
3817
3818PP(pp_msgctl)
3819{
3820 return pp_semctl(ARGS);
3821}
3822
3823PP(pp_msgsnd)
3824{
3825#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 3826 djSP; dMARK; dTARGET;
a0d0e21e
LW		 3827 I32 value = (I32)(do_msgsnd(MARK, SP) >= 0);
3828 SP = MARK;
3829 PUSHi(value);
3830 RETURN;
3831#else
748a9306 3832 return pp_semget(ARGS);
a0d0e21e
LW		 3833#endif
3834}
3835
3836PP(pp_msgrcv)
3837{
3838#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 3839 djSP; dMARK; dTARGET;
a0d0e21e
LW		 3840 I32 value = (I32)(do_msgrcv(MARK, SP) >= 0);
3841 SP = MARK;
3842 PUSHi(value);
3843 RETURN;
3844#else
748a9306 3845 return pp_semget(ARGS);
a0d0e21e
LW		 3846#endif
3847}
3848
3849/* Semaphores. */
3850
3851PP(pp_semget)
3852{
3853#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 3854 djSP; dMARK; dTARGET;
533c011a 3855 int anum = do_ipcget(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 3856 SP = MARK;
3857 if (anum == -1)
3858 RETPUSHUNDEF;
3859 PUSHi(anum);
3860 RETURN;
3861#else
3862 DIE("System V IPC is not implemented on this machine");
3863#endif
3864}
3865
3866PP(pp_semctl)
3867{
3868#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 3869 djSP; dMARK; dTARGET;
533c011a 3870 int anum = do_ipcctl(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 3871 SP = MARK;
3872 if (anum == -1)
3873 RETSETUNDEF;
3874 if (anum != 0) {
3875 PUSHi(anum);
3876 }
3877 else {
8903cb82 3878 PUSHp(zero_but_true, ZBTLEN);
a0d0e21e
LW		 3879 }
3880 RETURN;
3881#else
748a9306 3882 return pp_semget(ARGS);
a0d0e21e
LW		 3883#endif
3884}
3885
3886PP(pp_semop)
3887{
3888#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 3889 djSP; dMARK; dTARGET;
a0d0e21e
LW		 3890 I32 value = (I32)(do_semop(MARK, SP) >= 0);
3891 SP = MARK;
3892 PUSHi(value);
3893 RETURN;
3894#else
748a9306 3895 return pp_semget(ARGS);
a0d0e21e
LW		 3896#endif
3897}
3898
3899/* Get system info. */
3900
3901PP(pp_ghbyname)
3902{
693762b4 3903#ifdef HAS_GETHOSTBYNAME
a0d0e21e
LW		 3904 return pp_ghostent(ARGS);
3905#else
22c35a8c 3906 DIE(PL_no_sock_func, "gethostbyname");
a0d0e21e
LW		 3907#endif
3908}
3909
3910PP(pp_ghbyaddr)
3911{
693762b4 3912#ifdef HAS_GETHOSTBYADDR
a0d0e21e
LW		 3913 return pp_ghostent(ARGS);
3914#else
22c35a8c 3915 DIE(PL_no_sock_func, "gethostbyaddr");
a0d0e21e
LW		 3916#endif
3917}
3918
3919PP(pp_ghostent)
3920{
4e35701f 3921 djSP;
693762b4 3922#if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
533c011a 3923 I32 which = PL_op->op_type;
a0d0e21e
LW		 3924 register char **elem;
3925 register SV *sv;
dc45a647 3926#ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4599a1de
JH		 3927 struct hostent *PerlSock_gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
3928 struct hostent *PerlSock_gethostbyname(Netdb_name_t);
6ad3d225 3929 struct hostent *PerlSock_gethostent(void);
a0d0e21e
LW		 3930#endif
3931 struct hostent *hent;
3932 unsigned long len;
3933
3934 EXTEND(SP, 10);
dc45a647
MB		 3935 if (which == OP_GHBYNAME)
3936#ifdef HAS_GETHOSTBYNAME
6ad3d225 3937 hent = PerlSock_gethostbyname(POPp);
dc45a647 3938#else
22c35a8c 3939 DIE(PL_no_sock_func, "gethostbyname");
dc45a647 3940#endif
a0d0e21e 3941 else if (which == OP_GHBYADDR) {
dc45a647 3942#ifdef HAS_GETHOSTBYADDR
a0d0e21e 3943 int addrtype = POPi;
748a9306 3944 SV *addrsv = POPs;
a0d0e21e 3945 STRLEN addrlen;
4599a1de 3946 Netdb_host_t addr = (Netdb_host_t) SvPV(addrsv, addrlen);
a0d0e21e 3947
4599a1de 3948 hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
dc45a647 3949#else
22c35a8c 3950 DIE(PL_no_sock_func, "gethostbyaddr");
dc45a647 3951#endif
a0d0e21e
LW		 3952 }
3953 else
3954#ifdef HAS_GETHOSTENT
6ad3d225 3955 hent = PerlSock_gethostent();
a0d0e21e 3956#else
22c35a8c 3957 DIE(PL_no_sock_func, "gethostent");
a0d0e21e
LW		 3958#endif
3959
3960#ifdef HOST_NOT_FOUND
3961 if (!hent)
f86702cc 3962 STATUS_NATIVE_SET(h_errno);
a0d0e21e
LW		 3963#endif
3964
3965 if (GIMME != G_ARRAY) {
3966 PUSHs(sv = sv_newmortal());
3967 if (hent) {
3968 if (which == OP_GHBYNAME) {
fd0af264 3969 if (hent->h_addr)
3970 sv_setpvn(sv, hent->h_addr, hent->h_length);
a0d0e21e
LW		 3971 }
3972 else
3973 sv_setpv(sv, (char*)hent->h_name);
3974 }
3975 RETURN;
3976 }
3977
3978 if (hent) {
3280af22 3979 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 3980 sv_setpv(sv, (char*)hent->h_name);
3280af22 3981 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 3982 for (elem = hent->h_aliases; elem && *elem; elem++) {
3983 sv_catpv(sv, *elem);
3984 if (elem[1])
3985 sv_catpvn(sv, " ", 1);
3986 }
3280af22 3987 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 3988 sv_setiv(sv, (IV)hent->h_addrtype);
3280af22 3989 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 3990 len = hent->h_length;
1e422769 3991 sv_setiv(sv, (IV)len);
a0d0e21e
LW		 3992#ifdef h_addr
3993 for (elem = hent->h_addr_list; elem && *elem; elem++) {
3280af22 3994 XPUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 3995 sv_setpvn(sv, *elem, len);
3996 }
3997#else
6b88bc9c 3998 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
fd0af264 3999 if (hent->h_addr)
4000 sv_setpvn(sv, hent->h_addr, len);
a0d0e21e
LW		 4001#endif /* h_addr */
4002 }
4003 RETURN;
4004#else
22c35a8c 4005 DIE(PL_no_sock_func, "gethostent");
a0d0e21e
LW		 4006#endif
4007}
4008
4009PP(pp_gnbyname)
4010{
693762b4 4011#ifdef HAS_GETNETBYNAME
a0d0e21e
LW		 4012 return pp_gnetent(ARGS);
4013#else
22c35a8c 4014 DIE(PL_no_sock_func, "getnetbyname");
a0d0e21e
LW		 4015#endif
4016}
4017
4018PP(pp_gnbyaddr)
4019{
693762b4 4020#ifdef HAS_GETNETBYADDR
a0d0e21e
LW		 4021 return pp_gnetent(ARGS);
4022#else
22c35a8c 4023 DIE(PL_no_sock_func, "getnetbyaddr");
a0d0e21e
LW		 4024#endif
4025}
4026
4027PP(pp_gnetent)
4028{
4e35701f 4029 djSP;
693762b4 4030#if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
533c011a 4031 I32 which = PL_op->op_type;
a0d0e21e
LW		 4032 register char **elem;
4033 register SV *sv;
dc45a647
MB		 4034#ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4035 struct netent *PerlSock_getnetbyaddr(Netdb_net_t, int);
4036 struct netent *PerlSock_getnetbyname(Netdb_name_t);
4037 struct netent *PerlSock_getnetent(void);
8ac85365 4038#endif
a0d0e21e
LW		 4039 struct netent *nent;
4040
4041 if (which == OP_GNBYNAME)
dc45a647 4042#ifdef HAS_GETNETBYNAME
76e3520e 4043 nent = PerlSock_getnetbyname(POPp);
dc45a647 4044#else
22c35a8c 4045 DIE(PL_no_sock_func, "getnetbyname");
dc45a647 4046#endif
a0d0e21e 4047 else if (which == OP_GNBYADDR) {
dc45a647 4048#ifdef HAS_GETNETBYADDR
a0d0e21e 4049 int addrtype = POPi;
4599a1de 4050 Netdb_net_t addr = (Netdb_net_t) U_L(POPn);
76e3520e 4051 nent = PerlSock_getnetbyaddr(addr, addrtype);
dc45a647 4052#else
22c35a8c 4053 DIE(PL_no_sock_func, "getnetbyaddr");
dc45a647 4054#endif
a0d0e21e
LW		 4055 }
4056 else
dc45a647 4057#ifdef HAS_GETNETENT
76e3520e 4058 nent = PerlSock_getnetent();
dc45a647 4059#else
22c35a8c 4060 DIE(PL_no_sock_func, "getnetent");
dc45a647 4061#endif
a0d0e21e
LW		 4062
4063 EXTEND(SP, 4);
4064 if (GIMME != G_ARRAY) {
4065 PUSHs(sv = sv_newmortal());
4066 if (nent) {
4067 if (which == OP_GNBYNAME)
1e422769 4068 sv_setiv(sv, (IV)nent->n_net);
a0d0e21e
LW		 4069 else
4070 sv_setpv(sv, nent->n_name);
4071 }
4072 RETURN;
4073 }
4074
4075 if (nent) {
3280af22 4076 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4077 sv_setpv(sv, nent->n_name);
3280af22 4078 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 4079 for (elem = nent->n_aliases; elem && *elem; elem++) {
a0d0e21e
LW		 4080 sv_catpv(sv, *elem);
4081 if (elem[1])
4082 sv_catpvn(sv, " ", 1);
4083 }
3280af22 4084 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4085 sv_setiv(sv, (IV)nent->n_addrtype);
3280af22 4086 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4087 sv_setiv(sv, (IV)nent->n_net);
a0d0e21e
LW		 4088 }
4089
4090 RETURN;
4091#else
22c35a8c 4092 DIE(PL_no_sock_func, "getnetent");
a0d0e21e
LW		 4093#endif
4094}
4095
4096PP(pp_gpbyname)
4097{
693762b4 4098#ifdef HAS_GETPROTOBYNAME
a0d0e21e
LW		 4099 return pp_gprotoent(ARGS);
4100#else
22c35a8c 4101 DIE(PL_no_sock_func, "getprotobyname");
a0d0e21e
LW		 4102#endif
4103}
4104
4105PP(pp_gpbynumber)
4106{
693762b4 4107#ifdef HAS_GETPROTOBYNUMBER
a0d0e21e
LW		 4108 return pp_gprotoent(ARGS);
4109#else
22c35a8c 4110 DIE(PL_no_sock_func, "getprotobynumber");
a0d0e21e
LW		 4111#endif
4112}
4113
4114PP(pp_gprotoent)
4115{
4e35701f 4116 djSP;
693762b4 4117#if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
533c011a 4118 I32 which = PL_op->op_type;
a0d0e21e 4119 register char **elem;
8ac85365 4120 register SV *sv;
dc45a647 4121#ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4599a1de 4122 struct protoent *PerlSock_getprotobyname(Netdb_name_t);
6ad3d225
GS		 4123 struct protoent *PerlSock_getprotobynumber(int);
4124 struct protoent *PerlSock_getprotoent(void);
8ac85365 4125#endif
a0d0e21e
LW		 4126 struct protoent *pent;
4127
4128 if (which == OP_GPBYNAME)
e5c9fcd0 4129#ifdef HAS_GETPROTOBYNAME
6ad3d225 4130 pent = PerlSock_getprotobyname(POPp);
e5c9fcd0 4131#else
22c35a8c 4132 DIE(PL_no_sock_func, "getprotobyname");
e5c9fcd0 4133#endif
a0d0e21e 4134 else if (which == OP_GPBYNUMBER)
e5c9fcd0 4135#ifdef HAS_GETPROTOBYNUMBER
6ad3d225 4136 pent = PerlSock_getprotobynumber(POPi);
e5c9fcd0 4137#else
22c35a8c 4138 DIE(PL_no_sock_func, "getprotobynumber");
e5c9fcd0 4139#endif
a0d0e21e 4140 else
e5c9fcd0 4141#ifdef HAS_GETPROTOENT
6ad3d225 4142 pent = PerlSock_getprotoent();
e5c9fcd0 4143#else
22c35a8c 4144 DIE(PL_no_sock_func, "getprotoent");
e5c9fcd0 4145#endif
a0d0e21e
LW		 4146
4147 EXTEND(SP, 3);
4148 if (GIMME != G_ARRAY) {
4149 PUSHs(sv = sv_newmortal());
4150 if (pent) {
4151 if (which == OP_GPBYNAME)
1e422769 4152 sv_setiv(sv, (IV)pent->p_proto);
a0d0e21e
LW		 4153 else
4154 sv_setpv(sv, pent->p_name);
4155 }
4156 RETURN;
4157 }
4158
4159 if (pent) {
3280af22 4160 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4161 sv_setpv(sv, pent->p_name);
3280af22 4162 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 4163 for (elem = pent->p_aliases; elem && *elem; elem++) {
a0d0e21e
LW		 4164 sv_catpv(sv, *elem);
4165 if (elem[1])
4166 sv_catpvn(sv, " ", 1);
4167 }
3280af22 4168 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4169 sv_setiv(sv, (IV)pent->p_proto);
a0d0e21e
LW		 4170 }
4171
4172 RETURN;
4173#else
22c35a8c 4174 DIE(PL_no_sock_func, "getprotoent");
a0d0e21e
LW		 4175#endif
4176}
4177
4178PP(pp_gsbyname)
4179{
9ec75305 4180#ifdef HAS_GETSERVBYNAME
a0d0e21e
LW		 4181 return pp_gservent(ARGS);
4182#else
22c35a8c 4183 DIE(PL_no_sock_func, "getservbyname");
a0d0e21e
LW		 4184#endif
4185}
4186
4187PP(pp_gsbyport)
4188{
9ec75305 4189#ifdef HAS_GETSERVBYPORT
a0d0e21e
LW		 4190 return pp_gservent(ARGS);
4191#else
22c35a8c 4192 DIE(PL_no_sock_func, "getservbyport");
a0d0e21e
LW		 4193#endif
4194}
4195
4196PP(pp_gservent)
4197{
4e35701f 4198 djSP;
693762b4 4199#if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
533c011a 4200 I32 which = PL_op->op_type;
a0d0e21e
LW		 4201 register char **elem;
4202 register SV *sv;
dc45a647 4203#ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4599a1de
JH		 4204 struct servent *PerlSock_getservbyname(Netdb_name_t, Netdb_name_t);
4205 struct servent *PerlSock_getservbyport(int, Netdb_name_t);
6ad3d225 4206 struct servent *PerlSock_getservent(void);
8ac85365 4207#endif
a0d0e21e
LW		 4208 struct servent *sent;
4209
4210 if (which == OP_GSBYNAME) {
dc45a647 4211#ifdef HAS_GETSERVBYNAME
a0d0e21e
LW		 4212 char *proto = POPp;
4213 char *name = POPp;
4214
4215 if (proto && !*proto)
4216 proto = Nullch;
4217
6ad3d225 4218 sent = PerlSock_getservbyname(name, proto);
dc45a647 4219#else
22c35a8c 4220 DIE(PL_no_sock_func, "getservbyname");
dc45a647 4221#endif
a0d0e21e
LW		 4222 }
4223 else if (which == OP_GSBYPORT) {
dc45a647 4224#ifdef HAS_GETSERVBYPORT
a0d0e21e 4225 char *proto = POPp;
36477c24 4226 unsigned short port = POPu;
a0d0e21e 4227
36477c24 4228#ifdef HAS_HTONS
6ad3d225 4229 port = PerlSock_htons(port);
36477c24 4230#endif
6ad3d225 4231 sent = PerlSock_getservbyport(port, proto);
dc45a647 4232#else
22c35a8c 4233 DIE(PL_no_sock_func, "getservbyport");
dc45a647 4234#endif
a0d0e21e
LW		 4235 }
4236 else
e5c9fcd0 4237#ifdef HAS_GETSERVENT
6ad3d225 4238 sent = PerlSock_getservent();
e5c9fcd0 4239#else
22c35a8c 4240 DIE(PL_no_sock_func, "getservent");
e5c9fcd0 4241#endif
a0d0e21e
LW		 4242
4243 EXTEND(SP, 4);
4244 if (GIMME != G_ARRAY) {
4245 PUSHs(sv = sv_newmortal());
4246 if (sent) {
4247 if (which == OP_GSBYNAME) {
4248#ifdef HAS_NTOHS
6ad3d225 4249 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
a0d0e21e 4250#else
1e422769 4251 sv_setiv(sv, (IV)(sent->s_port));
a0d0e21e
LW		 4252#endif
4253 }
4254 else
4255 sv_setpv(sv, sent->s_name);
4256 }
4257 RETURN;
4258 }
4259
4260 if (sent) {
3280af22 4261 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4262 sv_setpv(sv, sent->s_name);
3280af22 4263 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 4264 for (elem = sent->s_aliases; elem && *elem; elem++) {
a0d0e21e
LW		 4265 sv_catpv(sv, *elem);
4266 if (elem[1])
4267 sv_catpvn(sv, " ", 1);
4268 }
3280af22 4269 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4270#ifdef HAS_NTOHS
76e3520e 4271 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
a0d0e21e 4272#else
1e422769 4273 sv_setiv(sv, (IV)(sent->s_port));
a0d0e21e 4274#endif
3280af22 4275 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 4276 sv_setpv(sv, sent->s_proto);
4277 }
4278
4279 RETURN;
4280#else
22c35a8c 4281 DIE(PL_no_sock_func, "getservent");
a0d0e21e
LW		 4282#endif
4283}
4284
4285PP(pp_shostent)
4286{
4e35701f 4287 djSP;
693762b4 4288#ifdef HAS_SETHOSTENT
76e3520e 4289 PerlSock_sethostent(TOPi);
a0d0e21e
LW		 4290 RETSETYES;
4291#else
22c35a8c 4292 DIE(PL_no_sock_func, "sethostent");
a0d0e21e
LW		 4293#endif
4294}
4295
4296PP(pp_snetent)
4297{
4e35701f 4298 djSP;
693762b4 4299#ifdef HAS_SETNETENT
76e3520e 4300 PerlSock_setnetent(TOPi);
a0d0e21e
LW		 4301 RETSETYES;
4302#else
22c35a8c 4303 DIE(PL_no_sock_func, "setnetent");
a0d0e21e
LW		 4304#endif
4305}
4306
4307PP(pp_sprotoent)
4308{
4e35701f 4309 djSP;
693762b4 4310#ifdef HAS_SETPROTOENT
76e3520e 4311 PerlSock_setprotoent(TOPi);
a0d0e21e
LW		 4312 RETSETYES;
4313#else
22c35a8c 4314 DIE(PL_no_sock_func, "setprotoent");
a0d0e21e
LW		 4315#endif
4316}
4317
4318PP(pp_sservent)
4319{
4e35701f 4320 djSP;
693762b4 4321#ifdef HAS_SETSERVENT
76e3520e 4322 PerlSock_setservent(TOPi);
a0d0e21e
LW		 4323 RETSETYES;
4324#else
22c35a8c 4325 DIE(PL_no_sock_func, "setservent");
a0d0e21e
LW		 4326#endif
4327}
4328
4329PP(pp_ehostent)
4330{
4e35701f 4331 djSP;
693762b4 4332#ifdef HAS_ENDHOSTENT
76e3520e 4333 PerlSock_endhostent();
924508f0 4334 EXTEND(SP,1);
a0d0e21e
LW		 4335 RETPUSHYES;
4336#else
22c35a8c 4337 DIE(PL_no_sock_func, "endhostent");
a0d0e21e
LW		 4338#endif
4339}
4340
4341PP(pp_enetent)
4342{
4e35701f 4343 djSP;
693762b4 4344#ifdef HAS_ENDNETENT
76e3520e 4345 PerlSock_endnetent();
924508f0 4346 EXTEND(SP,1);
a0d0e21e
LW		 4347 RETPUSHYES;
4348#else
22c35a8c 4349 DIE(PL_no_sock_func, "endnetent");
a0d0e21e
LW		 4350#endif
4351}
4352
4353PP(pp_eprotoent)
4354{
4e35701f 4355 djSP;
693762b4 4356#ifdef HAS_ENDPROTOENT
76e3520e 4357 PerlSock_endprotoent();
924508f0 4358 EXTEND(SP,1);
a0d0e21e
LW		 4359 RETPUSHYES;
4360#else
22c35a8c 4361 DIE(PL_no_sock_func, "endprotoent");
a0d0e21e
LW		 4362#endif
4363}
4364
4365PP(pp_eservent)
4366{
4e35701f 4367 djSP;
693762b4 4368#ifdef HAS_ENDSERVENT
76e3520e 4369 PerlSock_endservent();
924508f0 4370 EXTEND(SP,1);
a0d0e21e
LW		 4371 RETPUSHYES;
4372#else
22c35a8c 4373 DIE(PL_no_sock_func, "endservent");
a0d0e21e
LW		 4374#endif
4375}
4376
4377PP(pp_gpwnam)
4378{
4379#ifdef HAS_PASSWD
4380 return pp_gpwent(ARGS);
4381#else
22c35a8c 4382 DIE(PL_no_func, "getpwnam");
a0d0e21e
LW		 4383#endif
4384}
4385
4386PP(pp_gpwuid)
4387{
4388#ifdef HAS_PASSWD
4389 return pp_gpwent(ARGS);
4390#else
22c35a8c 4391 DIE(PL_no_func, "getpwuid");
a0d0e21e
LW		 4392#endif
4393}
4394
4395PP(pp_gpwent)
4396{
4e35701f 4397 djSP;
28e8609d 4398#if defined(HAS_PASSWD) && defined(HAS_GETPWENT)
533c011a 4399 I32 which = PL_op->op_type;
a0d0e21e
LW		 4400 register SV *sv;
4401 struct passwd *pwent;
4402
4403 if (which == OP_GPWNAM)
4404 pwent = getpwnam(POPp);
4405 else if (which == OP_GPWUID)
4406 pwent = getpwuid(POPi);
4407 else
4408 pwent = (struct passwd *)getpwent();
4409
4410 EXTEND(SP, 10);
4411 if (GIMME != G_ARRAY) {
4412 PUSHs(sv = sv_newmortal());
4413 if (pwent) {
4414 if (which == OP_GPWNAM)
1e422769 4415 sv_setiv(sv, (IV)pwent->pw_uid);
a0d0e21e
LW		 4416 else
4417 sv_setpv(sv, pwent->pw_name);
4418 }
4419 RETURN;
4420 }
4421
4422 if (pwent) {
3280af22 4423 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4424 sv_setpv(sv, pwent->pw_name);
6ee623d5 4425
3280af22 4426 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
28e8609d 4427#ifdef PWPASSWD
a0d0e21e 4428 sv_setpv(sv, pwent->pw_passwd);
28e8609d 4429#endif
6ee623d5 4430
3280af22 4431 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4432 sv_setiv(sv, (IV)pwent->pw_uid);
6ee623d5 4433
3280af22 4434 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4435 sv_setiv(sv, (IV)pwent->pw_gid);
6ee623d5
GS		 4436
4437 /* pw_change, pw_quota, and pw_age are mutually exclusive. */
3280af22 4438 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4439#ifdef PWCHANGE
1e422769 4440 sv_setiv(sv, (IV)pwent->pw_change);
a0d0e21e 4441#else
6ee623d5 4442# ifdef PWQUOTA
1e422769 4443 sv_setiv(sv, (IV)pwent->pw_quota);
6ee623d5
GS		 4444# else
4445# ifdef PWAGE
a0d0e21e 4446 sv_setpv(sv, pwent->pw_age);
6ee623d5
GS		 4447# endif
4448# endif
a0d0e21e 4449#endif
6ee623d5
GS		 4450
4451 /* pw_class and pw_comment are mutually exclusive. */
3280af22 4452 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 4453#ifdef PWCLASS
4454 sv_setpv(sv, pwent->pw_class);
4455#else
6ee623d5 4456# ifdef PWCOMMENT
a0d0e21e 4457 sv_setpv(sv, pwent->pw_comment);
6ee623d5 4458# endif
a0d0e21e 4459#endif
6ee623d5 4460
3280af22 4461 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
6ee623d5 4462#ifdef PWGECOS
a0d0e21e 4463 sv_setpv(sv, pwent->pw_gecos);
6ee623d5 4464#endif
fb73857a 4465#ifndef INCOMPLETE_TAINTS
d2719217 4466 /* pw_gecos is tainted because user himself can diddle with it. */
fb73857a 4467 SvTAINTED_on(sv);
4468#endif
6ee623d5 4469
3280af22 4470 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4471 sv_setpv(sv, pwent->pw_dir);
6ee623d5 4472
3280af22 4473 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4474 sv_setpv(sv, pwent->pw_shell);
6ee623d5 4475
a0d0e21e 4476#ifdef PWEXPIRE
6b88bc9c 4477 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4478 sv_setiv(sv, (IV)pwent->pw_expire);
a0d0e21e
LW		 4479#endif
4480 }
4481 RETURN;
4482#else
22c35a8c 4483 DIE(PL_no_func, "getpwent");
a0d0e21e
LW		 4484#endif
4485}
4486
4487PP(pp_spwent)
4488{
4e35701f 4489 djSP;
28e8609d 4490#if defined(HAS_PASSWD) && defined(HAS_SETPWENT) && !defined(CYGWIN32)
a0d0e21e
LW		 4491 setpwent();
4492 RETPUSHYES;
4493#else
22c35a8c 4494 DIE(PL_no_func, "setpwent");
a0d0e21e
LW		 4495#endif
4496}
4497
4498PP(pp_epwent)
4499{
4e35701f 4500 djSP;
28e8609d 4501#if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
a0d0e21e
LW		 4502 endpwent();
4503 RETPUSHYES;
4504#else
22c35a8c 4505 DIE(PL_no_func, "endpwent");
a0d0e21e
LW		 4506#endif
4507}
4508
4509PP(pp_ggrnam)
4510{
4511#ifdef HAS_GROUP
4512 return pp_ggrent(ARGS);
4513#else
22c35a8c 4514 DIE(PL_no_func, "getgrnam");
a0d0e21e
LW		 4515#endif
4516}
4517
4518PP(pp_ggrgid)
4519{
4520#ifdef HAS_GROUP
4521 return pp_ggrent(ARGS);
4522#else
22c35a8c 4523 DIE(PL_no_func, "getgrgid");
a0d0e21e
LW		 4524#endif
4525}
4526
4527PP(pp_ggrent)
4528{
4e35701f 4529 djSP;
28e8609d 4530#if defined(HAS_GROUP) && defined(HAS_GETGRENT)
533c011a 4531 I32 which = PL_op->op_type;
a0d0e21e
LW		 4532 register char **elem;
4533 register SV *sv;
4534 struct group *grent;
4535
4536 if (which == OP_GGRNAM)
4537 grent = (struct group *)getgrnam(POPp);
4538 else if (which == OP_GGRGID)
4539 grent = (struct group *)getgrgid(POPi);
4540 else
4541 grent = (struct group *)getgrent();
4542
4543 EXTEND(SP, 4);
4544 if (GIMME != G_ARRAY) {
4545 PUSHs(sv = sv_newmortal());
4546 if (grent) {
4547 if (which == OP_GGRNAM)
1e422769 4548 sv_setiv(sv, (IV)grent->gr_gid);
a0d0e21e
LW		 4549 else
4550 sv_setpv(sv, grent->gr_name);
4551 }
4552 RETURN;
4553 }
4554
4555 if (grent) {
3280af22 4556 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4557 sv_setpv(sv, grent->gr_name);
28e8609d 4558
3280af22 4559 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
28e8609d 4560#ifdef GRPASSWD
a0d0e21e 4561 sv_setpv(sv, grent->gr_passwd);
28e8609d
JH		 4562#endif
4563
3280af22 4564 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4565 sv_setiv(sv, (IV)grent->gr_gid);
28e8609d 4566
3280af22 4567 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 4568 for (elem = grent->gr_mem; elem && *elem; elem++) {
a0d0e21e
LW		 4569 sv_catpv(sv, *elem);
4570 if (elem[1])
4571 sv_catpvn(sv, " ", 1);
4572 }
4573 }
4574
4575 RETURN;
4576#else
22c35a8c 4577 DIE(PL_no_func, "getgrent");
a0d0e21e
LW		 4578#endif
4579}
4580
4581PP(pp_sgrent)
4582{
4e35701f 4583 djSP;
28e8609d 4584#if defined(HAS_GROUP) && defined(HAS_SETGRENT)
a0d0e21e
LW		 4585 setgrent();
4586 RETPUSHYES;
4587#else
22c35a8c 4588 DIE(PL_no_func, "setgrent");
a0d0e21e
LW		 4589#endif
4590}
4591
4592PP(pp_egrent)
4593{
4e35701f 4594 djSP;
28e8609d 4595#if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
a0d0e21e
LW		 4596 endgrent();
4597 RETPUSHYES;
4598#else
22c35a8c 4599 DIE(PL_no_func, "endgrent");
a0d0e21e
LW		 4600#endif
4601}
4602
4603PP(pp_getlogin)
4604{
4e35701f 4605 djSP; dTARGET;
a0d0e21e
LW		 4606#ifdef HAS_GETLOGIN
4607 char *tmps;
4608 EXTEND(SP, 1);
76e3520e 4609 if (!(tmps = PerlProc_getlogin()))
a0d0e21e
LW		 4610 RETPUSHUNDEF;
4611 PUSHp(tmps, strlen(tmps));
4612 RETURN;
4613#else
22c35a8c 4614 DIE(PL_no_func, "getlogin");
a0d0e21e
LW		 4615#endif
4616}
4617
4618/* Miscellaneous. */
4619
4620PP(pp_syscall)
4621{
d2719217 4622#ifdef HAS_SYSCALL
4e35701f 4623 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW		 4624 register I32 items = SP - MARK;
4625 unsigned long a[20];
4626 register I32 i = 0;
4627 I32 retval = -1;
748a9306 4628 MAGIC *mg;
a0d0e21e 4629
3280af22 4630 if (PL_tainting) {
a0d0e21e 4631 while (++MARK <= SP) {
bbce6d69 4632 if (SvTAINTED(*MARK)) {
4633 TAINT;
4634 break;
4635 }
a0d0e21e
LW		 4636 }
4637 MARK = ORIGMARK;
4638 TAINT_PROPER("syscall");
4639 }
4640
4641 /* This probably won't work on machines where sizeof(long) != sizeof(int)
4642 * or where sizeof(long) != sizeof(char*). But such machines will
4643 * not likely have syscall implemented either, so who cares?
4644 */
4645 while (++MARK <= SP) {
4646 if (SvNIOK(*MARK) || !i)
4647 a[i++] = SvIV(*MARK);
3280af22 4648 else if (*MARK == &PL_sv_undef)
748a9306
LW		 4649 a[i++] = 0;
4650 else
3280af22 4651 a[i++] = (unsigned long)SvPV_force(*MARK, PL_na);
a0d0e21e
LW		 4652 if (i > 15)
4653 break;
4654 }
4655 switch (items) {
4656 default:
4657 DIE("Too many args to syscall");
4658 case 0:
4659 DIE("Too few args to syscall");
4660 case 1:
4661 retval = syscall(a[0]);
4662 break;
4663 case 2:
4664 retval = syscall(a[0],a[1]);
4665 break;
4666 case 3:
4667 retval = syscall(a[0],a[1],a[2]);
4668 break;
4669 case 4:
4670 retval = syscall(a[0],a[1],a[2],a[3]);
4671 break;
4672 case 5:
4673 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
4674 break;
4675 case 6:
4676 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
4677 break;
4678 case 7:
4679 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
4680 break;
4681 case 8:
4682 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
4683 break;
4684#ifdef atarist
4685 case 9:
4686 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
4687 break;
4688 case 10:
4689 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
4690 break;
4691 case 11:
4692 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
4693 a[10]);
4694 break;
4695 case 12:
4696 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
4697 a[10],a[11]);
4698 break;
4699 case 13:
4700 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
4701 a[10],a[11],a[12]);
4702 break;
4703 case 14:
4704 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
4705 a[10],a[11],a[12],a[13]);
4706 break;
4707#endif /* atarist */
4708 }
4709 SP = ORIGMARK;
4710 PUSHi(retval);
4711 RETURN;
4712#else
22c35a8c 4713 DIE(PL_no_func, "syscall");
a0d0e21e
LW		 4714#endif
4715}
4716
ff68c719 4717#ifdef FCNTL_EMULATE_FLOCK
4718
4719/* XXX Emulate flock() with fcntl().
4720 What's really needed is a good file locking module.
4721*/
4722
4723static int
8ac85365 4724fcntl_emulate_flock(int fd, int operation)
ff68c719 4725{
4726 struct flock flock;
4727
4728 switch (operation & ~LOCK_NB) {
4729 case LOCK_SH:
4730 flock.l_type = F_RDLCK;
4731 break;
4732 case LOCK_EX:
4733 flock.l_type = F_WRLCK;
4734 break;
4735 case LOCK_UN:
4736 flock.l_type = F_UNLCK;
4737 break;
4738 default:
4739 errno = EINVAL;
4740 return -1;
4741 }
4742 flock.l_whence = SEEK_SET;
4743 flock.l_start = flock.l_len = 0L;
4744
4745 return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
4746}
4747
4748#endif /* FCNTL_EMULATE_FLOCK */
4749
4750#ifdef LOCKF_EMULATE_FLOCK
16d20bd9
AD		 4751
4752/* XXX Emulate flock() with lockf(). This is just to increase
4753 portability of scripts. The calls are not completely
4754 interchangeable. What's really needed is a good file
4755 locking module.
4756*/
4757
76c32331 4758/* The lockf() constants might have been defined in <unistd.h>.
4759 Unfortunately, <unistd.h> causes troubles on some mixed
4760 (BSD/POSIX) systems, such as SunOS 4.1.3.
16d20bd9
AD		 4761
4762 Further, the lockf() constants aren't POSIX, so they might not be
4763 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
4764 just stick in the SVID values and be done with it. Sigh.
4765*/
4766
4767# ifndef F_ULOCK
4768# define F_ULOCK 0 /* Unlock a previously locked region */
4769# endif
4770# ifndef F_LOCK
4771# define F_LOCK 1 /* Lock a region for exclusive use */
4772# endif
4773# ifndef F_TLOCK
4774# define F_TLOCK 2 /* Test and lock a region for exclusive use */
4775# endif
4776# ifndef F_TEST
4777# define F_TEST 3 /* Test a region for other processes locks */
4778# endif
4779
55497cff 4780static int
16d20bd9
AD		 4781lockf_emulate_flock (fd, operation)
4782int fd;
4783int operation;
4784{
4785 int i;
84902520
TB		 4786 int save_errno;
4787 Off_t pos;
4788
4789 /* flock locks entire file so for lockf we need to do the same */
4790 save_errno = errno;
6ad3d225 4791 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
84902520 4792 if (pos > 0) /* is seekable and needs to be repositioned */
6ad3d225 4793 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
08b714dd 4794 pos = -1; /* seek failed, so don't seek back afterwards */
84902520
TB		 4795 errno = save_errno;
4796
16d20bd9
AD		 4797 switch (operation) {
4798
4799 /* LOCK_SH - get a shared lock */
4800 case LOCK_SH:
4801 /* LOCK_EX - get an exclusive lock */
4802 case LOCK_EX:
4803 i = lockf (fd, F_LOCK, 0);
4804 break;
4805
4806 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
4807 case LOCK_SH|LOCK_NB:
4808 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
4809 case LOCK_EX|LOCK_NB:
4810 i = lockf (fd, F_TLOCK, 0);
4811 if (i == -1)
4812 if ((errno == EAGAIN) || (errno == EACCES))
4813 errno = EWOULDBLOCK;
4814 break;
4815
ff68c719 4816 /* LOCK_UN - unlock (non-blocking is a no-op) */
16d20bd9 4817 case LOCK_UN:
ff68c719 4818 case LOCK_UN|LOCK_NB:
16d20bd9
AD		 4819 i = lockf (fd, F_ULOCK, 0);
4820 break;
4821
4822 /* Default - can't decipher operation */
4823 default:
4824 i = -1;
4825 errno = EINVAL;
4826 break;
4827 }
84902520
TB		 4828
4829 if (pos > 0) /* need to restore position of the handle */
6ad3d225 4830 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
84902520 4831
16d20bd9
AD		 4832 return (i);
4833}
ff68c719 4834
4835#endif /* LOCKF_EMULATE_FLOCK */
Unnamed repository; edit this file 'description' to name the repository.