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