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