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