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