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
Re: Inline PI function
[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) {
ff68c719 1523 value = (I32)(FLOCK(PerlIO_fileno(fp), argtype) >= 0);
a0d0e21e
LW		 1524 }
1525 else
1526 value = 0;
1527 PUSHi(value);
1528 RETURN;
1529#else
a0d0e21e 1530 DIE(no_func, "flock()");
a0d0e21e
LW		 1531#endif
1532}
1533
1534/* Sockets. */
1535
1536PP(pp_socket)
1537{
1538 dSP;
1539#ifdef HAS_SOCKET
1540 GV *gv;
1541 register IO *io;
1542 int protocol = POPi;
1543 int type = POPi;
1544 int domain = POPi;
1545 int fd;
1546
1547 gv = (GV*)POPs;
1548
1549 if (!gv) {
748a9306 1550 SETERRNO(EBADF,LIB$_INVARG);
a0d0e21e
LW		 1551 RETPUSHUNDEF;
1552 }
1553
1554 io = GvIOn(gv);
1555 if (IoIFP(io))
1556 do_close(gv, FALSE);
1557
1558 TAINT_PROPER("socket");
1559 fd = socket(domain, type, protocol);
1560 if (fd < 0)
1561 RETPUSHUNDEF;
760ac839
LW		 1562 IoIFP(io) = PerlIO_fdopen(fd, "r"); /* stdio gets confused about sockets */
1563 IoOFP(io) = PerlIO_fdopen(fd, "w");
a0d0e21e
LW		 1564 IoTYPE(io) = 's';
1565 if (!IoIFP(io) || !IoOFP(io)) {
760ac839
LW		 1566 if (IoIFP(io)) PerlIO_close(IoIFP(io));
1567 if (IoOFP(io)) PerlIO_close(IoOFP(io));
a0d0e21e
LW		 1568 if (!IoIFP(io) && !IoOFP(io)) close(fd);
1569 RETPUSHUNDEF;
1570 }
1571
1572 RETPUSHYES;
1573#else
1574 DIE(no_sock_func, "socket");
1575#endif
1576}
1577
1578PP(pp_sockpair)
1579{
1580 dSP;
1581#ifdef HAS_SOCKETPAIR
1582 GV *gv1;
1583 GV *gv2;
1584 register IO *io1;
1585 register IO *io2;
1586 int protocol = POPi;
1587 int type = POPi;
1588 int domain = POPi;
1589 int fd[2];
1590
1591 gv2 = (GV*)POPs;
1592 gv1 = (GV*)POPs;
1593 if (!gv1 || !gv2)
1594 RETPUSHUNDEF;
1595
1596 io1 = GvIOn(gv1);
1597 io2 = GvIOn(gv2);
1598 if (IoIFP(io1))
1599 do_close(gv1, FALSE);
1600 if (IoIFP(io2))
1601 do_close(gv2, FALSE);
1602
1603 TAINT_PROPER("socketpair");
1604 if (socketpair(domain, type, protocol, fd) < 0)
1605 RETPUSHUNDEF;
760ac839
LW		 1606 IoIFP(io1) = PerlIO_fdopen(fd[0], "r");
1607 IoOFP(io1) = PerlIO_fdopen(fd[0], "w");
a0d0e21e 1608 IoTYPE(io1) = 's';
760ac839
LW		 1609 IoIFP(io2) = PerlIO_fdopen(fd[1], "r");
1610 IoOFP(io2) = PerlIO_fdopen(fd[1], "w");
a0d0e21e
LW		 1611 IoTYPE(io2) = 's';
1612 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
760ac839
LW		 1613 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
1614 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
a0d0e21e 1615 if (!IoIFP(io1) && !IoOFP(io1)) close(fd[0]);
760ac839
LW		 1616 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
1617 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
a0d0e21e
LW		 1618 if (!IoIFP(io2) && !IoOFP(io2)) close(fd[1]);
1619 RETPUSHUNDEF;
1620 }
1621
1622 RETPUSHYES;
1623#else
1624 DIE(no_sock_func, "socketpair");
1625#endif
1626}
1627
1628PP(pp_bind)
1629{
1630 dSP;
1631#ifdef HAS_SOCKET
748a9306 1632 SV *addrsv = POPs;
a0d0e21e
LW		 1633 char *addr;
1634 GV *gv = (GV*)POPs;
1635 register IO *io = GvIOn(gv);
1636 STRLEN len;
1637
1638 if (!io || !IoIFP(io))
1639 goto nuts;
1640
748a9306 1641 addr = SvPV(addrsv, len);
a0d0e21e 1642 TAINT_PROPER("bind");
760ac839 1643 if (bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
a0d0e21e
LW		 1644 RETPUSHYES;
1645 else
1646 RETPUSHUNDEF;
1647
1648nuts:
1649 if (dowarn)
1650 warn("bind() on closed fd");
748a9306 1651 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 1652 RETPUSHUNDEF;
1653#else
1654 DIE(no_sock_func, "bind");
1655#endif
1656}
1657
1658PP(pp_connect)
1659{
1660 dSP;
1661#ifdef HAS_SOCKET
748a9306 1662 SV *addrsv = POPs;
a0d0e21e
LW		 1663 char *addr;
1664 GV *gv = (GV*)POPs;
1665 register IO *io = GvIOn(gv);
1666 STRLEN len;
1667
1668 if (!io || !IoIFP(io))
1669 goto nuts;
1670
748a9306 1671 addr = SvPV(addrsv, len);
a0d0e21e 1672 TAINT_PROPER("connect");
760ac839 1673 if (connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
a0d0e21e
LW		 1674 RETPUSHYES;
1675 else
1676 RETPUSHUNDEF;
1677
1678nuts:
1679 if (dowarn)
1680 warn("connect() on closed fd");
748a9306 1681 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 1682 RETPUSHUNDEF;
1683#else
1684 DIE(no_sock_func, "connect");
1685#endif
1686}
1687
1688PP(pp_listen)
1689{
1690 dSP;
1691#ifdef HAS_SOCKET
1692 int backlog = POPi;
1693 GV *gv = (GV*)POPs;
1694 register IO *io = GvIOn(gv);
1695
1696 if (!io || !IoIFP(io))
1697 goto nuts;
1698
760ac839 1699 if (listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
a0d0e21e
LW		 1700 RETPUSHYES;
1701 else
1702 RETPUSHUNDEF;
1703
1704nuts:
1705 if (dowarn)
1706 warn("listen() on closed fd");
748a9306 1707 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 1708 RETPUSHUNDEF;
1709#else
1710 DIE(no_sock_func, "listen");
1711#endif
1712}
1713
1714PP(pp_accept)
1715{
1716 dSP; dTARGET;
1717#ifdef HAS_SOCKET
1718 GV *ngv;
1719 GV *ggv;
1720 register IO *nstio;
1721 register IO *gstio;
4633a7c4 1722 struct sockaddr saddr; /* use a struct to avoid alignment problems */
1e422769 1723 Sock_size_t len = sizeof saddr;
a0d0e21e
LW		 1724 int fd;
1725
1726 ggv = (GV*)POPs;
1727 ngv = (GV*)POPs;
1728
1729 if (!ngv)
1730 goto badexit;
1731 if (!ggv)
1732 goto nuts;
1733
1734 gstio = GvIO(ggv);
1735 if (!gstio || !IoIFP(gstio))
1736 goto nuts;
1737
1738 nstio = GvIOn(ngv);
1739 if (IoIFP(nstio))
1740 do_close(ngv, FALSE);
1741
760ac839 1742 fd = accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *)&saddr, &len);
a0d0e21e
LW		 1743 if (fd < 0)
1744 goto badexit;
760ac839
LW		 1745 IoIFP(nstio) = PerlIO_fdopen(fd, "r");
1746 IoOFP(nstio) = PerlIO_fdopen(fd, "w");
a0d0e21e
LW		 1747 IoTYPE(nstio) = 's';
1748 if (!IoIFP(nstio) || !IoOFP(nstio)) {
760ac839
LW		 1749 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
1750 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
a0d0e21e
LW		 1751 if (!IoIFP(nstio) && !IoOFP(nstio)) close(fd);
1752 goto badexit;
1753 }
1754
748a9306 1755 PUSHp((char *)&saddr, len);
a0d0e21e
LW		 1756 RETURN;
1757
1758nuts:
1759 if (dowarn)
1760 warn("accept() on closed fd");
748a9306 1761 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 1762
1763badexit:
1764 RETPUSHUNDEF;
1765
1766#else
1767 DIE(no_sock_func, "accept");
1768#endif
1769}
1770
1771PP(pp_shutdown)
1772{
1773 dSP; dTARGET;
1774#ifdef HAS_SOCKET
1775 int how = POPi;
1776 GV *gv = (GV*)POPs;
1777 register IO *io = GvIOn(gv);
1778
1779 if (!io || !IoIFP(io))
1780 goto nuts;
1781
760ac839 1782 PUSHi( shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
a0d0e21e
LW		 1783 RETURN;
1784
1785nuts:
1786 if (dowarn)
1787 warn("shutdown() on closed fd");
748a9306 1788 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 1789 RETPUSHUNDEF;
1790#else
1791 DIE(no_sock_func, "shutdown");
1792#endif
1793}
1794
1795PP(pp_gsockopt)
1796{
1797#ifdef HAS_SOCKET
1798 return pp_ssockopt(ARGS);
1799#else
1800 DIE(no_sock_func, "getsockopt");
1801#endif
1802}
1803
1804PP(pp_ssockopt)
1805{
1806 dSP;
1807#ifdef HAS_SOCKET
1808 int optype = op->op_type;
1809 SV *sv;
1810 int fd;
1811 unsigned int optname;
1812 unsigned int lvl;
1813 GV *gv;
1814 register IO *io;
1e422769 1815 Sock_size_t len;
a0d0e21e
LW		 1816
1817 if (optype == OP_GSOCKOPT)
1818 sv = sv_2mortal(NEWSV(22, 257));
1819 else
1820 sv = POPs;
1821 optname = (unsigned int) POPi;
1822 lvl = (unsigned int) POPi;
1823
1824 gv = (GV*)POPs;
1825 io = GvIOn(gv);
1826 if (!io || !IoIFP(io))
1827 goto nuts;
1828
760ac839 1829 fd = PerlIO_fileno(IoIFP(io));
a0d0e21e
LW		 1830 switch (optype) {
1831 case OP_GSOCKOPT:
748a9306 1832 SvGROW(sv, 257);
a0d0e21e 1833 (void)SvPOK_only(sv);
748a9306
LW		 1834 SvCUR_set(sv,256);
1835 *SvEND(sv) ='\0';
1e422769 1836 len = SvCUR(sv);
1837 if (getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
a0d0e21e 1838 goto nuts2;
1e422769 1839 SvCUR_set(sv, len);
748a9306 1840 *SvEND(sv) ='\0';
a0d0e21e
LW		 1841 PUSHs(sv);
1842 break;
1843 case OP_SSOCKOPT: {
1e422769 1844 char *buf;
1845 int aint;
1846 if (SvPOKp(sv)) {
1847 buf = SvPV(sv, na);
1848 len = na;
1849 }
a0d0e21e
LW		 1850 else if (SvOK(sv)) {
1851 aint = (int)SvIV(sv);
1852 buf = (char*)&aint;
1853 len = sizeof(int);
1854 }
1e422769 1855 if (setsockopt(fd, lvl, optname, buf, len) < 0)
a0d0e21e
LW		 1856 goto nuts2;
1857 PUSHs(&sv_yes);
1858 }
1859 break;
1860 }
1861 RETURN;
1862
1863nuts:
1864 if (dowarn)
1865 warn("[gs]etsockopt() on closed fd");
748a9306 1866 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 1867nuts2:
1868 RETPUSHUNDEF;
1869
1870#else
1871 DIE(no_sock_func, "setsockopt");
1872#endif
1873}
1874
1875PP(pp_getsockname)
1876{
1877#ifdef HAS_SOCKET
1878 return pp_getpeername(ARGS);
1879#else
1880 DIE(no_sock_func, "getsockname");
1881#endif
1882}
1883
1884PP(pp_getpeername)
1885{
1886 dSP;
1887#ifdef HAS_SOCKET
1888 int optype = op->op_type;
1889 SV *sv;
1890 int fd;
1891 GV *gv = (GV*)POPs;
1892 register IO *io = GvIOn(gv);
1e422769 1893 Sock_size_t len;
a0d0e21e
LW		 1894
1895 if (!io || !IoIFP(io))
1896 goto nuts;
1897
1898 sv = sv_2mortal(NEWSV(22, 257));
748a9306 1899 (void)SvPOK_only(sv);
1e422769 1900 len = 256;
1901 SvCUR_set(sv, len);
748a9306 1902 *SvEND(sv) ='\0';
760ac839 1903 fd = PerlIO_fileno(IoIFP(io));
a0d0e21e
LW		 1904 switch (optype) {
1905 case OP_GETSOCKNAME:
1e422769 1906 if (getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
a0d0e21e
LW		 1907 goto nuts2;
1908 break;
1909 case OP_GETPEERNAME:
1e422769 1910 if (getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
a0d0e21e
LW		 1911 goto nuts2;
1912 break;
1913 }
13826f2c
CS		 1914#ifdef BOGUS_GETNAME_RETURN
1915 /* Interactive Unix, getpeername() and getsockname()
1916 does not return valid namelen */
1e422769 1917 if (len == BOGUS_GETNAME_RETURN)
1918 len = sizeof(struct sockaddr);
13826f2c 1919#endif
1e422769 1920 SvCUR_set(sv, len);
748a9306 1921 *SvEND(sv) ='\0';
a0d0e21e
LW		 1922 PUSHs(sv);
1923 RETURN;
1924
1925nuts:
1926 if (dowarn)
1927 warn("get{sock, peer}name() on closed fd");
748a9306 1928 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 1929nuts2:
1930 RETPUSHUNDEF;
1931
1932#else
1933 DIE(no_sock_func, "getpeername");
1934#endif
1935}
1936
1937/* Stat calls. */
1938
1939PP(pp_lstat)
1940{
1941 return pp_stat(ARGS);
1942}
1943
1944PP(pp_stat)
1945{
1946 dSP;
1947 GV *tmpgv;
1948 I32 max = 13;
1949
1950 if (op->op_flags & OPf_REF) {
1951 tmpgv = cGVOP->op_gv;
748a9306 1952 do_fstat:
a0d0e21e
LW		 1953 if (tmpgv != defgv) {
1954 laststype = OP_STAT;
1955 statgv = tmpgv;
1956 sv_setpv(statname, "");
36477c24 1957 laststatval = (GvIO(tmpgv) && IoIFP(GvIOp(tmpgv))
1958 ? Fstat(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), &statcache) : -1);
a0d0e21e 1959 }
36477c24 1960 if (laststatval < 0)
a0d0e21e
LW		 1961 max = 0;
1962 }
1963 else {
748a9306
LW		 1964 SV* sv = POPs;
1965 if (SvTYPE(sv) == SVt_PVGV) {
1966 tmpgv = (GV*)sv;
1967 goto do_fstat;
1968 }
1969 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
1970 tmpgv = (GV*)SvRV(sv);
1971 goto do_fstat;
1972 }
1973 sv_setpv(statname, SvPV(sv,na));
a0d0e21e
LW		 1974 statgv = Nullgv;
1975#ifdef HAS_LSTAT
1976 laststype = op->op_type;
1977 if (op->op_type == OP_LSTAT)
1978 laststatval = lstat(SvPV(statname, na), &statcache);
1979 else
1980#endif
1981 laststatval = Stat(SvPV(statname, na), &statcache);
1982 if (laststatval < 0) {
1983 if (dowarn && strchr(SvPV(statname, na), '\n'))
1984 warn(warn_nl, "stat");
1985 max = 0;
1986 }
1987 }
1988
a0d0e21e 1989 if (GIMME != G_ARRAY) {
36477c24 1990 EXTEND(SP, 1);
a0d0e21e
LW		 1991 if (max)
1992 RETPUSHYES;
1993 else
1994 RETPUSHUNDEF;
1995 }
1996 if (max) {
36477c24 1997 EXTEND(SP, max);
1998 EXTEND_MORTAL(max);
1999
a0d0e21e
LW		 2000 PUSHs(sv_2mortal(newSViv((I32)statcache.st_dev)));
2001 PUSHs(sv_2mortal(newSViv((I32)statcache.st_ino)));
2002 PUSHs(sv_2mortal(newSViv((I32)statcache.st_mode)));
2003 PUSHs(sv_2mortal(newSViv((I32)statcache.st_nlink)));
2004 PUSHs(sv_2mortal(newSViv((I32)statcache.st_uid)));
2005 PUSHs(sv_2mortal(newSViv((I32)statcache.st_gid)));
cbdc8872 2006#ifdef USE_STAT_RDEV
a0d0e21e 2007 PUSHs(sv_2mortal(newSViv((I32)statcache.st_rdev)));
cbdc8872 2008#else
2009 PUSHs(sv_2mortal(newSVpv("", 0)));
2010#endif
a0d0e21e 2011 PUSHs(sv_2mortal(newSViv((I32)statcache.st_size)));
cbdc8872 2012#ifdef BIG_TIME
2013 PUSHs(sv_2mortal(newSVnv((U32)statcache.st_atime)));
2014 PUSHs(sv_2mortal(newSVnv((U32)statcache.st_mtime)));
2015 PUSHs(sv_2mortal(newSVnv((U32)statcache.st_ctime)));
2016#else
a0d0e21e
LW		 2017 PUSHs(sv_2mortal(newSViv((I32)statcache.st_atime)));
2018 PUSHs(sv_2mortal(newSViv((I32)statcache.st_mtime)));
2019 PUSHs(sv_2mortal(newSViv((I32)statcache.st_ctime)));
cbdc8872 2020#endif
a0d0e21e
LW		 2021#ifdef USE_STAT_BLOCKS
2022 PUSHs(sv_2mortal(newSViv((I32)statcache.st_blksize)));
2023 PUSHs(sv_2mortal(newSViv((I32)statcache.st_blocks)));
2024#else
2025 PUSHs(sv_2mortal(newSVpv("", 0)));
2026 PUSHs(sv_2mortal(newSVpv("", 0)));
2027#endif
2028 }
2029 RETURN;
2030}
2031
2032PP(pp_ftrread)
2033{
2034 I32 result = my_stat(ARGS);
2035 dSP;
2036 if (result < 0)
2037 RETPUSHUNDEF;
2038 if (cando(S_IRUSR, 0, &statcache))
2039 RETPUSHYES;
2040 RETPUSHNO;
2041}
2042
2043PP(pp_ftrwrite)
2044{
2045 I32 result = my_stat(ARGS);
2046 dSP;
2047 if (result < 0)
2048 RETPUSHUNDEF;
2049 if (cando(S_IWUSR, 0, &statcache))
2050 RETPUSHYES;
2051 RETPUSHNO;
2052}
2053
2054PP(pp_ftrexec)
2055{
2056 I32 result = my_stat(ARGS);
2057 dSP;
2058 if (result < 0)
2059 RETPUSHUNDEF;
2060 if (cando(S_IXUSR, 0, &statcache))
2061 RETPUSHYES;
2062 RETPUSHNO;
2063}
2064
2065PP(pp_fteread)
2066{
2067 I32 result = my_stat(ARGS);
2068 dSP;
2069 if (result < 0)
2070 RETPUSHUNDEF;
2071 if (cando(S_IRUSR, 1, &statcache))
2072 RETPUSHYES;
2073 RETPUSHNO;
2074}
2075
2076PP(pp_ftewrite)
2077{
2078 I32 result = my_stat(ARGS);
2079 dSP;
2080 if (result < 0)
2081 RETPUSHUNDEF;
2082 if (cando(S_IWUSR, 1, &statcache))
2083 RETPUSHYES;
2084 RETPUSHNO;
2085}
2086
2087PP(pp_fteexec)
2088{
2089 I32 result = my_stat(ARGS);
2090 dSP;
2091 if (result < 0)
2092 RETPUSHUNDEF;
2093 if (cando(S_IXUSR, 1, &statcache))
2094 RETPUSHYES;
2095 RETPUSHNO;
2096}
2097
2098PP(pp_ftis)
2099{
2100 I32 result = my_stat(ARGS);
2101 dSP;
2102 if (result < 0)
2103 RETPUSHUNDEF;
2104 RETPUSHYES;
2105}
2106
2107PP(pp_fteowned)
2108{
2109 return pp_ftrowned(ARGS);
2110}
2111
2112PP(pp_ftrowned)
2113{
2114 I32 result = my_stat(ARGS);
2115 dSP;
2116 if (result < 0)
2117 RETPUSHUNDEF;
2118 if (statcache.st_uid == (op->op_type == OP_FTEOWNED ? euid : uid) )
2119 RETPUSHYES;
2120 RETPUSHNO;
2121}
2122
2123PP(pp_ftzero)
2124{
2125 I32 result = my_stat(ARGS);
2126 dSP;
2127 if (result < 0)
2128 RETPUSHUNDEF;
2129 if (!statcache.st_size)
2130 RETPUSHYES;
2131 RETPUSHNO;
2132}
2133
2134PP(pp_ftsize)
2135{
2136 I32 result = my_stat(ARGS);
2137 dSP; dTARGET;
2138 if (result < 0)
2139 RETPUSHUNDEF;
2140 PUSHi(statcache.st_size);
2141 RETURN;
2142}
2143
2144PP(pp_ftmtime)
2145{
2146 I32 result = my_stat(ARGS);
2147 dSP; dTARGET;
2148 if (result < 0)
2149 RETPUSHUNDEF;
53a31ece 2150 PUSHn( ((I32)basetime - (I32)statcache.st_mtime) / 86400.0 );
a0d0e21e
LW		 2151 RETURN;
2152}
2153
2154PP(pp_ftatime)
2155{
2156 I32 result = my_stat(ARGS);
2157 dSP; dTARGET;
2158 if (result < 0)
2159 RETPUSHUNDEF;
53a31ece 2160 PUSHn( ((I32)basetime - (I32)statcache.st_atime) / 86400.0 );
a0d0e21e
LW		 2161 RETURN;
2162}
2163
2164PP(pp_ftctime)
2165{
2166 I32 result = my_stat(ARGS);
2167 dSP; dTARGET;
2168 if (result < 0)
2169 RETPUSHUNDEF;
53a31ece 2170 PUSHn( ((I32)basetime - (I32)statcache.st_ctime) / 86400.0 );
a0d0e21e
LW		 2171 RETURN;
2172}
2173
2174PP(pp_ftsock)
2175{
2176 I32 result = my_stat(ARGS);
2177 dSP;
2178 if (result < 0)
2179 RETPUSHUNDEF;
2180 if (S_ISSOCK(statcache.st_mode))
2181 RETPUSHYES;
2182 RETPUSHNO;
2183}
2184
2185PP(pp_ftchr)
2186{
2187 I32 result = my_stat(ARGS);
2188 dSP;
2189 if (result < 0)
2190 RETPUSHUNDEF;
2191 if (S_ISCHR(statcache.st_mode))
2192 RETPUSHYES;
2193 RETPUSHNO;
2194}
2195
2196PP(pp_ftblk)
2197{
2198 I32 result = my_stat(ARGS);
2199 dSP;
2200 if (result < 0)
2201 RETPUSHUNDEF;
2202 if (S_ISBLK(statcache.st_mode))
2203 RETPUSHYES;
2204 RETPUSHNO;
2205}
2206
2207PP(pp_ftfile)
2208{
2209 I32 result = my_stat(ARGS);
2210 dSP;
2211 if (result < 0)
2212 RETPUSHUNDEF;
2213 if (S_ISREG(statcache.st_mode))
2214 RETPUSHYES;
2215 RETPUSHNO;
2216}
2217
2218PP(pp_ftdir)
2219{
2220 I32 result = my_stat(ARGS);
2221 dSP;
2222 if (result < 0)
2223 RETPUSHUNDEF;
2224 if (S_ISDIR(statcache.st_mode))
2225 RETPUSHYES;
2226 RETPUSHNO;
2227}
2228
2229PP(pp_ftpipe)
2230{
2231 I32 result = my_stat(ARGS);
2232 dSP;
2233 if (result < 0)
2234 RETPUSHUNDEF;
2235 if (S_ISFIFO(statcache.st_mode))
2236 RETPUSHYES;
2237 RETPUSHNO;
2238}
2239
2240PP(pp_ftlink)
2241{
2242 I32 result = my_lstat(ARGS);
2243 dSP;
2244 if (result < 0)
2245 RETPUSHUNDEF;
2246 if (S_ISLNK(statcache.st_mode))
2247 RETPUSHYES;
2248 RETPUSHNO;
2249}
2250
2251PP(pp_ftsuid)
2252{
2253 dSP;
2254#ifdef S_ISUID
2255 I32 result = my_stat(ARGS);
2256 SPAGAIN;
2257 if (result < 0)
2258 RETPUSHUNDEF;
2259 if (statcache.st_mode & S_ISUID)
2260 RETPUSHYES;
2261#endif
2262 RETPUSHNO;
2263}
2264
2265PP(pp_ftsgid)
2266{
2267 dSP;
2268#ifdef S_ISGID
2269 I32 result = my_stat(ARGS);
2270 SPAGAIN;
2271 if (result < 0)
2272 RETPUSHUNDEF;
2273 if (statcache.st_mode & S_ISGID)
2274 RETPUSHYES;
2275#endif
2276 RETPUSHNO;
2277}
2278
2279PP(pp_ftsvtx)
2280{
2281 dSP;
2282#ifdef S_ISVTX
2283 I32 result = my_stat(ARGS);
2284 SPAGAIN;
2285 if (result < 0)
2286 RETPUSHUNDEF;
2287 if (statcache.st_mode & S_ISVTX)
2288 RETPUSHYES;
2289#endif
2290 RETPUSHNO;
2291}
2292
2293PP(pp_fttty)
2294{
2295 dSP;
2296 int fd;
2297 GV *gv;
2298 char *tmps;
2299 if (op->op_flags & OPf_REF) {
2300 gv = cGVOP->op_gv;
2301 tmps = "";
2302 }
2303 else
2304 gv = gv_fetchpv(tmps = POPp, FALSE, SVt_PVIO);
2305 if (GvIO(gv) && IoIFP(GvIOp(gv)))
760ac839 2306 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
a0d0e21e
LW		 2307 else if (isDIGIT(*tmps))
2308 fd = atoi(tmps);
2309 else
2310 RETPUSHUNDEF;
2311 if (isatty(fd))
2312 RETPUSHYES;
2313 RETPUSHNO;
2314}
2315
16d20bd9
AD		 2316#if defined(atarist) /* this will work with atariST. Configure will
2317 make guesses for other systems. */
2318# define FILE_base(f) ((f)->_base)
2319# define FILE_ptr(f) ((f)->_ptr)
2320# define FILE_cnt(f) ((f)->_cnt)
2321# define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
a0d0e21e
LW		 2322#endif
2323
2324PP(pp_fttext)
2325{
2326 dSP;
2327 I32 i;
2328 I32 len;
2329 I32 odd = 0;
2330 STDCHAR tbuf[512];
2331 register STDCHAR *s;
2332 register IO *io;
5f05dabc 2333 register SV *sv;
2334 GV *gv;
a0d0e21e 2335
5f05dabc 2336 if (op->op_flags & OPf_REF)
2337 gv = cGVOP->op_gv;
2338 else if (isGV(TOPs))
2339 gv = (GV*)POPs;
2340 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
2341 gv = (GV*)SvRV(POPs);
2342 else
2343 gv = Nullgv;
2344
2345 if (gv) {
a0d0e21e 2346 EXTEND(SP, 1);
5f05dabc 2347 if (gv == defgv) {
a0d0e21e
LW		 2348 if (statgv)
2349 io = GvIO(statgv);
2350 else {
2351 sv = statname;
2352 goto really_filename;
2353 }
2354 }
2355 else {
5f05dabc 2356 statgv = gv;
2357 laststatval = -1;
a0d0e21e
LW		 2358 sv_setpv(statname, "");
2359 io = GvIO(statgv);
2360 }
2361 if (io && IoIFP(io)) {
5f05dabc 2362 if (! PerlIO_has_base(IoIFP(io)))
2363 DIE("-T and -B not implemented on filehandles");
2364 laststatval = Fstat(PerlIO_fileno(IoIFP(io)), &statcache);
2365 if (laststatval < 0)
2366 RETPUSHUNDEF;
a0d0e21e
LW		 2367 if (S_ISDIR(statcache.st_mode)) /* handle NFS glitch */
2368 if (op->op_type == OP_FTTEXT)
2369 RETPUSHNO;
2370 else
2371 RETPUSHYES;
760ac839
LW		 2372 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
2373 i = PerlIO_getc(IoIFP(io));
a0d0e21e 2374 if (i != EOF)
760ac839 2375 (void)PerlIO_ungetc(IoIFP(io),i);
a0d0e21e 2376 }
760ac839 2377 if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
a0d0e21e 2378 RETPUSHYES;
760ac839
LW		 2379 len = PerlIO_get_bufsiz(IoIFP(io));
2380 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
2381 /* sfio can have large buffers - limit to 512 */
2382 if (len > 512)
2383 len = 512;
a0d0e21e
LW		 2384 }
2385 else {
2386 if (dowarn)
2387 warn("Test on unopened file <%s>",
2388 GvENAME(cGVOP->op_gv));
748a9306 2389 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW		 2390 RETPUSHUNDEF;
2391 }
2392 }
2393 else {
2394 sv = POPs;
5f05dabc 2395 really_filename:
a0d0e21e 2396 statgv = Nullgv;
5f05dabc 2397 laststatval = -1;
a0d0e21e 2398 sv_setpv(statname, SvPV(sv, na));
a0d0e21e
LW		 2399#ifdef HAS_OPEN3
2400 i = open(SvPV(sv, na), O_RDONLY, 0);
2401#else
2402 i = open(SvPV(sv, na), 0);
2403#endif
2404 if (i < 0) {
2405 if (dowarn && strchr(SvPV(sv, na), '\n'))
2406 warn(warn_nl, "open");
2407 RETPUSHUNDEF;
2408 }
5f05dabc 2409 laststatval = Fstat(i, &statcache);
2410 if (laststatval < 0)
2411 RETPUSHUNDEF;
a0d0e21e
LW		 2412 len = read(i, tbuf, 512);
2413 (void)close(i);
2414 if (len <= 0) {
2415 if (S_ISDIR(statcache.st_mode) && op->op_type == OP_FTTEXT)
2416 RETPUSHNO; /* special case NFS directories */
2417 RETPUSHYES; /* null file is anything */
2418 }
2419 s = tbuf;
2420 }
2421
2422 /* now scan s to look for textiness */
4633a7c4 2423 /* XXX ASCII dependent code */
a0d0e21e
LW		 2424
2425 for (i = 0; i < len; i++, s++) {
2426 if (!*s) { /* null never allowed in text */
2427 odd += len;
2428 break;
2429 }
2430 else if (*s & 128)
2431 odd++;
2432 else if (*s < 32 &&
2433 *s != '\n' && *s != '\r' && *s != '\b' &&
2434 *s != '\t' && *s != '\f' && *s != 27)
2435 odd++;
2436 }
2437
4633a7c4 2438 if ((odd * 3 > len) == (op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
a0d0e21e
LW		 2439 RETPUSHNO;
2440 else
2441 RETPUSHYES;
2442}
2443
2444PP(pp_ftbinary)
2445{
2446 return pp_fttext(ARGS);
2447}
2448
2449/* File calls. */
2450
2451PP(pp_chdir)
2452{
2453 dSP; dTARGET;
2454 char *tmps;
2455 SV **svp;
2456
2457 if (MAXARG < 1)
2458 tmps = Nullch;
2459 else
2460 tmps = POPp;
2461 if (!tmps || !*tmps) {
2462 svp = hv_fetch(GvHVn(envgv), "HOME", 4, FALSE);
2463 if (svp)
2464 tmps = SvPV(*svp, na);
2465 }
2466 if (!tmps || !*tmps) {
2467 svp = hv_fetch(GvHVn(envgv), "LOGDIR", 6, FALSE);
2468 if (svp)
2469 tmps = SvPV(*svp, na);
2470 }
2471 TAINT_PROPER("chdir");
2472 PUSHi( chdir(tmps) >= 0 );
748a9306
LW		 2473#ifdef VMS
2474 /* Clear the DEFAULT element of ENV so we'll get the new value
2475 * in the future. */
4633a7c4 2476 hv_delete(GvHVn(envgv),"DEFAULT",7,G_DISCARD);
748a9306 2477#endif
a0d0e21e
LW		 2478 RETURN;
2479}
2480
2481PP(pp_chown)
2482{
2483 dSP; dMARK; dTARGET;
2484 I32 value;
2485#ifdef HAS_CHOWN
2486 value = (I32)apply(op->op_type, MARK, SP);
2487 SP = MARK;
2488 PUSHi(value);
2489 RETURN;
2490#else
2491 DIE(no_func, "Unsupported function chown");
2492#endif
2493}
2494
2495PP(pp_chroot)
2496{
2497 dSP; dTARGET;
2498 char *tmps;
2499#ifdef HAS_CHROOT
2500 tmps = POPp;
2501 TAINT_PROPER("chroot");
2502 PUSHi( chroot(tmps) >= 0 );
2503 RETURN;
2504#else
2505 DIE(no_func, "chroot");
2506#endif
2507}
2508
2509PP(pp_unlink)
2510{
2511 dSP; dMARK; dTARGET;
2512 I32 value;
2513 value = (I32)apply(op->op_type, MARK, SP);
2514 SP = MARK;
2515 PUSHi(value);
2516 RETURN;
2517}
2518
2519PP(pp_chmod)
2520{
2521 dSP; dMARK; dTARGET;
2522 I32 value;
2523 value = (I32)apply(op->op_type, MARK, SP);
2524 SP = MARK;
2525 PUSHi(value);
2526 RETURN;
2527}
2528
2529PP(pp_utime)
2530{
2531 dSP; dMARK; dTARGET;
2532 I32 value;
2533 value = (I32)apply(op->op_type, MARK, SP);
2534 SP = MARK;
2535 PUSHi(value);
2536 RETURN;
2537}
2538
2539PP(pp_rename)
2540{
2541 dSP; dTARGET;
2542 int anum;
2543
2544 char *tmps2 = POPp;
2545 char *tmps = SvPV(TOPs, na);
2546 TAINT_PROPER("rename");
2547#ifdef HAS_RENAME
2548 anum = rename(tmps, tmps2);
2549#else
ed969818
W		 2550 if (!(anum = Stat(tmps, &statbuf))) {
2551 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
2552 anum = 1;
2553 else {
2554 if (euid || Stat(tmps2, &statbuf) < 0 || !S_ISDIR(statbuf.st_mode))
2555 (void)UNLINK(tmps2);
2556 if (!(anum = link(tmps, tmps2)))
2557 anum = UNLINK(tmps);
2558 }
a0d0e21e
LW		 2559 }
2560#endif
2561 SETi( anum >= 0 );
2562 RETURN;
2563}
2564
2565PP(pp_link)
2566{
2567 dSP; dTARGET;
2568#ifdef HAS_LINK
2569 char *tmps2 = POPp;
2570 char *tmps = SvPV(TOPs, na);
2571 TAINT_PROPER("link");
2572 SETi( link(tmps, tmps2) >= 0 );
2573#else
2574 DIE(no_func, "Unsupported function link");
2575#endif
2576 RETURN;
2577}
2578
2579PP(pp_symlink)
2580{
2581 dSP; dTARGET;
2582#ifdef HAS_SYMLINK
2583 char *tmps2 = POPp;
2584 char *tmps = SvPV(TOPs, na);
2585 TAINT_PROPER("symlink");
2586 SETi( symlink(tmps, tmps2) >= 0 );
2587 RETURN;
2588#else
2589 DIE(no_func, "symlink");
2590#endif
2591}
2592
2593PP(pp_readlink)
2594{
2595 dSP; dTARGET;
2596#ifdef HAS_SYMLINK
2597 char *tmps;
2598 int len;
2599 tmps = POPp;
2600 len = readlink(tmps, buf, sizeof buf);
2601 EXTEND(SP, 1);
2602 if (len < 0)
2603 RETPUSHUNDEF;
2604 PUSHp(buf, len);
2605 RETURN;
2606#else
2607 EXTEND(SP, 1);
2608 RETSETUNDEF; /* just pretend it's a normal file */
2609#endif
2610}
2611
2612#if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
2613static int
2614dooneliner(cmd, filename)
2615char *cmd;
2616char *filename;
2617{
1e422769 2618 char *save_filename = filename;
2619 char *cmdline;
2620 char *s;
760ac839 2621 PerlIO *myfp;
1e422769 2622 int anum = 1;
a0d0e21e 2623
1e422769 2624 New(666, cmdline, strlen(cmd) + (strlen(filename) * 2) + 10, char);
2625 strcpy(cmdline, cmd);
2626 strcat(cmdline, " ");
2627 for (s = cmdline + strlen(cmdline); *filename; ) {
a0d0e21e
LW		 2628 *s++ = '\\';
2629 *s++ = *filename++;
2630 }
2631 strcpy(s, " 2>&1");
1e422769 2632 myfp = my_popen(cmdline, "r");
2633 Safefree(cmdline);
2634
a0d0e21e 2635 if (myfp) {
1e422769 2636 SV *tmpsv = sv_newmortal();
760ac839
LW		 2637 /* Need to save/restore 'rs' ?? */
2638 s = sv_gets(tmpsv, myfp, 0);
a0d0e21e
LW		 2639 (void)my_pclose(myfp);
2640 if (s != Nullch) {
1e422769 2641 int e;
2642 for (e = 1;
a0d0e21e 2643#ifdef HAS_SYS_ERRLIST
1e422769 2644 e <= sys_nerr
2645#endif
2646 ; e++)
2647 {
2648 /* you don't see this */
2649 char *errmsg =
2650#ifdef HAS_SYS_ERRLIST
2651 sys_errlist[e]
a0d0e21e 2652#else
1e422769 2653 strerror(e)
a0d0e21e 2654#endif
1e422769 2655 ;
2656 if (!errmsg)
2657 break;
2658 if (instr(s, errmsg)) {
2659 SETERRNO(e,0);
2660 return 0;
2661 }
a0d0e21e 2662 }
748a9306 2663 SETERRNO(0,0);
a0d0e21e
LW		 2664#ifndef EACCES
2665#define EACCES EPERM
2666#endif
1e422769 2667 if (instr(s, "cannot make"))
748a9306 2668 SETERRNO(EEXIST,RMS$_FEX);
1e422769 2669 else if (instr(s, "existing file"))
748a9306 2670 SETERRNO(EEXIST,RMS$_FEX);
1e422769 2671 else if (instr(s, "ile exists"))
748a9306 2672 SETERRNO(EEXIST,RMS$_FEX);
1e422769 2673 else if (instr(s, "non-exist"))
748a9306 2674 SETERRNO(ENOENT,RMS$_FNF);
1e422769 2675 else if (instr(s, "does not exist"))
748a9306 2676 SETERRNO(ENOENT,RMS$_FNF);
1e422769 2677 else if (instr(s, "not empty"))
748a9306 2678 SETERRNO(EBUSY,SS$_DEVOFFLINE);
1e422769 2679 else if (instr(s, "cannot access"))
748a9306 2680 SETERRNO(EACCES,RMS$_PRV);
a0d0e21e 2681 else
748a9306 2682 SETERRNO(EPERM,RMS$_PRV);
a0d0e21e
LW		 2683 return 0;
2684 }
2685 else { /* some mkdirs return no failure indication */
5d94fbed 2686 anum = (Stat(save_filename, &statbuf) >= 0);
a0d0e21e
LW		 2687 if (op->op_type == OP_RMDIR)
2688 anum = !anum;
2689 if (anum)
748a9306 2690 SETERRNO(0,0);
a0d0e21e 2691 else
748a9306 2692 SETERRNO(EACCES,RMS$_PRV); /* a guess */
a0d0e21e
LW		 2693 }
2694 return anum;
2695 }
2696 else
2697 return 0;
2698}
2699#endif
2700
2701PP(pp_mkdir)
2702{
2703 dSP; dTARGET;
2704 int mode = POPi;
2705#ifndef HAS_MKDIR
2706 int oldumask;
2707#endif
2708 char *tmps = SvPV(TOPs, na);
2709
2710 TAINT_PROPER("mkdir");
2711#ifdef HAS_MKDIR
2712 SETi( mkdir(tmps, mode) >= 0 );
2713#else
2714 SETi( dooneliner("mkdir", tmps) );
2715 oldumask = umask(0);
2716 umask(oldumask);
2717 chmod(tmps, (mode & ~oldumask) & 0777);
2718#endif
2719 RETURN;
2720}
2721
2722PP(pp_rmdir)
2723{
2724 dSP; dTARGET;
2725 char *tmps;
2726
2727 tmps = POPp;
2728 TAINT_PROPER("rmdir");
2729#ifdef HAS_RMDIR
2730 XPUSHi( rmdir(tmps) >= 0 );
2731#else
2732 XPUSHi( dooneliner("rmdir", tmps) );
2733#endif
2734 RETURN;
2735}
2736
2737/* Directory calls. */
2738
2739PP(pp_open_dir)
2740{
2741 dSP;
2742#if defined(Direntry_t) && defined(HAS_READDIR)
2743 char *dirname = POPp;
2744 GV *gv = (GV*)POPs;
2745 register IO *io = GvIOn(gv);
2746
2747 if (!io)
2748 goto nope;
2749
2750 if (IoDIRP(io))
2751 closedir(IoDIRP(io));
2752 if (!(IoDIRP(io) = opendir(dirname)))
2753 goto nope;
2754
2755 RETPUSHYES;
2756nope:
2757 if (!errno)
748a9306 2758 SETERRNO(EBADF,RMS$_DIR);
a0d0e21e
LW		 2759 RETPUSHUNDEF;
2760#else
2761 DIE(no_dir_func, "opendir");
2762#endif
2763}
2764
2765PP(pp_readdir)
2766{
2767 dSP;
2768#if defined(Direntry_t) && defined(HAS_READDIR)
2769#ifndef I_DIRENT
2770 Direntry_t *readdir _((DIR *));
2771#endif
2772 register Direntry_t *dp;
2773 GV *gv = (GV*)POPs;
2774 register IO *io = GvIOn(gv);
2775
2776 if (!io || !IoDIRP(io))
2777 goto nope;
2778
2779 if (GIMME == G_ARRAY) {
2780 /*SUPPRESS 560*/
2781 while (dp = (Direntry_t *)readdir(IoDIRP(io))) {
2782#ifdef DIRNAMLEN
2783 XPUSHs(sv_2mortal(newSVpv(dp->d_name, dp->d_namlen)));
2784#else
2785 XPUSHs(sv_2mortal(newSVpv(dp->d_name, 0)));
2786#endif
2787 }
2788 }
2789 else {
2790 if (!(dp = (Direntry_t *)readdir(IoDIRP(io))))
2791 goto nope;
2792#ifdef DIRNAMLEN
2793 XPUSHs(sv_2mortal(newSVpv(dp->d_name, dp->d_namlen)));
2794#else
2795 XPUSHs(sv_2mortal(newSVpv(dp->d_name, 0)));
2796#endif
2797 }
2798 RETURN;
2799
2800nope:
2801 if (!errno)
748a9306 2802 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 2803 if (GIMME == G_ARRAY)
2804 RETURN;
2805 else
2806 RETPUSHUNDEF;
2807#else
2808 DIE(no_dir_func, "readdir");
2809#endif
2810}
2811
2812PP(pp_telldir)
2813{
2814 dSP; dTARGET;
2815#if defined(HAS_TELLDIR) || defined(telldir)
2816#if !defined(telldir) && !defined(HAS_TELLDIR_PROTOTYPE)
2817 long telldir _((DIR *));
2818#endif
2819 GV *gv = (GV*)POPs;
2820 register IO *io = GvIOn(gv);
2821
2822 if (!io || !IoDIRP(io))
2823 goto nope;
2824
2825 PUSHi( telldir(IoDIRP(io)) );
2826 RETURN;
2827nope:
2828 if (!errno)
748a9306 2829 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 2830 RETPUSHUNDEF;
2831#else
2832 DIE(no_dir_func, "telldir");
2833#endif
2834}
2835
2836PP(pp_seekdir)
2837{
2838 dSP;
2839#if defined(HAS_SEEKDIR) || defined(seekdir)
2840 long along = POPl;
2841 GV *gv = (GV*)POPs;
2842 register IO *io = GvIOn(gv);
2843
2844 if (!io || !IoDIRP(io))
2845 goto nope;
2846
2847 (void)seekdir(IoDIRP(io), along);
2848
2849 RETPUSHYES;
2850nope:
2851 if (!errno)
748a9306 2852 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 2853 RETPUSHUNDEF;
2854#else
2855 DIE(no_dir_func, "seekdir");
2856#endif
2857}
2858
2859PP(pp_rewinddir)
2860{
2861 dSP;
2862#if defined(HAS_REWINDDIR) || defined(rewinddir)
2863 GV *gv = (GV*)POPs;
2864 register IO *io = GvIOn(gv);
2865
2866 if (!io || !IoDIRP(io))
2867 goto nope;
2868
2869 (void)rewinddir(IoDIRP(io));
2870 RETPUSHYES;
2871nope:
2872 if (!errno)
748a9306 2873 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 2874 RETPUSHUNDEF;
2875#else
2876 DIE(no_dir_func, "rewinddir");
2877#endif
2878}
2879
2880PP(pp_closedir)
2881{
2882 dSP;
2883#if defined(Direntry_t) && defined(HAS_READDIR)
2884 GV *gv = (GV*)POPs;
2885 register IO *io = GvIOn(gv);
2886
2887 if (!io || !IoDIRP(io))
2888 goto nope;
2889
2890#ifdef VOID_CLOSEDIR
2891 closedir(IoDIRP(io));
2892#else
748a9306
LW		 2893 if (closedir(IoDIRP(io)) < 0) {
2894 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
a0d0e21e 2895 goto nope;
748a9306 2896 }
a0d0e21e
LW		 2897#endif
2898 IoDIRP(io) = 0;
2899
2900 RETPUSHYES;
2901nope:
2902 if (!errno)
748a9306 2903 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW		 2904 RETPUSHUNDEF;
2905#else
2906 DIE(no_dir_func, "closedir");
2907#endif
2908}
2909
2910/* Process control. */
2911
2912PP(pp_fork)
2913{
44a8e56a 2914#ifdef HAS_FORK
a0d0e21e
LW		 2915 dSP; dTARGET;
2916 int childpid;
2917 GV *tmpgv;
2918
2919 EXTEND(SP, 1);
a0d0e21e
LW		 2920 childpid = fork();
2921 if (childpid < 0)
2922 RETSETUNDEF;
2923 if (!childpid) {
2924 /*SUPPRESS 560*/
2925 if (tmpgv = gv_fetchpv("$", TRUE, SVt_PV))
1e422769 2926 sv_setiv(GvSV(tmpgv), (IV)getpid());
a0d0e21e
LW		 2927 hv_clear(pidstatus); /* no kids, so don't wait for 'em */
2928 }
2929 PUSHi(childpid);
2930 RETURN;
2931#else
2932 DIE(no_func, "Unsupported function fork");
2933#endif
2934}
2935
2936PP(pp_wait)
2937{
44a8e56a 2938#if !defined(DOSISH) || defined(OS2)
a0d0e21e
LW		 2939 dSP; dTARGET;
2940 int childpid;
2941 int argflags;
a0d0e21e 2942
44a8e56a 2943 childpid = wait4pid(-1, &argflags, 0);
f86702cc 2944 STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
44a8e56a 2945 XPUSHi(childpid);
a0d0e21e
LW		 2946 RETURN;
2947#else
2948 DIE(no_func, "Unsupported function wait");
2949#endif
2950}
2951
2952PP(pp_waitpid)
2953{
44a8e56a 2954#if !defined(DOSISH) || defined(OS2)
a0d0e21e
LW		 2955 dSP; dTARGET;
2956 int childpid;
2957 int optype;
2958 int argflags;
a0d0e21e 2959
a0d0e21e
LW		 2960 optype = POPi;
2961 childpid = TOPi;
2962 childpid = wait4pid(childpid, &argflags, optype);
f86702cc 2963 STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
44a8e56a 2964 SETi(childpid);
a0d0e21e
LW		 2965 RETURN;
2966#else
2967 DIE(no_func, "Unsupported function wait");
2968#endif
2969}
2970
2971PP(pp_system)
2972{
2973 dSP; dMARK; dORIGMARK; dTARGET;
2974 I32 value;
2975 int childpid;
2976 int result;
2977 int status;
ff68c719 2978 Sigsave_t ihand,qhand; /* place to save signals during system() */
a0d0e21e 2979
a0d0e21e
LW		 2980 if (SP - MARK == 1) {
2981 if (tainting) {
2982 char *junk = SvPV(TOPs, na);
2983 TAINT_ENV();
2984 TAINT_PROPER("system");
2985 }
2986 }
1e422769 2987#if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2)
a0d0e21e
LW		 2988 while ((childpid = vfork()) == -1) {
2989 if (errno != EAGAIN) {
2990 value = -1;
2991 SP = ORIGMARK;
2992 PUSHi(value);
2993 RETURN;
2994 }
2995 sleep(5);
2996 }
2997 if (childpid > 0) {
ff68c719 2998 rsignal_save(SIGINT, SIG_IGN, &ihand);
2999 rsignal_save(SIGQUIT, SIG_IGN, &qhand);
748a9306
LW		 3000 do {
3001 result = wait4pid(childpid, &status, 0);
3002 } while (result == -1 && errno == EINTR);
ff68c719 3003 (void)rsignal_restore(SIGINT, &ihand);
3004 (void)rsignal_restore(SIGQUIT, &qhand);
91e9c03f 3005 STATUS_NATIVE_SET(result == -1 ? -1 : status);
a0d0e21e
LW		 3006 do_execfree(); /* free any memory child malloced on vfork */
3007 SP = ORIGMARK;
ff0cee69 3008 PUSHi(STATUS_CURRENT);
a0d0e21e
LW		 3009 RETURN;
3010 }
3011 if (op->op_flags & OPf_STACKED) {
3012 SV *really = *++MARK;
3013 value = (I32)do_aexec(really, MARK, SP);
3014 }
3015 else if (SP - MARK != 1)
3016 value = (I32)do_aexec(Nullsv, MARK, SP);
3017 else {
3018 value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), na));
3019 }
3020 _exit(-1);
c3293030 3021#else /* ! FORK or VMS or OS/2 */
a0d0e21e
LW		 3022 if (op->op_flags & OPf_STACKED) {
3023 SV *really = *++MARK;
3024 value = (I32)do_aspawn(really, MARK, SP);
3025 }
3026 else if (SP - MARK != 1)
3027 value = (I32)do_aspawn(Nullsv, MARK, SP);
3028 else {
3029 value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), na));
3030 }
f86702cc 3031 STATUS_NATIVE_SET(value);
a0d0e21e
LW		 3032 do_execfree();
3033 SP = ORIGMARK;
ff0cee69 3034 PUSHi(STATUS_CURRENT);
a0d0e21e
LW		 3035#endif /* !FORK or VMS */
3036 RETURN;
3037}
3038
3039PP(pp_exec)
3040{
3041 dSP; dMARK; dORIGMARK; dTARGET;
3042 I32 value;
3043
3044 if (op->op_flags & OPf_STACKED) {
3045 SV *really = *++MARK;
3046 value = (I32)do_aexec(really, MARK, SP);
3047 }
3048 else if (SP - MARK != 1)
3049#ifdef VMS
3050 value = (I32)vms_do_aexec(Nullsv, MARK, SP);
3051#else
3052 value = (I32)do_aexec(Nullsv, MARK, SP);
3053#endif
3054 else {
3055 if (tainting) {
3056 char *junk = SvPV(*SP, na);
3057 TAINT_ENV();
3058 TAINT_PROPER("exec");
3059 }
3060#ifdef VMS
3061 value = (I32)vms_do_exec(SvPVx(sv_mortalcopy(*SP), na));
3062#else
3063 value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), na));
3064#endif
3065 }
3066 SP = ORIGMARK;
3067 PUSHi(value);
3068 RETURN;
3069}
3070
3071PP(pp_kill)
3072{
3073 dSP; dMARK; dTARGET;
3074 I32 value;
3075#ifdef HAS_KILL
3076 value = (I32)apply(op->op_type, MARK, SP);
3077 SP = MARK;
3078 PUSHi(value);
3079 RETURN;
3080#else
3081 DIE(no_func, "Unsupported function kill");
3082#endif
3083}
3084
3085PP(pp_getppid)
3086{
3087#ifdef HAS_GETPPID
3088 dSP; dTARGET;
3089 XPUSHi( getppid() );
3090 RETURN;
3091#else
3092 DIE(no_func, "getppid");
3093#endif
3094}
3095
3096PP(pp_getpgrp)
3097{
3098#ifdef HAS_GETPGRP
3099 dSP; dTARGET;
3100 int pid;
3101 I32 value;
3102
3103 if (MAXARG < 1)
3104 pid = 0;
3105 else
3106 pid = SvIVx(POPs);
c3293030
IZ		 3107#ifdef BSD_GETPGRP
3108 value = (I32)BSD_GETPGRP(pid);
a0d0e21e 3109#else
aa689395 3110 if (pid != 0 && pid != getpid())
a0d0e21e
LW		 3111 DIE("POSIX getpgrp can't take an argument");
3112 value = (I32)getpgrp();
3113#endif
3114 XPUSHi(value);
3115 RETURN;
3116#else
3117 DIE(no_func, "getpgrp()");
3118#endif
3119}
3120
3121PP(pp_setpgrp)
3122{
3123#ifdef HAS_SETPGRP
3124 dSP; dTARGET;
3125 int pgrp;
3126 int pid;
3127 if (MAXARG < 2) {
3128 pgrp = 0;
3129 pid = 0;
3130 }
3131 else {
3132 pgrp = POPi;
3133 pid = TOPi;
3134 }
3135
3136 TAINT_PROPER("setpgrp");
c3293030
IZ		 3137#ifdef BSD_SETPGRP
3138 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
a0d0e21e 3139#else
aa689395 3140 if ((pgrp != 0 && pgrp != getpid())) || (pid != 0 && pid != getpid()))
a0d0e21e 3141 DIE("POSIX setpgrp can't take an argument");
a0d0e21e
LW		 3142 SETi( setpgrp() >= 0 );
3143#endif /* USE_BSDPGRP */
3144 RETURN;
3145#else
3146 DIE(no_func, "setpgrp()");
3147#endif
3148}
3149
3150PP(pp_getpriority)
3151{
3152 dSP; dTARGET;
3153 int which;
3154 int who;
3155#ifdef HAS_GETPRIORITY
3156 who = POPi;
3157 which = TOPi;
3158 SETi( getpriority(which, who) );
3159 RETURN;
3160#else
3161 DIE(no_func, "getpriority()");
3162#endif
3163}
3164
3165PP(pp_setpriority)
3166{
3167 dSP; dTARGET;
3168 int which;
3169 int who;
3170 int niceval;
3171#ifdef HAS_SETPRIORITY
3172 niceval = POPi;
3173 who = POPi;
3174 which = TOPi;
3175 TAINT_PROPER("setpriority");
3176 SETi( setpriority(which, who, niceval) >= 0 );
3177 RETURN;
3178#else
3179 DIE(no_func, "setpriority()");
3180#endif
3181}
3182
3183/* Time calls. */
3184
3185PP(pp_time)
3186{
3187 dSP; dTARGET;
cbdc8872 3188#ifdef BIG_TIME
3189 XPUSHn( time(Null(Time_t*)) );
3190#else
a0d0e21e 3191 XPUSHi( time(Null(Time_t*)) );
cbdc8872 3192#endif
a0d0e21e
LW		 3193 RETURN;
3194}
3195
cd52b7b2 3196/* XXX The POSIX name is CLK_TCK; it is to be preferred
3197 to HZ. Probably. For now, assume that if the system
3198 defines HZ, it does so correctly. (Will this break
3199 on VMS?)
3200 Probably we ought to use _sysconf(_SC_CLK_TCK), if
3201 it's supported. --AD 9/96.
3202*/
3203
a0d0e21e 3204#ifndef HZ
cd52b7b2 3205# ifdef CLK_TCK
3206# define HZ CLK_TCK
3207# else
3208# define HZ 60
3209# endif
a0d0e21e
LW		 3210#endif
3211
3212PP(pp_tms)
3213{
3214 dSP;
3215
55497cff 3216#ifndef HAS_TIMES
a0d0e21e
LW		 3217 DIE("times not implemented");
3218#else
3219 EXTEND(SP, 4);
3220
3221#ifndef VMS
3222 (void)times(&timesbuf);
3223#else
3224 (void)times((tbuffer_t *)&timesbuf); /* time.h uses different name for */
3225 /* struct tms, though same data */
3226 /* is returned. */
3227#endif
3228
3229 PUSHs(sv_2mortal(newSVnv(((double)timesbuf.tms_utime)/HZ)));
3230 if (GIMME == G_ARRAY) {
3231 PUSHs(sv_2mortal(newSVnv(((double)timesbuf.tms_stime)/HZ)));
3232 PUSHs(sv_2mortal(newSVnv(((double)timesbuf.tms_cutime)/HZ)));
3233 PUSHs(sv_2mortal(newSVnv(((double)timesbuf.tms_cstime)/HZ)));
3234 }
3235 RETURN;
55497cff 3236#endif /* HAS_TIMES */
a0d0e21e
LW		 3237}
3238
3239PP(pp_localtime)
3240{
3241 return pp_gmtime(ARGS);
3242}
3243
3244PP(pp_gmtime)
3245{
3246 dSP;
3247 Time_t when;
3248 struct tm *tmbuf;
3249 static char *dayname[] = {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
3250 static char *monname[] = {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
3251 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
3252
3253 if (MAXARG < 1)
3254 (void)time(&when);
3255 else
cbdc8872 3256#ifdef BIG_TIME
3257 when = (Time_t)SvNVx(POPs);
3258#else
a0d0e21e 3259 when = (Time_t)SvIVx(POPs);
cbdc8872 3260#endif
a0d0e21e
LW		 3261
3262 if (op->op_type == OP_LOCALTIME)
3263 tmbuf = localtime(&when);
3264 else
3265 tmbuf = gmtime(&when);
3266
3267 EXTEND(SP, 9);
bbce6d69 3268 EXTEND_MORTAL(9);
a0d0e21e
LW		 3269 if (GIMME != G_ARRAY) {
3270 dTARGET;
3271 char mybuf[30];
3272 if (!tmbuf)
3273 RETPUSHUNDEF;
3274 sprintf(mybuf, "%s %s %2d %02d:%02d:%02d %d",
3275 dayname[tmbuf->tm_wday],
3276 monname[tmbuf->tm_mon],
3277 tmbuf->tm_mday,
3278 tmbuf->tm_hour,
3279 tmbuf->tm_min,
3280 tmbuf->tm_sec,
3281 tmbuf->tm_year + 1900);
3282 PUSHp(mybuf, strlen(mybuf));
3283 }
3284 else if (tmbuf) {
3285 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_sec)));
3286 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_min)));
3287 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_hour)));
3288 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_mday)));
3289 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_mon)));
3290 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_year)));
3291 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_wday)));
3292 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_yday)));
3293 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_isdst)));
3294 }
3295 RETURN;
3296}
3297
3298PP(pp_alarm)
3299{
3300 dSP; dTARGET;
3301 int anum;
3302#ifdef HAS_ALARM
3303 anum = POPi;
3304 anum = alarm((unsigned int)anum);
3305 EXTEND(SP, 1);
3306 if (anum < 0)
3307 RETPUSHUNDEF;
3308 PUSHi((I32)anum);
3309 RETURN;
3310#else
3311 DIE(no_func, "Unsupported function alarm");
a0d0e21e
LW		 3312#endif
3313}
3314
3315PP(pp_sleep)
3316{
3317 dSP; dTARGET;
3318 I32 duration;
3319 Time_t lasttime;
3320 Time_t when;
3321
3322 (void)time(&lasttime);
3323 if (MAXARG < 1)
76c32331 3324 Pause();
a0d0e21e
LW		 3325 else {
3326 duration = POPi;
3327 sleep((unsigned int)duration);
3328 }
3329 (void)time(&when);
3330 XPUSHi(when - lasttime);
3331 RETURN;
3332}
3333
3334/* Shared memory. */
3335
3336PP(pp_shmget)
3337{
3338 return pp_semget(ARGS);
3339}
3340
3341PP(pp_shmctl)
3342{
3343 return pp_semctl(ARGS);
3344}
3345
3346PP(pp_shmread)
3347{
3348 return pp_shmwrite(ARGS);
3349}
3350
3351PP(pp_shmwrite)
3352{
3353#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
3354 dSP; dMARK; dTARGET;
3355 I32 value = (I32)(do_shmio(op->op_type, MARK, SP) >= 0);
3356 SP = MARK;
3357 PUSHi(value);
3358 RETURN;
3359#else
748a9306 3360 return pp_semget(ARGS);
a0d0e21e
LW		 3361#endif
3362}
3363
3364/* Message passing. */
3365
3366PP(pp_msgget)
3367{
3368 return pp_semget(ARGS);
3369}
3370
3371PP(pp_msgctl)
3372{
3373 return pp_semctl(ARGS);
3374}
3375
3376PP(pp_msgsnd)
3377{
3378#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
3379 dSP; dMARK; dTARGET;
3380 I32 value = (I32)(do_msgsnd(MARK, SP) >= 0);
3381 SP = MARK;
3382 PUSHi(value);
3383 RETURN;
3384#else
748a9306 3385 return pp_semget(ARGS);
a0d0e21e
LW		 3386#endif
3387}
3388
3389PP(pp_msgrcv)
3390{
3391#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
3392 dSP; dMARK; dTARGET;
3393 I32 value = (I32)(do_msgrcv(MARK, SP) >= 0);
3394 SP = MARK;
3395 PUSHi(value);
3396 RETURN;
3397#else
748a9306 3398 return pp_semget(ARGS);
a0d0e21e
LW		 3399#endif
3400}
3401
3402/* Semaphores. */
3403
3404PP(pp_semget)
3405{
3406#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
3407 dSP; dMARK; dTARGET;
3408 int anum = do_ipcget(op->op_type, MARK, SP);
3409 SP = MARK;
3410 if (anum == -1)
3411 RETPUSHUNDEF;
3412 PUSHi(anum);
3413 RETURN;
3414#else
3415 DIE("System V IPC is not implemented on this machine");
3416#endif
3417}
3418
3419PP(pp_semctl)
3420{
3421#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
3422 dSP; dMARK; dTARGET;
3423 int anum = do_ipcctl(op->op_type, MARK, SP);
3424 SP = MARK;
3425 if (anum == -1)
3426 RETSETUNDEF;
3427 if (anum != 0) {
3428 PUSHi(anum);
3429 }
3430 else {
3431 PUSHp("0 but true",10);
3432 }
3433 RETURN;
3434#else
748a9306 3435 return pp_semget(ARGS);
a0d0e21e
LW		 3436#endif
3437}
3438
3439PP(pp_semop)
3440{
3441#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
3442 dSP; dMARK; dTARGET;
3443 I32 value = (I32)(do_semop(MARK, SP) >= 0);
3444 SP = MARK;
3445 PUSHi(value);
3446 RETURN;
3447#else
748a9306 3448 return pp_semget(ARGS);
a0d0e21e
LW		 3449#endif
3450}
3451
3452/* Get system info. */
3453
3454PP(pp_ghbyname)
3455{
3456#ifdef HAS_SOCKET
3457 return pp_ghostent(ARGS);
3458#else
3459 DIE(no_sock_func, "gethostbyname");
3460#endif
3461}
3462
3463PP(pp_ghbyaddr)
3464{
3465#ifdef HAS_SOCKET
3466 return pp_ghostent(ARGS);
3467#else
3468 DIE(no_sock_func, "gethostbyaddr");
3469#endif
3470}
3471
3472PP(pp_ghostent)
3473{
3474 dSP;
3475#ifdef HAS_SOCKET
3476 I32 which = op->op_type;
3477 register char **elem;
3478 register SV *sv;
3479 struct hostent *gethostbyname();
3480 struct hostent *gethostbyaddr();
3481#ifdef HAS_GETHOSTENT
3482 struct hostent *gethostent();
3483#endif
3484 struct hostent *hent;
3485 unsigned long len;
3486
3487 EXTEND(SP, 10);
3488 if (which == OP_GHBYNAME) {
3489 hent = gethostbyname(POPp);
3490 }
3491 else if (which == OP_GHBYADDR) {
3492 int addrtype = POPi;
748a9306 3493 SV *addrsv = POPs;
a0d0e21e 3494 STRLEN addrlen;
748a9306 3495 char *addr = SvPV(addrsv, addrlen);
a0d0e21e
LW		 3496
3497 hent = gethostbyaddr(addr, addrlen, addrtype);
3498 }
3499 else
3500#ifdef HAS_GETHOSTENT
3501 hent = gethostent();
3502#else
3503 DIE("gethostent not implemented");
3504#endif
3505
3506#ifdef HOST_NOT_FOUND
3507 if (!hent)
f86702cc 3508 STATUS_NATIVE_SET(h_errno);
a0d0e21e
LW		 3509#endif
3510
3511 if (GIMME != G_ARRAY) {
3512 PUSHs(sv = sv_newmortal());
3513 if (hent) {
3514 if (which == OP_GHBYNAME) {
fd0af264 3515 if (hent->h_addr)
3516 sv_setpvn(sv, hent->h_addr, hent->h_length);
a0d0e21e
LW		 3517 }
3518 else
3519 sv_setpv(sv, (char*)hent->h_name);
3520 }
3521 RETURN;
3522 }
3523
3524 if (hent) {
3525 PUSHs(sv = sv_mortalcopy(&sv_no));
3526 sv_setpv(sv, (char*)hent->h_name);
3527 PUSHs(sv = sv_mortalcopy(&sv_no));
3528 for (elem = hent->h_aliases; elem && *elem; elem++) {
3529 sv_catpv(sv, *elem);
3530 if (elem[1])
3531 sv_catpvn(sv, " ", 1);
3532 }
3533 PUSHs(sv = sv_mortalcopy(&sv_no));
1e422769 3534 sv_setiv(sv, (IV)hent->h_addrtype);
a0d0e21e
LW		 3535 PUSHs(sv = sv_mortalcopy(&sv_no));
3536 len = hent->h_length;
1e422769 3537 sv_setiv(sv, (IV)len);
a0d0e21e
LW		 3538#ifdef h_addr
3539 for (elem = hent->h_addr_list; elem && *elem; elem++) {
3540 XPUSHs(sv = sv_mortalcopy(&sv_no));
3541 sv_setpvn(sv, *elem, len);
3542 }
3543#else
3544 PUSHs(sv = sv_mortalcopy(&sv_no));
fd0af264 3545 if (hent->h_addr)
3546 sv_setpvn(sv, hent->h_addr, len);
a0d0e21e
LW		 3547#endif /* h_addr */
3548 }
3549 RETURN;
3550#else
3551 DIE(no_sock_func, "gethostent");
3552#endif
3553}
3554
3555PP(pp_gnbyname)
3556{
3557#ifdef HAS_SOCKET
3558 return pp_gnetent(ARGS);
3559#else
3560 DIE(no_sock_func, "getnetbyname");
3561#endif
3562}
3563
3564PP(pp_gnbyaddr)
3565{
3566#ifdef HAS_SOCKET
3567 return pp_gnetent(ARGS);
3568#else
3569 DIE(no_sock_func, "getnetbyaddr");
3570#endif
3571}
3572
3573PP(pp_gnetent)
3574{
3575 dSP;
3576#ifdef HAS_SOCKET
3577 I32 which = op->op_type;
3578 register char **elem;
3579 register SV *sv;
3580 struct netent *getnetbyname();
3581 struct netent *getnetbyaddr();
3582 struct netent *getnetent();
3583 struct netent *nent;
3584
3585 if (which == OP_GNBYNAME)
3586 nent = getnetbyname(POPp);
3587 else if (which == OP_GNBYADDR) {
3588 int addrtype = POPi;
3589 unsigned long addr = U_L(POPn);
3590 nent = getnetbyaddr((long)addr, addrtype);
3591 }
3592 else
3593 nent = getnetent();
3594
3595 EXTEND(SP, 4);
3596 if (GIMME != G_ARRAY) {
3597 PUSHs(sv = sv_newmortal());
3598 if (nent) {
3599 if (which == OP_GNBYNAME)
1e422769 3600 sv_setiv(sv, (IV)nent->n_net);
a0d0e21e
LW		 3601 else
3602 sv_setpv(sv, nent->n_name);
3603 }
3604 RETURN;
3605 }
3606
3607 if (nent) {
3608 PUSHs(sv = sv_mortalcopy(&sv_no));
3609 sv_setpv(sv, nent->n_name);
3610 PUSHs(sv = sv_mortalcopy(&sv_no));
3611 for (elem = nent->n_aliases; *elem; elem++) {
3612 sv_catpv(sv, *elem);
3613 if (elem[1])
3614 sv_catpvn(sv, " ", 1);
3615 }
3616 PUSHs(sv = sv_mortalcopy(&sv_no));
1e422769 3617 sv_setiv(sv, (IV)nent->n_addrtype);
a0d0e21e 3618 PUSHs(sv = sv_mortalcopy(&sv_no));
1e422769 3619 sv_setiv(sv, (IV)nent->n_net);
a0d0e21e
LW		 3620 }
3621
3622 RETURN;
3623#else
3624 DIE(no_sock_func, "getnetent");
3625#endif
3626}
3627
3628PP(pp_gpbyname)
3629{
3630#ifdef HAS_SOCKET
3631 return pp_gprotoent(ARGS);
3632#else
3633 DIE(no_sock_func, "getprotobyname");
3634#endif
3635}
3636
3637PP(pp_gpbynumber)
3638{
3639#ifdef HAS_SOCKET
3640 return pp_gprotoent(ARGS);
3641#else
3642 DIE(no_sock_func, "getprotobynumber");
3643#endif
3644}
3645
3646PP(pp_gprotoent)
3647{
3648 dSP;
3649#ifdef HAS_SOCKET
3650 I32 which = op->op_type;
3651 register char **elem;
3652 register SV *sv;
3653 struct protoent *getprotobyname();
3654 struct protoent *getprotobynumber();
3655 struct protoent *getprotoent();
3656 struct protoent *pent;
3657
3658 if (which == OP_GPBYNAME)
3659 pent = getprotobyname(POPp);
3660 else if (which == OP_GPBYNUMBER)
3661 pent = getprotobynumber(POPi);
3662 else
3663 pent = getprotoent();
3664
3665 EXTEND(SP, 3);
3666 if (GIMME != G_ARRAY) {
3667 PUSHs(sv = sv_newmortal());
3668 if (pent) {
3669 if (which == OP_GPBYNAME)
1e422769 3670 sv_setiv(sv, (IV)pent->p_proto);
a0d0e21e
LW		 3671 else
3672 sv_setpv(sv, pent->p_name);
3673 }
3674 RETURN;
3675 }
3676
3677 if (pent) {
3678 PUSHs(sv = sv_mortalcopy(&sv_no));
3679 sv_setpv(sv, pent->p_name);
3680 PUSHs(sv = sv_mortalcopy(&sv_no));
3681 for (elem = pent->p_aliases; *elem; elem++) {
3682 sv_catpv(sv, *elem);
3683 if (elem[1])
3684 sv_catpvn(sv, " ", 1);
3685 }
3686 PUSHs(sv = sv_mortalcopy(&sv_no));
1e422769 3687 sv_setiv(sv, (IV)pent->p_proto);
a0d0e21e
LW		 3688 }
3689
3690 RETURN;
3691#else
3692 DIE(no_sock_func, "getprotoent");
3693#endif
3694}
3695
3696PP(pp_gsbyname)
3697{
3698#ifdef HAS_SOCKET
3699 return pp_gservent(ARGS);
3700#else
3701 DIE(no_sock_func, "getservbyname");
3702#endif
3703}
3704
3705PP(pp_gsbyport)
3706{
3707#ifdef HAS_SOCKET
3708 return pp_gservent(ARGS);
3709#else
3710 DIE(no_sock_func, "getservbyport");
3711#endif
3712}
3713
3714PP(pp_gservent)
3715{
3716 dSP;
3717#ifdef HAS_SOCKET
3718 I32 which = op->op_type;
3719 register char **elem;
3720 register SV *sv;
3721 struct servent *getservbyname();
3722 struct servent *getservbynumber();
3723 struct servent *getservent();
3724 struct servent *sent;
3725
3726 if (which == OP_GSBYNAME) {
3727 char *proto = POPp;
3728 char *name = POPp;
3729
3730 if (proto && !*proto)
3731 proto = Nullch;
3732
3733 sent = getservbyname(name, proto);
3734 }
3735 else if (which == OP_GSBYPORT) {
3736 char *proto = POPp;
36477c24 3737 unsigned short port = POPu;
a0d0e21e 3738
36477c24 3739#ifdef HAS_HTONS
3740 port = htons(port);
3741#endif
a0d0e21e
LW		 3742 sent = getservbyport(port, proto);
3743 }
3744 else
3745 sent = getservent();
3746
3747 EXTEND(SP, 4);
3748 if (GIMME != G_ARRAY) {
3749 PUSHs(sv = sv_newmortal());
3750 if (sent) {
3751 if (which == OP_GSBYNAME) {
3752#ifdef HAS_NTOHS
1e422769 3753 sv_setiv(sv, (IV)ntohs(sent->s_port));
a0d0e21e 3754#else
1e422769 3755 sv_setiv(sv, (IV)(sent->s_port));
a0d0e21e
LW		 3756#endif
3757 }
3758 else
3759 sv_setpv(sv, sent->s_name);
3760 }
3761 RETURN;
3762 }
3763
3764 if (sent) {
3765 PUSHs(sv = sv_mortalcopy(&sv_no));
3766 sv_setpv(sv, sent->s_name);
3767 PUSHs(sv = sv_mortalcopy(&sv_no));
3768 for (elem = sent->s_aliases; *elem; elem++) {
3769 sv_catpv(sv, *elem);
3770 if (elem[1])
3771 sv_catpvn(sv, " ", 1);
3772 }
3773 PUSHs(sv = sv_mortalcopy(&sv_no));
3774#ifdef HAS_NTOHS
1e422769 3775 sv_setiv(sv, (IV)ntohs(sent->s_port));
a0d0e21e 3776#else
1e422769 3777 sv_setiv(sv, (IV)(sent->s_port));
a0d0e21e
LW		 3778#endif
3779 PUSHs(sv = sv_mortalcopy(&sv_no));
3780 sv_setpv(sv, sent->s_proto);
3781 }
3782
3783 RETURN;
3784#else
3785 DIE(no_sock_func, "getservent");
3786#endif
3787}
3788
3789PP(pp_shostent)
3790{
3791 dSP;
3792#ifdef HAS_SOCKET
3793 sethostent(TOPi);
3794 RETSETYES;
3795#else
3796 DIE(no_sock_func, "sethostent");
3797#endif
3798}
3799
3800PP(pp_snetent)
3801{
3802 dSP;
3803#ifdef HAS_SOCKET
3804 setnetent(TOPi);
3805 RETSETYES;
3806#else
3807 DIE(no_sock_func, "setnetent");
3808#endif
3809}
3810
3811PP(pp_sprotoent)
3812{
3813 dSP;
3814#ifdef HAS_SOCKET
3815 setprotoent(TOPi);
3816 RETSETYES;
3817#else
3818 DIE(no_sock_func, "setprotoent");
3819#endif
3820}
3821
3822PP(pp_sservent)
3823{
3824 dSP;
3825#ifdef HAS_SOCKET
3826 setservent(TOPi);
3827 RETSETYES;
3828#else
3829 DIE(no_sock_func, "setservent");
3830#endif
3831}
3832
3833PP(pp_ehostent)
3834{
3835 dSP;
3836#ifdef HAS_SOCKET
3837 endhostent();
3838 EXTEND(sp,1);
3839 RETPUSHYES;
3840#else
3841 DIE(no_sock_func, "endhostent");
3842#endif
3843}
3844
3845PP(pp_enetent)
3846{
3847 dSP;
3848#ifdef HAS_SOCKET
3849 endnetent();
3850 EXTEND(sp,1);
3851 RETPUSHYES;
3852#else
3853 DIE(no_sock_func, "endnetent");
3854#endif
3855}
3856
3857PP(pp_eprotoent)
3858{
3859 dSP;
3860#ifdef HAS_SOCKET
3861 endprotoent();
3862 EXTEND(sp,1);
3863 RETPUSHYES;
3864#else
3865 DIE(no_sock_func, "endprotoent");
3866#endif
3867}
3868
3869PP(pp_eservent)
3870{
3871 dSP;
3872#ifdef HAS_SOCKET
3873 endservent();
3874 EXTEND(sp,1);
3875 RETPUSHYES;
3876#else
3877 DIE(no_sock_func, "endservent");
3878#endif
3879}
3880
3881PP(pp_gpwnam)
3882{
3883#ifdef HAS_PASSWD
3884 return pp_gpwent(ARGS);
3885#else
3886 DIE(no_func, "getpwnam");
3887#endif
3888}
3889
3890PP(pp_gpwuid)
3891{
3892#ifdef HAS_PASSWD
3893 return pp_gpwent(ARGS);
3894#else
3895 DIE(no_func, "getpwuid");
3896#endif
3897}
3898
3899PP(pp_gpwent)
3900{
3901 dSP;
3902#ifdef HAS_PASSWD
3903 I32 which = op->op_type;
3904 register SV *sv;
3905 struct passwd *pwent;
3906
3907 if (which == OP_GPWNAM)
3908 pwent = getpwnam(POPp);
3909 else if (which == OP_GPWUID)
3910 pwent = getpwuid(POPi);
3911 else
3912 pwent = (struct passwd *)getpwent();
3913
3914 EXTEND(SP, 10);
3915 if (GIMME != G_ARRAY) {
3916 PUSHs(sv = sv_newmortal());
3917 if (pwent) {
3918 if (which == OP_GPWNAM)
1e422769 3919 sv_setiv(sv, (IV)pwent->pw_uid);
a0d0e21e
LW		 3920 else
3921 sv_setpv(sv, pwent->pw_name);
3922 }
3923 RETURN;
3924 }
3925
3926 if (pwent) {
3927 PUSHs(sv = sv_mortalcopy(&sv_no));
3928 sv_setpv(sv, pwent->pw_name);
3929 PUSHs(sv = sv_mortalcopy(&sv_no));
3930 sv_setpv(sv, pwent->pw_passwd);
3931 PUSHs(sv = sv_mortalcopy(&sv_no));
1e422769 3932 sv_setiv(sv, (IV)pwent->pw_uid);
a0d0e21e 3933 PUSHs(sv = sv_mortalcopy(&sv_no));
1e422769 3934 sv_setiv(sv, (IV)pwent->pw_gid);
a0d0e21e
LW		 3935 PUSHs(sv = sv_mortalcopy(&sv_no));
3936#ifdef PWCHANGE
1e422769 3937 sv_setiv(sv, (IV)pwent->pw_change);
a0d0e21e
LW		 3938#else
3939#ifdef PWQUOTA
1e422769 3940 sv_setiv(sv, (IV)pwent->pw_quota);
a0d0e21e
LW		 3941#else
3942#ifdef PWAGE
3943 sv_setpv(sv, pwent->pw_age);
3944#endif
3945#endif
3946#endif
3947 PUSHs(sv = sv_mortalcopy(&sv_no));
3948#ifdef PWCLASS
3949 sv_setpv(sv, pwent->pw_class);
3950#else
3951#ifdef PWCOMMENT
3952 sv_setpv(sv, pwent->pw_comment);
3953#endif
3954#endif
3955 PUSHs(sv = sv_mortalcopy(&sv_no));
3956 sv_setpv(sv, pwent->pw_gecos);
3957 PUSHs(sv = sv_mortalcopy(&sv_no));
3958 sv_setpv(sv, pwent->pw_dir);
3959 PUSHs(sv = sv_mortalcopy(&sv_no));
3960 sv_setpv(sv, pwent->pw_shell);
3961#ifdef PWEXPIRE
3962 PUSHs(sv = sv_mortalcopy(&sv_no));
1e422769 3963 sv_setiv(sv, (IV)pwent->pw_expire);
a0d0e21e
LW		 3964#endif
3965 }
3966 RETURN;
3967#else
3968 DIE(no_func, "getpwent");
3969#endif
3970}
3971
3972PP(pp_spwent)
3973{
3974 dSP;
3975#ifdef HAS_PASSWD
3976 setpwent();
3977 RETPUSHYES;
3978#else
3979 DIE(no_func, "setpwent");
3980#endif
3981}
3982
3983PP(pp_epwent)
3984{
3985 dSP;
3986#ifdef HAS_PASSWD
3987 endpwent();
3988 RETPUSHYES;
3989#else
3990 DIE(no_func, "endpwent");
3991#endif
3992}
3993
3994PP(pp_ggrnam)
3995{
3996#ifdef HAS_GROUP
3997 return pp_ggrent(ARGS);
3998#else
3999 DIE(no_func, "getgrnam");
4000#endif
4001}
4002
4003PP(pp_ggrgid)
4004{
4005#ifdef HAS_GROUP
4006 return pp_ggrent(ARGS);
4007#else
4008 DIE(no_func, "getgrgid");
4009#endif
4010}
4011
4012PP(pp_ggrent)
4013{
4014 dSP;
4015#ifdef HAS_GROUP
4016 I32 which = op->op_type;
4017 register char **elem;
4018 register SV *sv;
4019 struct group *grent;
4020
4021 if (which == OP_GGRNAM)
4022 grent = (struct group *)getgrnam(POPp);
4023 else if (which == OP_GGRGID)
4024 grent = (struct group *)getgrgid(POPi);
4025 else
4026 grent = (struct group *)getgrent();
4027
4028 EXTEND(SP, 4);
4029 if (GIMME != G_ARRAY) {
4030 PUSHs(sv = sv_newmortal());
4031 if (grent) {
4032 if (which == OP_GGRNAM)
1e422769 4033 sv_setiv(sv, (IV)grent->gr_gid);
a0d0e21e
LW		 4034 else
4035 sv_setpv(sv, grent->gr_name);
4036 }
4037 RETURN;
4038 }
4039
4040 if (grent) {
4041 PUSHs(sv = sv_mortalcopy(&sv_no));
4042 sv_setpv(sv, grent->gr_name);
4043 PUSHs(sv = sv_mortalcopy(&sv_no));
4044 sv_setpv(sv, grent->gr_passwd);
4045 PUSHs(sv = sv_mortalcopy(&sv_no));
1e422769 4046 sv_setiv(sv, (IV)grent->gr_gid);
a0d0e21e
LW		 4047 PUSHs(sv = sv_mortalcopy(&sv_no));
4048 for (elem = grent->gr_mem; *elem; elem++) {
4049 sv_catpv(sv, *elem);
4050 if (elem[1])
4051 sv_catpvn(sv, " ", 1);
4052 }
4053 }
4054
4055 RETURN;
4056#else
4057 DIE(no_func, "getgrent");
4058#endif
4059}
4060
4061PP(pp_sgrent)
4062{
4063 dSP;
4064#ifdef HAS_GROUP
4065 setgrent();
4066 RETPUSHYES;
4067#else
4068 DIE(no_func, "setgrent");
4069#endif
4070}
4071
4072PP(pp_egrent)
4073{
4074 dSP;
4075#ifdef HAS_GROUP
4076 endgrent();
4077 RETPUSHYES;
4078#else
4079 DIE(no_func, "endgrent");
4080#endif
4081}
4082
4083PP(pp_getlogin)
4084{
4085 dSP; dTARGET;
4086#ifdef HAS_GETLOGIN
4087 char *tmps;
4088 EXTEND(SP, 1);
4089 if (!(tmps = getlogin()))
4090 RETPUSHUNDEF;
4091 PUSHp(tmps, strlen(tmps));
4092 RETURN;
4093#else
4094 DIE(no_func, "getlogin");
4095#endif
4096}
4097
4098/* Miscellaneous. */
4099
4100PP(pp_syscall)
4101{
4102#ifdef HAS_SYSCALL
4103 dSP; dMARK; dORIGMARK; dTARGET;
4104 register I32 items = SP - MARK;
4105 unsigned long a[20];
4106 register I32 i = 0;
4107 I32 retval = -1;
748a9306 4108 MAGIC *mg;
a0d0e21e
LW		 4109
4110 if (tainting) {
4111 while (++MARK <= SP) {
bbce6d69 4112 if (SvTAINTED(*MARK)) {
4113 TAINT;
4114 break;
4115 }
a0d0e21e
LW		 4116 }
4117 MARK = ORIGMARK;
4118 TAINT_PROPER("syscall");
4119 }
4120
4121 /* This probably won't work on machines where sizeof(long) != sizeof(int)
4122 * or where sizeof(long) != sizeof(char*). But such machines will
4123 * not likely have syscall implemented either, so who cares?
4124 */
4125 while (++MARK <= SP) {
4126 if (SvNIOK(*MARK) || !i)
4127 a[i++] = SvIV(*MARK);
748a9306
LW		 4128 else if (*MARK == &sv_undef)
4129 a[i++] = 0;
4130 else
4131 a[i++] = (unsigned long)SvPV_force(*MARK, na);
a0d0e21e
LW		 4132 if (i > 15)
4133 break;
4134 }
4135 switch (items) {
4136 default:
4137 DIE("Too many args to syscall");
4138 case 0:
4139 DIE("Too few args to syscall");
4140 case 1:
4141 retval = syscall(a[0]);
4142 break;
4143 case 2:
4144 retval = syscall(a[0],a[1]);
4145 break;
4146 case 3:
4147 retval = syscall(a[0],a[1],a[2]);
4148 break;
4149 case 4:
4150 retval = syscall(a[0],a[1],a[2],a[3]);
4151 break;
4152 case 5:
4153 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
4154 break;
4155 case 6:
4156 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
4157 break;
4158 case 7:
4159 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
4160 break;
4161 case 8:
4162 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
4163 break;
4164#ifdef atarist
4165 case 9:
4166 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
4167 break;
4168 case 10:
4169 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
4170 break;
4171 case 11:
4172 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
4173 a[10]);
4174 break;
4175 case 12:
4176 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
4177 a[10],a[11]);
4178 break;
4179 case 13:
4180 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
4181 a[10],a[11],a[12]);
4182 break;
4183 case 14:
4184 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
4185 a[10],a[11],a[12],a[13]);
4186 break;
4187#endif /* atarist */
4188 }
4189 SP = ORIGMARK;
4190 PUSHi(retval);
4191 RETURN;
4192#else
4193 DIE(no_func, "syscall");
4194#endif
4195}
4196
ff68c719 4197#ifdef FCNTL_EMULATE_FLOCK
4198
4199/* XXX Emulate flock() with fcntl().
4200 What's really needed is a good file locking module.
4201*/
4202
4203static int
4204fcntl_emulate_flock(fd, operation)
4205int fd;
4206int operation;
4207{
4208 struct flock flock;
4209
4210 switch (operation & ~LOCK_NB) {
4211 case LOCK_SH:
4212 flock.l_type = F_RDLCK;
4213 break;
4214 case LOCK_EX:
4215 flock.l_type = F_WRLCK;
4216 break;
4217 case LOCK_UN:
4218 flock.l_type = F_UNLCK;
4219 break;
4220 default:
4221 errno = EINVAL;
4222 return -1;
4223 }
4224 flock.l_whence = SEEK_SET;
4225 flock.l_start = flock.l_len = 0L;
4226
4227 return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
4228}
4229
4230#endif /* FCNTL_EMULATE_FLOCK */
4231
4232#ifdef LOCKF_EMULATE_FLOCK
16d20bd9
AD		 4233
4234/* XXX Emulate flock() with lockf(). This is just to increase
4235 portability of scripts. The calls are not completely
4236 interchangeable. What's really needed is a good file
4237 locking module.
4238*/
4239
76c32331 4240/* The lockf() constants might have been defined in <unistd.h>.
4241 Unfortunately, <unistd.h> causes troubles on some mixed
4242 (BSD/POSIX) systems, such as SunOS 4.1.3.
16d20bd9
AD		 4243
4244 Further, the lockf() constants aren't POSIX, so they might not be
4245 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
4246 just stick in the SVID values and be done with it. Sigh.
4247*/
4248
4249# ifndef F_ULOCK
4250# define F_ULOCK 0 /* Unlock a previously locked region */
4251# endif
4252# ifndef F_LOCK
4253# define F_LOCK 1 /* Lock a region for exclusive use */
4254# endif
4255# ifndef F_TLOCK
4256# define F_TLOCK 2 /* Test and lock a region for exclusive use */
4257# endif
4258# ifndef F_TEST
4259# define F_TEST 3 /* Test a region for other processes locks */
4260# endif
4261
55497cff 4262static int
16d20bd9
AD		 4263lockf_emulate_flock (fd, operation)
4264int fd;
4265int operation;
4266{
4267 int i;
4268 switch (operation) {
4269
4270 /* LOCK_SH - get a shared lock */
4271 case LOCK_SH:
4272 /* LOCK_EX - get an exclusive lock */
4273 case LOCK_EX:
4274 i = lockf (fd, F_LOCK, 0);
4275 break;
4276
4277 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
4278 case LOCK_SH|LOCK_NB:
4279 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
4280 case LOCK_EX|LOCK_NB:
4281 i = lockf (fd, F_TLOCK, 0);
4282 if (i == -1)
4283 if ((errno == EAGAIN) || (errno == EACCES))
4284 errno = EWOULDBLOCK;
4285 break;
4286
ff68c719 4287 /* LOCK_UN - unlock (non-blocking is a no-op) */
16d20bd9 4288 case LOCK_UN:
ff68c719 4289 case LOCK_UN|LOCK_NB:
16d20bd9
AD		 4290 i = lockf (fd, F_ULOCK, 0);
4291 break;
4292
4293 /* Default - can't decipher operation */
4294 default:
4295 i = -1;
4296 errno = EINVAL;
4297 break;
4298 }
4299 return (i);
4300}
ff68c719 4301
4302#endif /* LOCKF_EMULATE_FLOCK */
Unnamed repository; edit this file 'description' to name the repository.