This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
another platform where pp_sselect() needs a whole fd_set buffer
[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);
36477c24 385 if (do_open(gv, tmps, len, FALSE, 0, 0, Nullfp))
3280af22
NIS
386 PUSHi( (I32)PL_forkprocess );
387 else if (PL_forkprocess == 0) /* we are a new child */
a0d0e21e
LW
388 PUSHi(0);
389 else
390 RETPUSHUNDEF;
391 RETURN;
392}
393
394PP(pp_close)
395{
4e35701f 396 djSP;
a0d0e21e 397 GV *gv;
1d603a67 398 MAGIC *mg;
a0d0e21e
LW
399
400 if (MAXARG == 0)
3280af22 401 gv = PL_defoutgv;
a0d0e21e
LW
402 else
403 gv = (GV*)POPs;
1d603a67
GB
404
405 if (SvRMAGICAL(gv) && (mg = mg_find((SV*)gv, 'q'))) {
406 PUSHMARK(SP);
407 XPUSHs(mg->mg_obj);
408 PUTBACK;
409 ENTER;
410 perl_call_method("CLOSE", G_SCALAR);
411 LEAVE;
412 SPAGAIN;
413 RETURN;
414 }
a0d0e21e 415 EXTEND(SP, 1);
54310121 416 PUSHs(boolSV(do_close(gv, TRUE)));
a0d0e21e
LW
417 RETURN;
418}
419
420PP(pp_pipe_op)
421{
4e35701f 422 djSP;
a0d0e21e
LW
423#ifdef HAS_PIPE
424 GV *rgv;
425 GV *wgv;
426 register IO *rstio;
427 register IO *wstio;
428 int fd[2];
429
430 wgv = (GV*)POPs;
431 rgv = (GV*)POPs;
432
433 if (!rgv || !wgv)
434 goto badexit;
435
4633a7c4
LW
436 if (SvTYPE(rgv) != SVt_PVGV || SvTYPE(wgv) != SVt_PVGV)
437 DIE(no_usym, "filehandle");
a0d0e21e
LW
438 rstio = GvIOn(rgv);
439 wstio = GvIOn(wgv);
440
441 if (IoIFP(rstio))
442 do_close(rgv, FALSE);
443 if (IoIFP(wstio))
444 do_close(wgv, FALSE);
445
6ad3d225 446 if (PerlProc_pipe(fd) < 0)
a0d0e21e
LW
447 goto badexit;
448
760ac839
LW
449 IoIFP(rstio) = PerlIO_fdopen(fd[0], "r");
450 IoOFP(wstio) = PerlIO_fdopen(fd[1], "w");
a0d0e21e
LW
451 IoIFP(wstio) = IoOFP(wstio);
452 IoTYPE(rstio) = '<';
453 IoTYPE(wstio) = '>';
454
455 if (!IoIFP(rstio) || !IoOFP(wstio)) {
760ac839 456 if (IoIFP(rstio)) PerlIO_close(IoIFP(rstio));
6ad3d225 457 else PerlLIO_close(fd[0]);
760ac839 458 if (IoOFP(wstio)) PerlIO_close(IoOFP(wstio));
6ad3d225 459 else PerlLIO_close(fd[1]);
a0d0e21e
LW
460 goto badexit;
461 }
462
463 RETPUSHYES;
464
465badexit:
466 RETPUSHUNDEF;
467#else
468 DIE(no_func, "pipe");
469#endif
470}
471
472PP(pp_fileno)
473{
4e35701f 474 djSP; dTARGET;
a0d0e21e
LW
475 GV *gv;
476 IO *io;
760ac839 477 PerlIO *fp;
a0d0e21e
LW
478 if (MAXARG < 1)
479 RETPUSHUNDEF;
480 gv = (GV*)POPs;
481 if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io)))
482 RETPUSHUNDEF;
760ac839 483 PUSHi(PerlIO_fileno(fp));
a0d0e21e
LW
484 RETURN;
485}
486
487PP(pp_umask)
488{
4e35701f 489 djSP; dTARGET;
a0d0e21e
LW
490 int anum;
491
492#ifdef HAS_UMASK
493 if (MAXARG < 1) {
6ad3d225
GS
494 anum = PerlLIO_umask(0);
495 (void)PerlLIO_umask(anum);
a0d0e21e
LW
496 }
497 else
6ad3d225 498 anum = PerlLIO_umask(POPi);
a0d0e21e
LW
499 TAINT_PROPER("umask");
500 XPUSHi(anum);
501#else
eec2d3df
GS
502 /* Only DIE if trying to restrict permissions on `user' (self).
503 * Otherwise it's harmless and more useful to just return undef
504 * since 'group' and 'other' concepts probably don't exist here. */
505 if (MAXARG >= 1 && (POPi & 0700))
506 DIE("umask not implemented");
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 }
2611 else if (*s & 128)
2612 odd++;
2613 else if (*s < 32 &&
2614 *s != '\n' && *s != '\r' && *s != '\b' &&
2615 *s != '\t' && *s != '\f' && *s != 27)
2616 odd++;
2617 }
2618
533c011a 2619 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
a0d0e21e
LW
2620 RETPUSHNO;
2621 else
2622 RETPUSHYES;
2623}
2624
2625PP(pp_ftbinary)
2626{
2627 return pp_fttext(ARGS);
2628}
2629
2630/* File calls. */
2631
2632PP(pp_chdir)
2633{
4e35701f 2634 djSP; dTARGET;
a0d0e21e
LW
2635 char *tmps;
2636 SV **svp;
2637
2638 if (MAXARG < 1)
2639 tmps = Nullch;
2640 else
2641 tmps = POPp;
2642 if (!tmps || !*tmps) {
3280af22 2643 svp = hv_fetch(GvHVn(PL_envgv), "HOME", 4, FALSE);
a0d0e21e 2644 if (svp)
3280af22 2645 tmps = SvPV(*svp, PL_na);
a0d0e21e
LW
2646 }
2647 if (!tmps || !*tmps) {
3280af22 2648 svp = hv_fetch(GvHVn(PL_envgv), "LOGDIR", 6, FALSE);
a0d0e21e 2649 if (svp)
3280af22 2650 tmps = SvPV(*svp, PL_na);
a0d0e21e 2651 }
491527d0
GS
2652#ifdef VMS
2653 if (!tmps || !*tmps) {
6b88bc9c 2654 svp = hv_fetch(GvHVn(PL_envgv), "SYS$LOGIN", 9, FALSE);
491527d0 2655 if (svp)
b28d0864 2656 tmps = SvPV(*svp, PL_na);
491527d0
GS
2657 }
2658#endif
a0d0e21e 2659 TAINT_PROPER("chdir");
6ad3d225 2660 PUSHi( PerlDir_chdir(tmps) >= 0 );
748a9306
LW
2661#ifdef VMS
2662 /* Clear the DEFAULT element of ENV so we'll get the new value
2663 * in the future. */
6b88bc9c 2664 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
748a9306 2665#endif
a0d0e21e
LW
2666 RETURN;
2667}
2668
2669PP(pp_chown)
2670{
4e35701f 2671 djSP; dMARK; dTARGET;
a0d0e21e
LW
2672 I32 value;
2673#ifdef HAS_CHOWN
533c011a 2674 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW
2675 SP = MARK;
2676 PUSHi(value);
2677 RETURN;
2678#else
2679 DIE(no_func, "Unsupported function chown");
2680#endif
2681}
2682
2683PP(pp_chroot)
2684{
4e35701f 2685 djSP; dTARGET;
a0d0e21e
LW
2686 char *tmps;
2687#ifdef HAS_CHROOT
2688 tmps = POPp;
2689 TAINT_PROPER("chroot");
2690 PUSHi( chroot(tmps) >= 0 );
2691 RETURN;
2692#else
2693 DIE(no_func, "chroot");
2694#endif
2695}
2696
2697PP(pp_unlink)
2698{
4e35701f 2699 djSP; dMARK; dTARGET;
a0d0e21e 2700 I32 value;
533c011a 2701 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW
2702 SP = MARK;
2703 PUSHi(value);
2704 RETURN;
2705}
2706
2707PP(pp_chmod)
2708{
4e35701f 2709 djSP; dMARK; dTARGET;
a0d0e21e 2710 I32 value;
533c011a 2711 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW
2712 SP = MARK;
2713 PUSHi(value);
2714 RETURN;
2715}
2716
2717PP(pp_utime)
2718{
4e35701f 2719 djSP; dMARK; dTARGET;
a0d0e21e 2720 I32 value;
533c011a 2721 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW
2722 SP = MARK;
2723 PUSHi(value);
2724 RETURN;
2725}
2726
2727PP(pp_rename)
2728{
4e35701f 2729 djSP; dTARGET;
a0d0e21e
LW
2730 int anum;
2731
2732 char *tmps2 = POPp;
3280af22 2733 char *tmps = SvPV(TOPs, PL_na);
a0d0e21e
LW
2734 TAINT_PROPER("rename");
2735#ifdef HAS_RENAME
baed7233 2736 anum = PerlLIO_rename(tmps, tmps2);
a0d0e21e 2737#else
6b88bc9c 2738 if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
ed969818
WK
2739 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
2740 anum = 1;
2741 else {
6b88bc9c 2742 if (euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
ed969818
WK
2743 (void)UNLINK(tmps2);
2744 if (!(anum = link(tmps, tmps2)))
2745 anum = UNLINK(tmps);
2746 }
a0d0e21e
LW
2747 }
2748#endif
2749 SETi( anum >= 0 );
2750 RETURN;
2751}
2752
2753PP(pp_link)
2754{
4e35701f 2755 djSP; dTARGET;
a0d0e21e
LW
2756#ifdef HAS_LINK
2757 char *tmps2 = POPp;
3280af22 2758 char *tmps = SvPV(TOPs, PL_na);
a0d0e21e
LW
2759 TAINT_PROPER("link");
2760 SETi( link(tmps, tmps2) >= 0 );
2761#else
2762 DIE(no_func, "Unsupported function link");
2763#endif
2764 RETURN;
2765}
2766
2767PP(pp_symlink)
2768{
4e35701f 2769 djSP; dTARGET;
a0d0e21e
LW
2770#ifdef HAS_SYMLINK
2771 char *tmps2 = POPp;
3280af22 2772 char *tmps = SvPV(TOPs, PL_na);
a0d0e21e
LW
2773 TAINT_PROPER("symlink");
2774 SETi( symlink(tmps, tmps2) >= 0 );
2775 RETURN;
2776#else
2777 DIE(no_func, "symlink");
2778#endif
2779}
2780
2781PP(pp_readlink)
2782{
4e35701f 2783 djSP; dTARGET;
a0d0e21e
LW
2784#ifdef HAS_SYMLINK
2785 char *tmps;
46fc3d4c 2786 char buf[MAXPATHLEN];
a0d0e21e 2787 int len;
46fc3d4c 2788
fb73857a
PP
2789#ifndef INCOMPLETE_TAINTS
2790 TAINT;
2791#endif
a0d0e21e
LW
2792 tmps = POPp;
2793 len = readlink(tmps, buf, sizeof buf);
2794 EXTEND(SP, 1);
2795 if (len < 0)
2796 RETPUSHUNDEF;
2797 PUSHp(buf, len);
2798 RETURN;
2799#else
2800 EXTEND(SP, 1);
2801 RETSETUNDEF; /* just pretend it's a normal file */
2802#endif
2803}
2804
2805#if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
2806static int
2807dooneliner(cmd, filename)
2808char *cmd;
2809char *filename;
2810{
1e422769
PP
2811 char *save_filename = filename;
2812 char *cmdline;
2813 char *s;
760ac839 2814 PerlIO *myfp;
1e422769 2815 int anum = 1;
a0d0e21e 2816
1e422769
PP
2817 New(666, cmdline, strlen(cmd) + (strlen(filename) * 2) + 10, char);
2818 strcpy(cmdline, cmd);
2819 strcat(cmdline, " ");
2820 for (s = cmdline + strlen(cmdline); *filename; ) {
a0d0e21e
LW
2821 *s++ = '\\';
2822 *s++ = *filename++;
2823 }
2824 strcpy(s, " 2>&1");
6ad3d225 2825 myfp = PerlProc_popen(cmdline, "r");
1e422769
PP
2826 Safefree(cmdline);
2827
a0d0e21e 2828 if (myfp) {
1e422769 2829 SV *tmpsv = sv_newmortal();
6b88bc9c 2830 /* Need to save/restore 'PL_rs' ?? */
760ac839 2831 s = sv_gets(tmpsv, myfp, 0);
6ad3d225 2832 (void)PerlProc_pclose(myfp);
a0d0e21e 2833 if (s != Nullch) {
1e422769
PP
2834 int e;
2835 for (e = 1;
a0d0e21e 2836#ifdef HAS_SYS_ERRLIST
1e422769
PP
2837 e <= sys_nerr
2838#endif
2839 ; e++)
2840 {
2841 /* you don't see this */
2842 char *errmsg =
2843#ifdef HAS_SYS_ERRLIST
2844 sys_errlist[e]
a0d0e21e 2845#else
1e422769 2846 strerror(e)
a0d0e21e 2847#endif
1e422769
PP
2848 ;
2849 if (!errmsg)
2850 break;
2851 if (instr(s, errmsg)) {
2852 SETERRNO(e,0);
2853 return 0;
2854 }
a0d0e21e 2855 }
748a9306 2856 SETERRNO(0,0);
a0d0e21e
LW
2857#ifndef EACCES
2858#define EACCES EPERM
2859#endif
1e422769 2860 if (instr(s, "cannot make"))
748a9306 2861 SETERRNO(EEXIST,RMS$_FEX);
1e422769 2862 else if (instr(s, "existing file"))
748a9306 2863 SETERRNO(EEXIST,RMS$_FEX);
1e422769 2864 else if (instr(s, "ile exists"))
748a9306 2865 SETERRNO(EEXIST,RMS$_FEX);
1e422769 2866 else if (instr(s, "non-exist"))
748a9306 2867 SETERRNO(ENOENT,RMS$_FNF);
1e422769 2868 else if (instr(s, "does not exist"))
748a9306 2869 SETERRNO(ENOENT,RMS$_FNF);
1e422769 2870 else if (instr(s, "not empty"))
748a9306 2871 SETERRNO(EBUSY,SS$_DEVOFFLINE);
1e422769 2872 else if (instr(s, "cannot access"))
748a9306 2873 SETERRNO(EACCES,RMS$_PRV);
a0d0e21e 2874 else
748a9306 2875 SETERRNO(EPERM,RMS$_PRV);
a0d0e21e
LW
2876 return 0;
2877 }
2878 else { /* some mkdirs return no failure indication */
6b88bc9c 2879 anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
911d147d 2880 if (PL_op->op_type == OP_RMDIR)
a0d0e21e
LW
2881 anum = !anum;
2882 if (anum)
748a9306 2883 SETERRNO(0,0);
a0d0e21e 2884 else
748a9306 2885 SETERRNO(EACCES,RMS$_PRV); /* a guess */
a0d0e21e
LW
2886 }
2887 return anum;
2888 }
2889 else
2890 return 0;
2891}
2892#endif
2893
2894PP(pp_mkdir)
2895{
4e35701f 2896 djSP; dTARGET;
a0d0e21e
LW
2897 int mode = POPi;
2898#ifndef HAS_MKDIR
2899 int oldumask;
2900#endif
3280af22 2901 char *tmps = SvPV(TOPs, PL_na);
a0d0e21e
LW
2902
2903 TAINT_PROPER("mkdir");
2904#ifdef HAS_MKDIR
6ad3d225 2905 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
a0d0e21e
LW
2906#else
2907 SETi( dooneliner("mkdir", tmps) );
6ad3d225
GS
2908 oldumask = PerlLIO_umask(0);
2909 PerlLIO_umask(oldumask);
2910 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
a0d0e21e
LW
2911#endif
2912 RETURN;
2913}
2914
2915PP(pp_rmdir)
2916{
4e35701f 2917 djSP; dTARGET;
a0d0e21e
LW
2918 char *tmps;
2919
2920 tmps = POPp;
2921 TAINT_PROPER("rmdir");
2922#ifdef HAS_RMDIR
6ad3d225 2923 XPUSHi( PerlDir_rmdir(tmps) >= 0 );
a0d0e21e
LW
2924#else
2925 XPUSHi( dooneliner("rmdir", tmps) );
2926#endif
2927 RETURN;
2928}
2929
2930/* Directory calls. */
2931
2932PP(pp_open_dir)
2933{
4e35701f 2934 djSP;
a0d0e21e
LW
2935#if defined(Direntry_t) && defined(HAS_READDIR)
2936 char *dirname = POPp;
2937 GV *gv = (GV*)POPs;
2938 register IO *io = GvIOn(gv);
2939
2940 if (!io)
2941 goto nope;
2942
2943 if (IoDIRP(io))
6ad3d225
GS
2944 PerlDir_close(IoDIRP(io));
2945 if (!(IoDIRP(io) = PerlDir_open(dirname)))
a0d0e21e
LW
2946 goto nope;
2947
2948 RETPUSHYES;
2949nope:
2950 if (!errno)
748a9306 2951 SETERRNO(EBADF,RMS$_DIR);
a0d0e21e
LW
2952 RETPUSHUNDEF;
2953#else
2954 DIE(no_dir_func, "opendir");
2955#endif
2956}
2957
2958PP(pp_readdir)
2959{
4e35701f 2960 djSP;
a0d0e21e
LW
2961#if defined(Direntry_t) && defined(HAS_READDIR)
2962#ifndef I_DIRENT
2963 Direntry_t *readdir _((DIR *));
2964#endif
2965 register Direntry_t *dp;
2966 GV *gv = (GV*)POPs;
2967 register IO *io = GvIOn(gv);
fb73857a 2968 SV *sv;
a0d0e21e
LW
2969
2970 if (!io || !IoDIRP(io))
2971 goto nope;
2972
2973 if (GIMME == G_ARRAY) {
2974 /*SUPPRESS 560*/
6ad3d225 2975 while (dp = (Direntry_t *)PerlDir_read(IoDIRP(io))) {
a0d0e21e 2976#ifdef DIRNAMLEN
fb73857a 2977 sv = newSVpv(dp->d_name, dp->d_namlen);
a0d0e21e 2978#else
fb73857a
PP
2979 sv = newSVpv(dp->d_name, 0);
2980#endif
2981#ifndef INCOMPLETE_TAINTS
2982 SvTAINTED_on(sv);
a0d0e21e 2983#endif
fb73857a 2984 XPUSHs(sv_2mortal(sv));
a0d0e21e
LW
2985 }
2986 }
2987 else {
6ad3d225 2988 if (!(dp = (Direntry_t *)PerlDir_read(IoDIRP(io))))
a0d0e21e
LW
2989 goto nope;
2990#ifdef DIRNAMLEN
fb73857a 2991 sv = newSVpv(dp->d_name, dp->d_namlen);
a0d0e21e 2992#else
fb73857a 2993 sv = newSVpv(dp->d_name, 0);
a0d0e21e 2994#endif
fb73857a
PP
2995#ifndef INCOMPLETE_TAINTS
2996 SvTAINTED_on(sv);
2997#endif
2998 XPUSHs(sv_2mortal(sv));
a0d0e21e
LW
2999 }
3000 RETURN;
3001
3002nope:
3003 if (!errno)
748a9306 3004 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW
3005 if (GIMME == G_ARRAY)
3006 RETURN;
3007 else
3008 RETPUSHUNDEF;
3009#else
3010 DIE(no_dir_func, "readdir");
3011#endif
3012}
3013
3014PP(pp_telldir)
3015{
4e35701f 3016 djSP; dTARGET;
a0d0e21e 3017#if defined(HAS_TELLDIR) || defined(telldir)
dfe9444c 3018# ifdef NEED_TELLDIR_PROTO /* XXX does _anyone_ need this? --AD 2/20/1998 */
a0d0e21e 3019 long telldir _((DIR *));
dfe9444c 3020# endif
a0d0e21e
LW
3021 GV *gv = (GV*)POPs;
3022 register IO *io = GvIOn(gv);
3023
3024 if (!io || !IoDIRP(io))
3025 goto nope;
3026
6ad3d225 3027 PUSHi( PerlDir_tell(IoDIRP(io)) );
a0d0e21e
LW
3028 RETURN;
3029nope:
3030 if (!errno)
748a9306 3031 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW
3032 RETPUSHUNDEF;
3033#else
3034 DIE(no_dir_func, "telldir");
3035#endif
3036}
3037
3038PP(pp_seekdir)
3039{
4e35701f 3040 djSP;
a0d0e21e
LW
3041#if defined(HAS_SEEKDIR) || defined(seekdir)
3042 long along = POPl;
3043 GV *gv = (GV*)POPs;
3044 register IO *io = GvIOn(gv);
3045
3046 if (!io || !IoDIRP(io))
3047 goto nope;
3048
6ad3d225 3049 (void)PerlDir_seek(IoDIRP(io), along);
a0d0e21e
LW
3050
3051 RETPUSHYES;
3052nope:
3053 if (!errno)
748a9306 3054 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW
3055 RETPUSHUNDEF;
3056#else
3057 DIE(no_dir_func, "seekdir");
3058#endif
3059}
3060
3061PP(pp_rewinddir)
3062{
4e35701f 3063 djSP;
a0d0e21e
LW
3064#if defined(HAS_REWINDDIR) || defined(rewinddir)
3065 GV *gv = (GV*)POPs;
3066 register IO *io = GvIOn(gv);
3067
3068 if (!io || !IoDIRP(io))
3069 goto nope;
3070
6ad3d225 3071 (void)PerlDir_rewind(IoDIRP(io));
a0d0e21e
LW
3072 RETPUSHYES;
3073nope:
3074 if (!errno)
748a9306 3075 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW
3076 RETPUSHUNDEF;
3077#else
3078 DIE(no_dir_func, "rewinddir");
3079#endif
3080}
3081
3082PP(pp_closedir)
3083{
4e35701f 3084 djSP;
a0d0e21e
LW
3085#if defined(Direntry_t) && defined(HAS_READDIR)
3086 GV *gv = (GV*)POPs;
3087 register IO *io = GvIOn(gv);
3088
3089 if (!io || !IoDIRP(io))
3090 goto nope;
3091
3092#ifdef VOID_CLOSEDIR
6ad3d225 3093 PerlDir_close(IoDIRP(io));
a0d0e21e 3094#else
6ad3d225 3095 if (PerlDir_close(IoDIRP(io)) < 0) {
748a9306 3096 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
a0d0e21e 3097 goto nope;
748a9306 3098 }
a0d0e21e
LW
3099#endif
3100 IoDIRP(io) = 0;
3101
3102 RETPUSHYES;
3103nope:
3104 if (!errno)
748a9306 3105 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW
3106 RETPUSHUNDEF;
3107#else
3108 DIE(no_dir_func, "closedir");
3109#endif
3110}
3111
3112/* Process control. */
3113
3114PP(pp_fork)
3115{
44a8e56a 3116#ifdef HAS_FORK
4e35701f 3117 djSP; dTARGET;
a0d0e21e
LW
3118 int childpid;
3119 GV *tmpgv;
3120
3121 EXTEND(SP, 1);
a0d0e21e
LW
3122 childpid = fork();
3123 if (childpid < 0)
3124 RETSETUNDEF;
3125 if (!childpid) {
3126 /*SUPPRESS 560*/
3127 if (tmpgv = gv_fetchpv("$", TRUE, SVt_PV))
1e422769 3128 sv_setiv(GvSV(tmpgv), (IV)getpid());
3280af22 3129 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
a0d0e21e
LW
3130 }
3131 PUSHi(childpid);
3132 RETURN;
3133#else
3134 DIE(no_func, "Unsupported function fork");
3135#endif
3136}
3137
3138PP(pp_wait)
3139{
2d7a9237 3140#if !defined(DOSISH) || defined(OS2) || defined(WIN32)
4e35701f 3141 djSP; dTARGET;
a0d0e21e
LW
3142 int childpid;
3143 int argflags;
a0d0e21e 3144
44a8e56a 3145 childpid = wait4pid(-1, &argflags, 0);
f86702cc 3146 STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
44a8e56a 3147 XPUSHi(childpid);
a0d0e21e
LW
3148 RETURN;
3149#else
3150 DIE(no_func, "Unsupported function wait");
3151#endif
3152}
3153
3154PP(pp_waitpid)
3155{
2d7a9237 3156#if !defined(DOSISH) || defined(OS2) || defined(WIN32)
4e35701f 3157 djSP; dTARGET;
a0d0e21e
LW
3158 int childpid;
3159 int optype;
3160 int argflags;
a0d0e21e 3161
a0d0e21e
LW
3162 optype = POPi;
3163 childpid = TOPi;
3164 childpid = wait4pid(childpid, &argflags, optype);
f86702cc 3165 STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
44a8e56a 3166 SETi(childpid);
a0d0e21e
LW
3167 RETURN;
3168#else
2d7a9237 3169 DIE(no_func, "Unsupported function waitpid");
a0d0e21e
LW
3170#endif
3171}
3172
3173PP(pp_system)
3174{
4e35701f 3175 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW
3176 I32 value;
3177 int childpid;
3178 int result;
3179 int status;
ff68c719 3180 Sigsave_t ihand,qhand; /* place to save signals during system() */
a0d0e21e 3181
a0d0e21e 3182 if (SP - MARK == 1) {
3280af22
NIS
3183 if (PL_tainting) {
3184 char *junk = SvPV(TOPs, PL_na);
a0d0e21e
LW
3185 TAINT_ENV();
3186 TAINT_PROPER("system");
3187 }
3188 }
1e422769 3189#if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2)
a0d0e21e
LW
3190 while ((childpid = vfork()) == -1) {
3191 if (errno != EAGAIN) {
3192 value = -1;
3193 SP = ORIGMARK;
3194 PUSHi(value);
3195 RETURN;
3196 }
3197 sleep(5);
3198 }
3199 if (childpid > 0) {
ff68c719
PP
3200 rsignal_save(SIGINT, SIG_IGN, &ihand);
3201 rsignal_save(SIGQUIT, SIG_IGN, &qhand);
748a9306
LW
3202 do {
3203 result = wait4pid(childpid, &status, 0);
3204 } while (result == -1 && errno == EINTR);
ff68c719
PP
3205 (void)rsignal_restore(SIGINT, &ihand);
3206 (void)rsignal_restore(SIGQUIT, &qhand);
91e9c03f 3207 STATUS_NATIVE_SET(result == -1 ? -1 : status);
a0d0e21e
LW
3208 do_execfree(); /* free any memory child malloced on vfork */
3209 SP = ORIGMARK;
ff0cee69 3210 PUSHi(STATUS_CURRENT);
a0d0e21e
LW
3211 RETURN;
3212 }
533c011a 3213 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e
LW
3214 SV *really = *++MARK;
3215 value = (I32)do_aexec(really, MARK, SP);
3216 }
3217 else if (SP - MARK != 1)
3218 value = (I32)do_aexec(Nullsv, MARK, SP);
3219 else {
3280af22 3220 value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), PL_na));
a0d0e21e 3221 }
6ad3d225 3222 PerlProc__exit(-1);
c3293030 3223#else /* ! FORK or VMS or OS/2 */
911d147d 3224 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e 3225 SV *really = *++MARK;
4e35701f 3226 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
a0d0e21e
LW
3227 }
3228 else if (SP - MARK != 1)
4e35701f 3229 value = (I32)do_aspawn(Nullsv, (void **)MARK, (void **)SP);
a0d0e21e 3230 else {
b28d0864 3231 value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), PL_na));
a0d0e21e 3232 }
f86702cc 3233 STATUS_NATIVE_SET(value);
a0d0e21e
LW
3234 do_execfree();
3235 SP = ORIGMARK;
ff0cee69 3236 PUSHi(STATUS_CURRENT);
a0d0e21e
LW
3237#endif /* !FORK or VMS */
3238 RETURN;
3239}
3240
3241PP(pp_exec)
3242{
4e35701f 3243 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW
3244 I32 value;
3245
533c011a 3246 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e
LW
3247 SV *really = *++MARK;
3248 value = (I32)do_aexec(really, MARK, SP);
3249 }
3250 else if (SP - MARK != 1)
3251#ifdef VMS
3252 value = (I32)vms_do_aexec(Nullsv, MARK, SP);
3253#else
3254 value = (I32)do_aexec(Nullsv, MARK, SP);
3255#endif
3256 else {
3280af22
NIS
3257 if (PL_tainting) {
3258 char *junk = SvPV(*SP, PL_na);
a0d0e21e
LW
3259 TAINT_ENV();
3260 TAINT_PROPER("exec");
3261 }
3262#ifdef VMS
b28d0864 3263 value = (I32)vms_do_exec(SvPVx(sv_mortalcopy(*SP), PL_na));
a0d0e21e 3264#else
3280af22 3265 value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), PL_na));
a0d0e21e
LW
3266#endif
3267 }
3268 SP = ORIGMARK;
3269 PUSHi(value);
3270 RETURN;
3271}
3272
3273PP(pp_kill)
3274{
4e35701f 3275 djSP; dMARK; dTARGET;
a0d0e21e
LW
3276 I32 value;
3277#ifdef HAS_KILL
533c011a 3278 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW
3279 SP = MARK;
3280 PUSHi(value);
3281 RETURN;
3282#else
3283 DIE(no_func, "Unsupported function kill");
3284#endif
3285}
3286
3287PP(pp_getppid)
3288{
3289#ifdef HAS_GETPPID
4e35701f 3290 djSP; dTARGET;
a0d0e21e
LW
3291 XPUSHi( getppid() );
3292 RETURN;
3293#else
3294 DIE(no_func, "getppid");
3295#endif
3296}
3297
3298PP(pp_getpgrp)
3299{
3300#ifdef HAS_GETPGRP
4e35701f 3301 djSP; dTARGET;
a0d0e21e
LW
3302 int pid;
3303 I32 value;
3304
3305 if (MAXARG < 1)
3306 pid = 0;
3307 else
3308 pid = SvIVx(POPs);
c3293030
IZ
3309#ifdef BSD_GETPGRP
3310 value = (I32)BSD_GETPGRP(pid);
a0d0e21e 3311#else
aa689395 3312 if (pid != 0 && pid != getpid())
a0d0e21e
LW
3313 DIE("POSIX getpgrp can't take an argument");
3314 value = (I32)getpgrp();
3315#endif
3316 XPUSHi(value);
3317 RETURN;
3318#else
3319 DIE(no_func, "getpgrp()");
3320#endif
3321}
3322
3323PP(pp_setpgrp)
3324{
3325#ifdef HAS_SETPGRP
4e35701f 3326 djSP; dTARGET;
a0d0e21e
LW
3327 int pgrp;
3328 int pid;
3329 if (MAXARG < 2) {
3330 pgrp = 0;
3331 pid = 0;
3332 }
3333 else {
3334 pgrp = POPi;
3335 pid = TOPi;
3336 }
3337
3338 TAINT_PROPER("setpgrp");
c3293030
IZ
3339#ifdef BSD_SETPGRP
3340 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
a0d0e21e 3341#else
c90c0ff4 3342 if ((pgrp != 0 && pgrp != getpid()) || (pid != 0 && pid != getpid()))
a0d0e21e 3343 DIE("POSIX setpgrp can't take an argument");
a0d0e21e
LW
3344 SETi( setpgrp() >= 0 );
3345#endif /* USE_BSDPGRP */
3346 RETURN;
3347#else
3348 DIE(no_func, "setpgrp()");
3349#endif
3350}
3351
3352PP(pp_getpriority)
3353{
4e35701f 3354 djSP; dTARGET;
a0d0e21e
LW
3355 int which;
3356 int who;
3357#ifdef HAS_GETPRIORITY
3358 who = POPi;
3359 which = TOPi;
3360 SETi( getpriority(which, who) );
3361 RETURN;
3362#else
3363 DIE(no_func, "getpriority()");
3364#endif
3365}
3366
3367PP(pp_setpriority)
3368{
4e35701f 3369 djSP; dTARGET;
a0d0e21e
LW
3370 int which;
3371 int who;
3372 int niceval;
3373#ifdef HAS_SETPRIORITY
3374 niceval = POPi;
3375 who = POPi;
3376 which = TOPi;
3377 TAINT_PROPER("setpriority");
3378 SETi( setpriority(which, who, niceval) >= 0 );
3379 RETURN;
3380#else
3381 DIE(no_func, "setpriority()");
3382#endif
3383}
3384
3385/* Time calls. */
3386
3387PP(pp_time)
3388{
4e35701f 3389 djSP; dTARGET;
cbdc8872
PP
3390#ifdef BIG_TIME
3391 XPUSHn( time(Null(Time_t*)) );
3392#else
a0d0e21e 3393 XPUSHi( time(Null(Time_t*)) );
cbdc8872 3394#endif
a0d0e21e
LW
3395 RETURN;
3396}
3397
cd52b7b2
PP
3398/* XXX The POSIX name is CLK_TCK; it is to be preferred
3399 to HZ. Probably. For now, assume that if the system
3400 defines HZ, it does so correctly. (Will this break
3401 on VMS?)
3402 Probably we ought to use _sysconf(_SC_CLK_TCK), if
3403 it's supported. --AD 9/96.
3404*/
3405
a0d0e21e 3406#ifndef HZ
cd52b7b2
PP
3407# ifdef CLK_TCK
3408# define HZ CLK_TCK
3409# else
3410# define HZ 60
3411# endif
a0d0e21e
LW
3412#endif
3413
3414PP(pp_tms)
3415{
4e35701f 3416 djSP;
a0d0e21e 3417
55497cff 3418#ifndef HAS_TIMES
a0d0e21e
LW
3419 DIE("times not implemented");
3420#else
3421 EXTEND(SP, 4);
3422
3423#ifndef VMS
3280af22 3424 (void)PerlProc_times(&PL_timesbuf);
a0d0e21e 3425#else
6b88bc9c 3426 (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */
76e3520e
GS
3427 /* struct tms, though same data */
3428 /* is returned. */
a0d0e21e
LW
3429#endif
3430
3280af22 3431 PUSHs(sv_2mortal(newSVnv(((double)PL_timesbuf.tms_utime)/HZ)));
a0d0e21e 3432 if (GIMME == G_ARRAY) {
3280af22
NIS
3433 PUSHs(sv_2mortal(newSVnv(((double)PL_timesbuf.tms_stime)/HZ)));
3434 PUSHs(sv_2mortal(newSVnv(((double)PL_timesbuf.tms_cutime)/HZ)));
3435 PUSHs(sv_2mortal(newSVnv(((double)PL_timesbuf.tms_cstime)/HZ)));
a0d0e21e
LW
3436 }
3437 RETURN;
55497cff 3438#endif /* HAS_TIMES */
a0d0e21e
LW
3439}
3440
3441PP(pp_localtime)
3442{
3443 return pp_gmtime(ARGS);
3444}
3445
3446PP(pp_gmtime)
3447{
4e35701f 3448 djSP;
a0d0e21e
LW
3449 Time_t when;
3450 struct tm *tmbuf;
3451 static char *dayname[] = {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
3452 static char *monname[] = {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
3453 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
3454
3455 if (MAXARG < 1)
3456 (void)time(&when);
3457 else
cbdc8872
PP
3458#ifdef BIG_TIME
3459 when = (Time_t)SvNVx(POPs);
3460#else
a0d0e21e 3461 when = (Time_t)SvIVx(POPs);
cbdc8872 3462#endif
a0d0e21e 3463
533c011a 3464 if (PL_op->op_type == OP_LOCALTIME)
a0d0e21e
LW
3465 tmbuf = localtime(&when);
3466 else
3467 tmbuf = gmtime(&when);
3468
3469 EXTEND(SP, 9);
bbce6d69 3470 EXTEND_MORTAL(9);
a0d0e21e
LW
3471 if (GIMME != G_ARRAY) {
3472 dTARGET;
46fc3d4c 3473 SV *tsv;
a0d0e21e
LW
3474 if (!tmbuf)
3475 RETPUSHUNDEF;
46fc3d4c
PP
3476 tsv = newSVpvf("%s %s %2d %02d:%02d:%02d %d",
3477 dayname[tmbuf->tm_wday],
3478 monname[tmbuf->tm_mon],
3479 tmbuf->tm_mday,
3480 tmbuf->tm_hour,
3481 tmbuf->tm_min,
3482 tmbuf->tm_sec,
3483 tmbuf->tm_year + 1900);
3484 PUSHs(sv_2mortal(tsv));
a0d0e21e
LW
3485 }
3486 else if (tmbuf) {
3487 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_sec)));
3488 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_min)));
3489 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_hour)));
3490 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_mday)));
3491 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_mon)));
3492 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_year)));
3493 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_wday)));
3494 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_yday)));
3495 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_isdst)));
3496 }
3497 RETURN;
3498}
3499
3500PP(pp_alarm)
3501{
4e35701f 3502 djSP; dTARGET;
a0d0e21e
LW
3503 int anum;
3504#ifdef HAS_ALARM
3505 anum = POPi;
3506 anum = alarm((unsigned int)anum);
3507 EXTEND(SP, 1);
3508 if (anum < 0)
3509 RETPUSHUNDEF;
3510 PUSHi((I32)anum);
3511 RETURN;
3512#else
3513 DIE(no_func, "Unsupported function alarm");
a0d0e21e
LW
3514#endif
3515}
3516
3517PP(pp_sleep)
3518{
4e35701f 3519 djSP; dTARGET;
a0d0e21e
LW
3520 I32 duration;
3521 Time_t lasttime;
3522 Time_t when;
3523
3524 (void)time(&lasttime);
3525 if (MAXARG < 1)
76e3520e 3526 PerlProc_pause();
a0d0e21e
LW
3527 else {
3528 duration = POPi;
76e3520e 3529 PerlProc_sleep((unsigned int)duration);
a0d0e21e
LW
3530 }
3531 (void)time(&when);
3532 XPUSHi(when - lasttime);
3533 RETURN;
3534}
3535
3536/* Shared memory. */
3537
3538PP(pp_shmget)
3539{
3540 return pp_semget(ARGS);
3541}
3542
3543PP(pp_shmctl)
3544{
3545 return pp_semctl(ARGS);
3546}
3547
3548PP(pp_shmread)
3549{
3550 return pp_shmwrite(ARGS);
3551}
3552
3553PP(pp_shmwrite)
3554{
3555#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 3556 djSP; dMARK; dTARGET;
533c011a 3557 I32 value = (I32)(do_shmio(PL_op->op_type, MARK, SP) >= 0);
a0d0e21e
LW
3558 SP = MARK;
3559 PUSHi(value);
3560 RETURN;
3561#else
748a9306 3562 return pp_semget(ARGS);
a0d0e21e
LW
3563#endif
3564}
3565
3566/* Message passing. */
3567
3568PP(pp_msgget)
3569{
3570 return pp_semget(ARGS);
3571}
3572
3573PP(pp_msgctl)
3574{
3575 return pp_semctl(ARGS);
3576}
3577
3578PP(pp_msgsnd)
3579{
3580#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 3581 djSP; dMARK; dTARGET;
a0d0e21e
LW
3582 I32 value = (I32)(do_msgsnd(MARK, SP) >= 0);
3583 SP = MARK;
3584 PUSHi(value);
3585 RETURN;
3586#else
748a9306 3587 return pp_semget(ARGS);
a0d0e21e
LW
3588#endif
3589}
3590
3591PP(pp_msgrcv)
3592{
3593#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 3594 djSP; dMARK; dTARGET;
a0d0e21e
LW
3595 I32 value = (I32)(do_msgrcv(MARK, SP) >= 0);
3596 SP = MARK;
3597 PUSHi(value);
3598 RETURN;
3599#else
748a9306 3600 return pp_semget(ARGS);
a0d0e21e
LW
3601#endif
3602}
3603
3604/* Semaphores. */
3605
3606PP(pp_semget)
3607{
3608#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 3609 djSP; dMARK; dTARGET;
533c011a 3610 int anum = do_ipcget(PL_op->op_type, MARK, SP);
a0d0e21e
LW
3611 SP = MARK;
3612 if (anum == -1)
3613 RETPUSHUNDEF;
3614 PUSHi(anum);
3615 RETURN;
3616#else
3617 DIE("System V IPC is not implemented on this machine");
3618#endif
3619}
3620
3621PP(pp_semctl)
3622{
3623#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 3624 djSP; dMARK; dTARGET;
533c011a 3625 int anum = do_ipcctl(PL_op->op_type, MARK, SP);
a0d0e21e
LW
3626 SP = MARK;
3627 if (anum == -1)
3628 RETSETUNDEF;
3629 if (anum != 0) {
3630 PUSHi(anum);
3631 }
3632 else {
8903cb82 3633 PUSHp(zero_but_true, ZBTLEN);
a0d0e21e
LW
3634 }
3635 RETURN;
3636#else
748a9306 3637 return pp_semget(ARGS);
a0d0e21e
LW
3638#endif
3639}
3640
3641PP(pp_semop)
3642{
3643#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 3644 djSP; dMARK; dTARGET;
a0d0e21e
LW
3645 I32 value = (I32)(do_semop(MARK, SP) >= 0);
3646 SP = MARK;
3647 PUSHi(value);
3648 RETURN;
3649#else
748a9306 3650 return pp_semget(ARGS);
a0d0e21e
LW
3651#endif
3652}
3653
3654/* Get system info. */
3655
3656PP(pp_ghbyname)
3657{
693762b4 3658#ifdef HAS_GETHOSTBYNAME
a0d0e21e
LW
3659 return pp_ghostent(ARGS);
3660#else
3661 DIE(no_sock_func, "gethostbyname");
3662#endif
3663}
3664
3665PP(pp_ghbyaddr)
3666{
693762b4 3667#ifdef HAS_GETHOSTBYADDR
a0d0e21e
LW
3668 return pp_ghostent(ARGS);
3669#else
3670 DIE(no_sock_func, "gethostbyaddr");
3671#endif
3672}
3673
3674PP(pp_ghostent)
3675{
4e35701f 3676 djSP;
693762b4 3677#if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
533c011a 3678 I32 which = PL_op->op_type;
a0d0e21e
LW
3679 register char **elem;
3680 register SV *sv;
dc45a647 3681#ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4599a1de
JH
3682 struct hostent *PerlSock_gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
3683 struct hostent *PerlSock_gethostbyname(Netdb_name_t);
6ad3d225 3684 struct hostent *PerlSock_gethostent(void);
a0d0e21e
LW
3685#endif
3686 struct hostent *hent;
3687 unsigned long len;
3688
3689 EXTEND(SP, 10);
dc45a647
MB
3690 if (which == OP_GHBYNAME)
3691#ifdef HAS_GETHOSTBYNAME
6ad3d225 3692 hent = PerlSock_gethostbyname(POPp);
dc45a647
MB
3693#else
3694 DIE(no_sock_func, "gethostbyname");
3695#endif
a0d0e21e 3696 else if (which == OP_GHBYADDR) {
dc45a647 3697#ifdef HAS_GETHOSTBYADDR
a0d0e21e 3698 int addrtype = POPi;
748a9306 3699 SV *addrsv = POPs;
a0d0e21e 3700 STRLEN addrlen;
4599a1de 3701 Netdb_host_t addr = (Netdb_host_t) SvPV(addrsv, addrlen);
a0d0e21e 3702
4599a1de 3703 hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
dc45a647
MB
3704#else
3705 DIE(no_sock_func, "gethostbyaddr");
3706#endif
a0d0e21e
LW
3707 }
3708 else
3709#ifdef HAS_GETHOSTENT
6ad3d225 3710 hent = PerlSock_gethostent();
a0d0e21e 3711#else
dc45a647 3712 DIE(no_sock_func, "gethostent");
a0d0e21e
LW
3713#endif
3714
3715#ifdef HOST_NOT_FOUND
3716 if (!hent)
f86702cc 3717 STATUS_NATIVE_SET(h_errno);
a0d0e21e
LW
3718#endif
3719
3720 if (GIMME != G_ARRAY) {
3721 PUSHs(sv = sv_newmortal());
3722 if (hent) {
3723 if (which == OP_GHBYNAME) {
fd0af264
PP
3724 if (hent->h_addr)
3725 sv_setpvn(sv, hent->h_addr, hent->h_length);
a0d0e21e
LW
3726 }
3727 else
3728 sv_setpv(sv, (char*)hent->h_name);
3729 }
3730 RETURN;
3731 }
3732
3733 if (hent) {
3280af22 3734 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 3735 sv_setpv(sv, (char*)hent->h_name);
3280af22 3736 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW
3737 for (elem = hent->h_aliases; elem && *elem; elem++) {
3738 sv_catpv(sv, *elem);
3739 if (elem[1])
3740 sv_catpvn(sv, " ", 1);
3741 }
3280af22 3742 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 3743 sv_setiv(sv, (IV)hent->h_addrtype);
3280af22 3744 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 3745 len = hent->h_length;
1e422769 3746 sv_setiv(sv, (IV)len);
a0d0e21e
LW
3747#ifdef h_addr
3748 for (elem = hent->h_addr_list; elem && *elem; elem++) {
3280af22 3749 XPUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW
3750 sv_setpvn(sv, *elem, len);
3751 }
3752#else
6b88bc9c 3753 PUSHs(sv = sv_mortalcopy(&PL_sv_no));