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