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