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