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