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