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