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