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