This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
[win32] Fix typo: s/GETNETBYADD\b/GETNETBYADDR/
[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 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 31#ifdef I_SYS_WAIT
32# include <sys/wait.h>
33#endif
34
35#ifdef I_SYS_RESOURCE
36# include <sys/resource.h>
16d20bd9 37#endif
a0d0e21e
LW		 38
39#if defined(HAS_SOCKET) && !defined(VMS) /* VMS handles sockets via vmsish.h */
40# include <sys/socket.h>
3fd537d4
JH		 41# ifdef I_NETDB
42# include <netdb.h>
43# endif
a0d0e21e
LW		 44# ifndef ENOTSOCK
45# ifdef I_NET_ERRNO
46# include <net/errno.h>
47# endif
48# endif
49#endif
50
51#ifdef HAS_SELECT
52#ifdef I_SYS_SELECT
a0d0e21e
LW		 53#include <sys/select.h>
54#endif
55#endif
a0d0e21e
LW		 56
57#ifdef HOST_NOT_FOUND
58extern int h_errno;
59#endif
60
61#ifdef HAS_PASSWD
62# ifdef I_PWD
63# include <pwd.h>
64# else
65 struct passwd *getpwnam _((char *));
66 struct passwd *getpwuid _((Uid_t));
67# endif
68 struct passwd *getpwent _((void));
69#endif
70
71#ifdef HAS_GROUP
72# ifdef I_GRP
73# include <grp.h>
74# else
75 struct group *getgrnam _((char *));
76 struct group *getgrgid _((Gid_t));
77# endif
78 struct group *getgrent _((void));
79#endif
80
81#ifdef I_UTIME
3e3baf6d 82# ifdef _MSC_VER
3fe9a6f1 83# include <sys/utime.h>
84# else
85# include <utime.h>
86# endif
a0d0e21e
LW		 87#endif
88#ifdef I_FCNTL
89#include <fcntl.h>
90#endif
91#ifdef I_SYS_FILE
92#include <sys/file.h>
93#endif
94
54310121 95/* Put this after #includes because fork and vfork prototypes may conflict. */
96#ifndef HAS_VFORK
97# define vfork fork
98#endif
99
d574b85e
CS		 100/* Put this after #includes because <unistd.h> defines _XOPEN_*. */
101#ifndef Sock_size_t
137443ea 102# if _XOPEN_VERSION >= 5 || defined(_XOPEN_SOURCE_EXTENDED) || defined(__GLIBC__)
d574b85e
CS		 103# define Sock_size_t Size_t
104# else
105# define Sock_size_t int
106# endif
54310121 107#endif
108
a0d0e21e
LW		 109#if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
110static int dooneliner _((char *cmd, char *filename));
111#endif
cbdc8872 112
113#ifdef HAS_CHSIZE
cd52b7b2 114# ifdef my_chsize /* Probably #defined to Perl_my_chsize in embed.h */
115# undef my_chsize
116# endif
3028581b 117# define my_chsize PerlLIO_chsize
cbdc8872 118#endif
119
ff68c719 120#ifdef HAS_FLOCK
121# define FLOCK flock
122#else /* no flock() */
123
36477c24 124 /* fcntl.h might not have been included, even if it exists, because
125 the current Configure only sets I_FCNTL if it's needed to pick up
126 the *_OK constants. Make sure it has been included before testing
127 the fcntl() locking constants. */
128# if defined(HAS_FCNTL) && !defined(I_FCNTL)
129# include <fcntl.h>
130# endif
131
ff68c719 132# if defined(HAS_FCNTL) && defined(F_SETLK) && defined (F_SETLKW)
133# define FLOCK fcntl_emulate_flock
134# define FCNTL_EMULATE_FLOCK
135# else /* no flock() or fcntl(F_SETLK,...) */
136# ifdef HAS_LOCKF
137# define FLOCK lockf_emulate_flock
138# define LOCKF_EMULATE_FLOCK
139# endif /* lockf */
140# endif /* no flock() or fcntl(F_SETLK,...) */
141
142# ifdef FLOCK
13826f2c 143 static int FLOCK _((int, int));
ff68c719 144
145 /*
146 * These are the flock() constants. Since this sytems doesn't have
147 * flock(), the values of the constants are probably not available.
148 */
149# ifndef LOCK_SH
150# define LOCK_SH 1
151# endif
152# ifndef LOCK_EX
153# define LOCK_EX 2
154# endif
155# ifndef LOCK_NB
156# define LOCK_NB 4
157# endif
158# ifndef LOCK_UN
159# define LOCK_UN 8
160# endif
161# endif /* emulating flock() */
162
163#endif /* no flock() */
55497cff 164
46fc3d4c 165#ifndef MAXPATHLEN
166# ifdef PATH_MAX
167# define MAXPATHLEN PATH_MAX
168# else
169# define MAXPATHLEN 1024
170# endif
171#endif
55497cff 172
8903cb82 173#define ZBTLEN 10
174static char zero_but_true[ZBTLEN + 1] = "0 but true";
175
a0d0e21e
LW		 176/* Pushy I/O. */
177
178PP(pp_backtick)
179{
4e35701f 180 djSP; dTARGET;
760ac839 181 PerlIO *fp;
a0d0e21e 182 char *tmps = POPp;
54310121 183 I32 gimme = GIMME_V;
184
a0d0e21e 185 TAINT_PROPER("``");
3028581b 186 fp = PerlProc_popen(tmps, "r");
a0d0e21e 187 if (fp) {
54310121 188 if (gimme == G_VOID) {
96827780
MB		 189 char tmpbuf[256];
190 while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0)
54310121 191 /*SUPPRESS 530*/
192 ;
193 }
194 else if (gimme == G_SCALAR) {
aa689395 195 sv_setpv(TARG, ""); /* note that this preserves previous buffer */
a0d0e21e
LW		 196 while (sv_gets(TARG, fp, SvCUR(TARG)) != Nullch)
197 /*SUPPRESS 530*/
198 ;
199 XPUSHs(TARG);
aa689395 200 SvTAINTED_on(TARG);
a0d0e21e
LW		 201 }
202 else {
203 SV *sv;
204
205 for (;;) {
206 sv = NEWSV(56, 80);
207 if (sv_gets(sv, fp, 0) == Nullch) {
208 SvREFCNT_dec(sv);
209 break;
210 }
211 XPUSHs(sv_2mortal(sv));
212 if (SvLEN(sv) - SvCUR(sv) > 20) {
213 SvLEN_set(sv, SvCUR(sv)+1);
214 Renew(SvPVX(sv), SvLEN(sv), char);
215 }
aa689395 216 SvTAINTED_on(sv);
a0d0e21e
LW		 217 }
218 }
3028581b 219 STATUS_NATIVE_SET(PerlProc_pclose(fp));
aa689395 220 TAINT; /* "I believe that this is not gratuitous!" */
a0d0e21e
LW		 221 }
222 else {
f86702cc 223 STATUS_NATIVE_SET(-1);
54310121 224 if (gimme == G_SCALAR)
a0d0e21e
LW		 225 RETPUSHUNDEF;
226 }
227
228 RETURN;
229}
230
231PP(pp_glob)
232{
233 OP *result;
234 ENTER;
a0d0e21e 235
c90c0ff4 236#ifndef VMS
7bac28a0 237 if (tainting) {
238 /*
239 * The external globbing program may use things we can't control,
240 * so for security reasons we must assume the worst.
241 */
242 TAINT;
243 taint_proper(no_security, "glob");
244 }
c90c0ff4 245#endif /* !VMS */
7bac28a0 246
a0d0e21e
LW		 247 SAVESPTR(last_in_gv); /* We don't want this to be permanent. */
248 last_in_gv = (GV*)*stack_sp--;
249
c07a80fd 250 SAVESPTR(rs); /* This is not permanent, either. */
251 rs = sv_2mortal(newSVpv("", 1));
252#ifndef DOSISH
253#ifndef CSH
254 *SvPVX(rs) = '\n';
a0d0e21e 255#endif /* !CSH */
55497cff 256#endif /* !DOSISH */
c07a80fd 257
a0d0e21e
LW		 258 result = do_readline();
259 LEAVE;
260 return result;
261}
262
263PP(pp_indread)
264{
265 last_in_gv = gv_fetchpv(SvPVx(GvSV((GV*)(*stack_sp--)), na), TRUE,SVt_PVIO);
266 return do_readline();
267}
268
269PP(pp_rcatline)
270{
271 last_in_gv = cGVOP->op_gv;
272 return do_readline();
273}
274
275PP(pp_warn)
276{
4e35701f 277 djSP; dMARK;
a0d0e21e
LW		 278 char *tmps;
279 if (SP - MARK != 1) {
280 dTARGET;
281 do_join(TARG, &sv_no, MARK, SP);
282 tmps = SvPV(TARG, na);
283 SP = MARK + 1;
284 }
285 else {
286 tmps = SvPV(TOPs, na);
287 }
288 if (!tmps || !*tmps) {
38a03e6e
MB		 289 (void)SvUPGRADE(ERRSV, SVt_PV);
290 if (SvPOK(ERRSV) && SvCUR(ERRSV))
291 sv_catpv(ERRSV, "\t...caught");
292 tmps = SvPV(ERRSV, na);
a0d0e21e
LW		 293 }
294 if (!tmps || !*tmps)
295 tmps = "Warning: something's wrong";
296 warn("%s", tmps);
297 RETSETYES;
298}
299
300PP(pp_die)
301{
4e35701f 302 djSP; dMARK;
a0d0e21e
LW		 303 char *tmps;
304 if (SP - MARK != 1) {
305 dTARGET;
306 do_join(TARG, &sv_no, MARK, SP);
307 tmps = SvPV(TARG, na);
308 SP = MARK + 1;
309 }
310 else {
311 tmps = SvPV(TOPs, na);
312 }
313 if (!tmps || !*tmps) {
38a03e6e
MB		 314 (void)SvUPGRADE(ERRSV, SVt_PV);
315 if (SvPOK(ERRSV) && SvCUR(ERRSV))
316 sv_catpv(ERRSV, "\t...propagated");
317 tmps = SvPV(ERRSV, na);
a0d0e21e
LW		 318 }
319 if (!tmps || !*tmps)
320 tmps = "Died";
321 DIE("%s", tmps);
322}
323
324/* I/O. */
325
326PP(pp_open)
327{
4e35701f 328 djSP; dTARGET;
a0d0e21e
LW		 329 GV *gv;
330 SV *sv;
331 char *tmps;
332 STRLEN len;
333
334 if (MAXARG > 1)
335 sv = POPs;
5f05dabc 336 if (!isGV(TOPs))
4633a7c4 337 DIE(no_usym, "filehandle");
5f05dabc 338 if (MAXARG <= 1)
339 sv = GvSV(TOPs);
a0d0e21e 340 gv = (GV*)POPs;
5f05dabc 341 if (!isGV(gv))
342 DIE(no_usym, "filehandle");
36477c24 343 if (GvIOp(gv))
344 IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
a0d0e21e 345 tmps = SvPV(sv, len);
36477c24 346 if (do_open(gv, tmps, len, FALSE, 0, 0, Nullfp))
a0d0e21e 347 PUSHi( (I32)forkprocess );
a0d0e21e
LW		 348 else if (forkprocess == 0) /* we are a new child */
349 PUSHi(0);
350 else
351 RETPUSHUNDEF;
352 RETURN;
353}
354
355PP(pp_close)
356{
4e35701f 357 djSP;
a0d0e21e
LW		 358 GV *gv;
359
360 if (MAXARG == 0)
361 gv = defoutgv;
362 else
363 gv = (GV*)POPs;
364 EXTEND(SP, 1);
54310121 365 PUSHs(boolSV(do_close(gv, TRUE)));
a0d0e21e
LW		 366 RETURN;
367}
368
369PP(pp_pipe_op)
370{
4e35701f 371 djSP;
a0d0e21e
LW		 372#ifdef HAS_PIPE
373 GV *rgv;
374 GV *wgv;
375 register IO *rstio;
376 register IO *wstio;
377 int fd[2];
378
379 wgv = (GV*)POPs;
380 rgv = (GV*)POPs;
381
382 if (!rgv || !wgv)
383 goto badexit;
384
4633a7c4
LW		 385 if (SvTYPE(rgv) != SVt_PVGV || SvTYPE(wgv) != SVt_PVGV)
386 DIE(no_usym, "filehandle");
a0d0e21e
LW		 387 rstio = GvIOn(rgv);
388 wstio = GvIOn(wgv);
389
390 if (IoIFP(rstio))
391 do_close(rgv, FALSE);
392 if (IoIFP(wstio))
393 do_close(wgv, FALSE);
394
3028581b 395 if (PerlProc_pipe(fd) < 0)
a0d0e21e
LW		 396 goto badexit;
397
760ac839
LW		 398 IoIFP(rstio) = PerlIO_fdopen(fd[0], "r");
399 IoOFP(wstio) = PerlIO_fdopen(fd[1], "w");
a0d0e21e
LW		 400 IoIFP(wstio) = IoOFP(wstio);
401 IoTYPE(rstio) = '<';
402 IoTYPE(wstio) = '>';
403
404 if (!IoIFP(rstio) || !IoOFP(wstio)) {
760ac839 405 if (IoIFP(rstio)) PerlIO_close(IoIFP(rstio));
3028581b 406 else PerlLIO_close(fd[0]);
760ac839 407 if (IoOFP(wstio)) PerlIO_close(IoOFP(wstio));
3028581b 408 else PerlLIO_close(fd[1]);
a0d0e21e
LW		 409 goto badexit;
410 }
411
412 RETPUSHYES;
413
414badexit:
415 RETPUSHUNDEF;
416#else
417 DIE(no_func, "pipe");
418#endif
419}
420
421PP(pp_fileno)
422{
4e35701f 423 djSP; dTARGET;
a0d0e21e
LW		 424 GV *gv;
425 IO *io;
760ac839 426 PerlIO *fp;
a0d0e21e
LW		 427 if (MAXARG < 1)
428 RETPUSHUNDEF;
429 gv = (GV*)POPs;
430 if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io)))
431 RETPUSHUNDEF;
760ac839 432 PUSHi(PerlIO_fileno(fp));
a0d0e21e
LW		 433 RETURN;
434}
435
436PP(pp_umask)
437{
4e35701f 438 djSP; dTARGET;
a0d0e21e
LW		 439 int anum;
440
441#ifdef HAS_UMASK
442 if (MAXARG < 1) {
3028581b
GS		 443 anum = PerlLIO_umask(0);
444 (void)PerlLIO_umask(anum);
a0d0e21e
LW		 445 }
446 else
3028581b 447 anum = PerlLIO_umask(POPi);
a0d0e21e
LW		 448 TAINT_PROPER("umask");
449 XPUSHi(anum);
450#else
451 DIE(no_func, "Unsupported function umask");
452#endif
453 RETURN;
454}
455
456PP(pp_binmode)
457{
4e35701f 458 djSP;
a0d0e21e
LW		 459 GV *gv;
460 IO *io;
760ac839 461 PerlIO *fp;
a0d0e21e
LW		 462
463 if (MAXARG < 1)
464 RETPUSHUNDEF;
465
466 gv = (GV*)POPs;
467
468 EXTEND(SP, 1);
469 if (!(io = GvIO(gv)) || !(fp = IoIFP(io)))
55497cff 470 RETPUSHUNDEF;
a0d0e21e
LW		 471
472#ifdef DOSISH
473#ifdef atarist
760ac839 474 if (!PerlIO_flush(fp) && (fp->_flag |= _IOBIN))
a0d0e21e
LW		 475 RETPUSHYES;
476 else
477 RETPUSHUNDEF;
478#else
3028581b 479 if (PerlLIO_setmode(PerlIO_fileno(fp), OP_BINARY) != -1) {
3e3baf6d
TB		 480#if defined(WIN32) && defined(__BORLANDC__)
481 /* The translation mode of the stream is maintained independent
482 * of the translation mode of the fd in the Borland RTL (heavy
483 * digging through their runtime sources reveal). User has to
484 * set the mode explicitly for the stream (though they don't
485 * document this anywhere). GSAR 97-5-24
486 */
487 PerlIO_seek(fp,0L,0);
488 fp->flags |= _F_BIN;
489#endif
a0d0e21e 490 RETPUSHYES;
3e3baf6d 491 }
a0d0e21e
LW		 492 else
493 RETPUSHUNDEF;
494#endif
495#else
cbdc8872 496#if defined(USEMYBINMODE)
497 if (my_binmode(fp,IoTYPE(io)) != NULL)
498 RETPUSHYES;
499 else
500 RETPUSHUNDEF;
501#else
a0d0e21e
LW		 502 RETPUSHYES;
503#endif
cbdc8872 504#endif
505
a0d0e21e
LW		 506}
507
b8e3bfaf 508
a0d0e21e
LW		 509PP(pp_tie)
510{
4e35701f 511 djSP;
a0d0e21e
LW		 512 SV *varsv;
513 HV* stash;
514 GV *gv;
a0d0e21e
LW		 515 SV *sv;
516 SV **mark = stack_base + ++*markstack_ptr; /* reuse in entersub */
517 I32 markoff = mark - stack_base - 1;
518 char *methname;
6b05c17a
NIS		 519 int how = 'P';
520
521 varsv = mark[0];
522 switch(SvTYPE(varsv)) {
523 case SVt_PVHV:
524 methname = "TIEHASH";
525 break;
526 case SVt_PVAV:
527 methname = "TIEARRAY";
528 break;
529 case SVt_PVGV:
530 methname = "TIEHANDLE";
531 how = 'q';
532 break;
533 default:
534 methname = "TIESCALAR";
535 how = 'q';
536 break;
537 }
a0d0e21e 538
6b05c17a
NIS		 539 if (sv_isobject(mark[1])) {
540 ENTER;
541 perl_call_method(methname, G_SCALAR);
542 }
543 else {
544 /* Not clear why we don't call perl_call_method here too.
545 * perhaps to get different error message ?
546 */
547 stash = gv_stashsv(mark[1], FALSE);
548 if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
549 DIE("Can't locate object method \"%s\" via package \"%s\"",
550 methname, SvPV(mark[1],na));
551 }
552 ENTER;
553 perl_call_sv((SV*)GvCV(gv), G_SCALAR);
554 }
a0d0e21e
LW		 555 SPAGAIN;
556
557 sv = TOPs;
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 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 583 warn("untie attempted while %lu inner references still exist",
584 (unsigned long)SvREFCNT(SvRV(mg->mg_obj)) - 1 ) ;
cbdc8872 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 595PP(pp_tied)
596{
4e35701f 597 djSP;
c07a80fd 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 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
MB		 638 ENTER;
639 PUSHMARK(sp);
6b05c17a 640
a0d0e21e
LW		 641 EXTEND(sp, 5);
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)) {
654 sp--;
57d3b86d 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 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 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 872 PUSHMARK(SP);
873 XPUSHs(mg->mg_obj);
874 PUTBACK;
875 ENTER;
54310121 876 perl_call_method("GETC", gimme);
2ae324a7 877 LEAVE;
878 SPAGAIN;
54310121 879 if (gimme == G_SCALAR)
880 SvSetMagicSV_nosteal(TARG, TOPs);
2ae324a7 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 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 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 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 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 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 1155PP(pp_sysopen)
1156{
4e35701f 1157 djSP;
c07a80fd 1158 GV *gv;
c07a80fd 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 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 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 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 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 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 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;
1322
1323 gv = (GV*)*++MARK;
1324 if (!gv)
1325 goto say_undef;
748a9306
LW		 1326 bufsv = *++MARK;
1327 buffer = SvPV(bufsv, blen);
a0d0e21e
LW		 1328 length = SvIVx(*++MARK);
1329 if (length < 0)
1330 DIE("Negative length");
748a9306 1331 SETERRNO(0,0);
a0d0e21e
LW		 1332 io = GvIO(gv);
1333 if (!io || !IoIFP(io)) {
1334 length = -1;
1335 if (dowarn) {
1336 if (op->op_type == OP_SYSWRITE)
1337 warn("Syswrite on closed filehandle");
1338 else
1339 warn("Send on closed socket");
1340 }
1341 }
1342 else if (op->op_type == OP_SYSWRITE) {
bbce6d69 1343 if (MARK < SP) {
a0d0e21e 1344 offset = SvIVx(*++MARK);
bbce6d69 1345 if (offset < 0) {
1346 if (-offset > blen)
1347 DIE("Offset outside string");
1348 offset += blen;
fb73857a 1349 } else if (offset >= blen && blen > 0)
bbce6d69 1350 DIE("Offset outside string");
1351 } else
a0d0e21e
LW		 1352 offset = 0;
1353 if (length > blen - offset)
1354 length = blen - offset;
3028581b 1355 length = PerlLIO_write(PerlIO_fileno(IoIFP(io)), buffer+offset, length);
a0d0e21e
LW		 1356 }
1357#ifdef HAS_SOCKET
1358 else if (SP > MARK) {
1359 char *sockbuf;
1360 STRLEN mlen;
1361 sockbuf = SvPVx(*++MARK, mlen);
3028581b 1362 length = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen, length,
a0d0e21e
LW		 1363 (struct sockaddr *)sockbuf, mlen);
1364 }
1365 else
3028581b 1366 length = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, length);
490ab354 1367
a0d0e21e
LW		 1368#else
1369 else
1370 DIE(no_sock_func, "send");
1371#endif
1372 if (length < 0)
1373 goto say_undef;
1374 SP = ORIGMARK;
1375 PUSHi(length);
1376 RETURN;
1377
1378 say_undef:
1379 SP = ORIGMARK;
1380 RETPUSHUNDEF;
1381}
1382
1383PP(pp_recv)
1384{
1385 return pp_sysread(ARGS);
1386}
1387
1388PP(pp_eof)
1389{
4e35701f 1390 djSP;
a0d0e21e
LW		 1391 GV *gv;
1392
1393 if (MAXARG <= 0)
1394 gv = last_in_gv;
1395 else
1396 gv = last_in_gv = (GV*)POPs;
54310121 1397 PUSHs(boolSV(!gv || do_eof(gv)));
a0d0e21e
LW		 1398 RETURN;
1399}
1400
1401PP(pp_tell)
1402{
4e35701f 1403 djSP; dTARGET;
a0d0e21e
LW		 1404 GV *gv;
1405
1406 if (MAXARG <= 0)
1407 gv = last_in_gv;
1408 else
1409 gv = last_in_gv = (GV*)POPs;
1410 PUSHi( do_tell(gv) );
1411 RETURN;
1412}
1413
1414PP(pp_seek)
1415{
137443ea 1416 return pp_sysseek(ARGS);
1417}
1418
1419PP(pp_sysseek)
1420{
4e35701f 1421 djSP;
a0d0e21e
LW		 1422 GV *gv;
1423 int whence = POPi;
1424 long offset = POPl;
1425
1426 gv = last_in_gv = (GV*)POPs;
8903cb82 1427 if (op->op_type == OP_SEEK)
1428 PUSHs(boolSV(do_seek(gv, offset, whence)));
1429 else {
1430 long n = do_sysseek(gv, offset, whence);
1431 PUSHs((n < 0) ? &sv_undef
1432 : sv_2mortal(n ? newSViv((IV)n)
1433 : newSVpv(zero_but_true, ZBTLEN)));
1434 }
a0d0e21e
LW		 1435 RETURN;
1436}
1437
1438PP(pp_truncate)
1439{
4e35701f 1440 djSP;
a0d0e21e
LW		 1441 Off_t len = (Off_t)POPn;
1442 int result = 1;
1443 GV *tmpgv;
1444
748a9306 1445 SETERRNO(0,0);
5d94fbed 1446#if defined(HAS_TRUNCATE) || defined(HAS_CHSIZE) || defined(F_FREESP)
a0d0e21e 1447 if (op->op_flags & OPf_SPECIAL) {
1e422769 1448 tmpgv = gv_fetchpv(POPp, FALSE, SVt_PVIO);
cbdc8872 1449 do_ftruncate:
1e422769 1450 TAINT_PROPER("truncate");
a0d0e21e 1451 if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv)) ||
cbdc8872 1452#ifdef HAS_TRUNCATE
760ac839 1453 ftruncate(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
cbdc8872 1454#else
760ac839 1455 my_chsize(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
cbdc8872 1456#endif
a0d0e21e
LW		 1457 result = 0;
1458 }
1459 else {
cbdc8872 1460 SV *sv = POPs;
1e422769 1461 char *name;
1462
cbdc8872 1463 if (SvTYPE(sv) == SVt_PVGV) {
1464 tmpgv = (GV*)sv; /* *main::FRED for example */
1465 goto do_ftruncate;
1466 }
1467 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
1468 tmpgv = (GV*) SvRV(sv); /* \*main::FRED for example */
1469 goto do_ftruncate;
1470 }
1e422769 1471
1472 name = SvPV(sv, na);
1473 TAINT_PROPER("truncate");
cbdc8872 1474#ifdef HAS_TRUNCATE
1e422769 1475 if (truncate(name, len) < 0)
a0d0e21e 1476 result = 0;
cbdc8872 1477#else
1478 {
1479 int tmpfd;
3028581b 1480 if ((tmpfd = PerlLIO_open(name, O_RDWR)) < 0)
bbce6d69 1481 result = 0;
cbdc8872 1482 else {
1483 if (my_chsize(tmpfd, len) < 0)
1484 result = 0;
3028581b 1485 PerlLIO_close(tmpfd);
cbdc8872 1486 }
a0d0e21e 1487 }
a0d0e21e 1488#endif
cbdc8872 1489 }
a0d0e21e
LW		 1490
1491 if (result)
1492 RETPUSHYES;
1493 if (!errno)
748a9306 1494 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW		 1495 RETPUSHUNDEF;
1496#else
1497 DIE("truncate not implemented");
1498#endif
1499}
1500
1501PP(pp_fcntl)
1502{
1503 return pp_ioctl(ARGS);
1504}
1505
1506PP(pp_ioctl)
1507{
4e35701f 1508 djSP; dTARGET;
748a9306 1509 SV *argsv = POPs;
a0d0e21e
LW		 1510 unsigned int func = U_I(POPn);
1511 int optype = op->op_type;
1512 char *s;
324aa91a 1513 IV retval;
a0d0e21e
LW		 1514 GV *gv = (GV*)POPs;
1515 IO *io = GvIOn(gv);
1516
748a9306
LW		 1517 if (!io || !argsv || !IoIFP(io)) {
1518 SETERRNO(EBADF,RMS$_IFI); /* well, sort of... */
a0d0e21e
LW		 1519 RETPUSHUNDEF;
1520 }
1521
748a9306 1522 if (SvPOK(argsv) || !SvNIOK(argsv)) {
a0d0e21e 1523 STRLEN len;
324aa91a 1524 STRLEN need;
748a9306 1525 s = SvPV_force(argsv, len);
324aa91a
HF		 1526 need = IOCPARM_LEN(func);
1527 if (len < need) {
1528 s = Sv_Grow(argsv, need + 1);
1529 SvCUR_set(argsv, need);
a0d0e21e
LW		 1530 }
1531
748a9306 1532 s[SvCUR(argsv)] = 17; /* a little sanity check here */
a0d0e21e
LW		 1533 }
1534 else {
748a9306 1535 retval = SvIV(argsv);
a0d0e21e 1536 s = (char*)retval; /* ouch */
a0d0e21e
LW		 1537 }
1538
1539 TAINT_PROPER(optype == OP_IOCTL ? "ioctl" : "fcntl");
1540
1541 if (optype == OP_IOCTL)
1542#ifdef HAS_IOCTL
760ac839 1543 retval = ioctl(PerlIO_fileno(IoIFP(io)), func, s);
a0d0e21e
LW		 1544#else
1545 DIE("ioctl is not implemented");
1546#endif
1547 else
55497cff 1548#ifdef HAS_FCNTL
1549#if defined(OS2) && defined(__EMX__)
760ac839 1550 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
55497cff 1551#else
760ac839 1552 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
55497cff 1553#endif
1554#else
a0d0e21e 1555 DIE("fcntl is not implemented");
a0d0e21e
LW		 1556#endif
1557
748a9306
LW		 1558 if (SvPOK(argsv)) {
1559 if (s[SvCUR(argsv)] != 17)
a0d0e21e
LW		 1560 DIE("Possible memory corruption: %s overflowed 3rd argument",
1561 op_name[optype]);
748a9306
LW		 1562 s[SvCUR(argsv)] = 0; /* put our null back */
1563 SvSETMAGIC(argsv); /* Assume it has changed */
a0d0e21e
LW		 1564 }
1565
1566 if (retval == -1)
1567 RETPUSHUNDEF;
1568 if (retval != 0) {
1569 PUSHi(retval);
1570 }
1571 else {
8903cb82 1572 PUSHp(zero_but_true, ZBTLEN);
a0d0e21e
LW		 1573 }
1574 RETURN;
1575}
1576
1577PP(pp_flock)
1578{
4e35701f 1579 djSP; dTARGET;
a0d0e21e
LW		 1580 I32 value;
1581 int argtype;
1582 GV *gv;
760ac839 1583 PerlIO *fp;
16d20bd9 1584
ff68c719 1585#ifdef FLOCK
a0d0e21e
LW		 1586 argtype = POPi;
1587 if (MAXARG <= 0)
1588 gv = last_in_gv;
1589 else
1590 gv = (GV*)POPs;
1591 if (gv && GvIO(gv))
1592 fp = IoIFP(GvIOp(gv));
1593 else
1594 fp = Nullfp;
1595 if (fp) {
68dc0745 1596 (void)PerlIO_flush(fp);
ff68c719 1597 value = (I32)(FLOCK(PerlIO_fileno(fp), argtype) >= 0);
a0d0e21e
LW		 1598 }
1599 else
1600 value = 0;
1601 PUSHi(value);
1602 RETURN;
1603#else
a0d0e21e 1604 DIE(no_func, "flock()");
a0d0e21e
LW		 1605#endif
1606}
1607
1608/* Sockets. */
1609
1610PP(pp_socket)
1611{
4e35701f 1612 djSP;
a0d0e21e
LW		 1613#ifdef HAS_SOCKET
1614 GV *gv;
1615 register IO *io;
1616 int protocol = POPi;
1617 int type = POPi;
1618 int domain = POPi;
1619 int fd;
1620
1621 gv = (GV*)POPs;
1622
1623 if (!gv) {
748a9306 1624 SETERRNO(EBADF,LIB$_INVARG);
a0d0e21e
LW		 1625 RETPUSHUNDEF;
1626 }
1627
1628 io = GvIOn(gv);
1629 if (IoIFP(io))
1630 do_close(gv, FALSE);
1631
1632 TAINT_PROPER("socket");
3028581b 1633 fd = PerlSock_socket(domain, type, protocol);
a0d0e21e
LW		 1634 if (fd < 0)
1635 RETPUSHUNDEF;
760ac839
LW		 1636 IoIFP(io) = PerlIO_fdopen(fd, "r"); /* stdio gets confused about sockets */
1637 IoOFP(io) = PerlIO_fdopen(fd, "w");
a0d0e21e
LW		 1638 IoTYPE(io) = 's';
1639 if (!IoIFP(io) || !IoOFP(io)) {
760ac839
LW		 1640 if (IoIFP(io)) PerlIO_close(IoIFP(io));
1641 if (IoOFP(io)) PerlIO_close(IoOFP(io));
3028581b 1642 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
a0d0e21e
LW		 1643 RETPUSHUNDEF;
1644 }
1645
1646 RETPUSHYES;
1647#else
1648 DIE(no_sock_func, "socket");
1649#endif
1650}
1651
1652PP(pp_sockpair)
1653{
4e35701f 1654 djSP;
a0d0e21e
LW		 1655#ifdef HAS_SOCKETPAIR
1656 GV *gv1;
1657 GV *gv2;
1658 register IO *io1;
1659 register IO *io2;
1660 int protocol = POPi;
1661 int type = POPi;
1662 int domain = POPi;
1663 int fd[2];
1664
1665 gv2 = (GV*)POPs;
1666 gv1 = (GV*)POPs;
1667 if (!gv1 || !gv2)
1668 RETPUSHUNDEF;
1669
1670 io1 = GvIOn(gv1);
1671 io2 = GvIOn(gv2);
1672 if (IoIFP(io1))
1673 do_close(gv1, FALSE);
1674 if (IoIFP(io2))
1675 do_close(gv2, FALSE);
1676
1677 TAINT_PROPER("socketpair");
3028581b 1678 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
a0d0e21e 1679 RETPUSHUNDEF;
760ac839
LW		 1680 IoIFP(io1) = PerlIO_fdopen(fd[0], "r");
1681 IoOFP(io1) = PerlIO_fdopen(fd[0], "w");
a0d0e21e 1682 IoTYPE(io1) = 's';
760ac839
LW		 1683 IoIFP(io2) = PerlIO_fdopen(fd[1], "r");
1684 IoOFP(io2) = PerlIO_fdopen(fd[1], "w");
a0d0e21e
LW		 1685 IoTYPE(io2) = 's';
1686 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
760ac839
LW		 1687 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
1688 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
3028581b 1689 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
760ac839
LW		 1690 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
1691 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
3028581b 1692 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
a0d0e21e
LW		 1693 RETPUSHUNDEF;
1694 }
1695
1696 RETPUSHYES;
1697#else
1698 DIE(no_sock_func, "socketpair");
1699#endif
1700}
1701
1702PP(pp_bind)
1703{
4e35701f 1704 djSP;
a0d0e21e 1705#ifdef HAS_SOCKET
748a9306 1706 SV *addrsv = POPs;
a0d0e21e
LW		 1707 char *addr;
1708 GV *gv = (GV*)POPs;
1709 register IO *io = GvIOn(gv);
1710 STRLEN len;
1711
1712 if (!io || !IoIFP(io))
1713 goto nuts;
1714
748a9306 1715 addr = SvPV(addrsv, len);
a0d0e21e 1716 TAINT_PROPER("bind");
3028581b 1717 if (PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
a0d0e21e
LW		 1718 RETPUSHYES;
1719 else
1720 RETPUSHUNDEF;
1721
1722nuts:
1723 if (dowarn)
1724 warn("bind() on closed fd");
748a9306 1725 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 1726 RETPUSHUNDEF;
1727#else
1728 DIE(no_sock_func, "bind");
1729#endif
1730}
1731
1732PP(pp_connect)
1733{
4e35701f 1734 djSP;
a0d0e21e 1735#ifdef HAS_SOCKET
748a9306 1736 SV *addrsv = POPs;
a0d0e21e
LW		 1737 char *addr;
1738 GV *gv = (GV*)POPs;
1739 register IO *io = GvIOn(gv);
1740 STRLEN len;
1741
1742 if (!io || !IoIFP(io))
1743 goto nuts;
1744
748a9306 1745 addr = SvPV(addrsv, len);
a0d0e21e 1746 TAINT_PROPER("connect");
3028581b 1747 if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
a0d0e21e
LW		 1748 RETPUSHYES;
1749 else
1750 RETPUSHUNDEF;
1751
1752nuts:
1753 if (dowarn)
1754 warn("connect() on closed fd");
748a9306 1755 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 1756 RETPUSHUNDEF;
1757#else
1758 DIE(no_sock_func, "connect");
1759#endif
1760}
1761
1762PP(pp_listen)
1763{
4e35701f 1764 djSP;
a0d0e21e
LW		 1765#ifdef HAS_SOCKET
1766 int backlog = POPi;
1767 GV *gv = (GV*)POPs;
1768 register IO *io = GvIOn(gv);
1769
1770 if (!io || !IoIFP(io))
1771 goto nuts;
1772
3028581b 1773 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
a0d0e21e
LW		 1774 RETPUSHYES;
1775 else
1776 RETPUSHUNDEF;
1777
1778nuts:
1779 if (dowarn)
1780 warn("listen() on closed fd");
748a9306 1781 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 1782 RETPUSHUNDEF;
1783#else
1784 DIE(no_sock_func, "listen");
1785#endif
1786}
1787
1788PP(pp_accept)
1789{
4e35701f 1790 djSP; dTARGET;
a0d0e21e
LW		 1791#ifdef HAS_SOCKET
1792 GV *ngv;
1793 GV *ggv;
1794 register IO *nstio;
1795 register IO *gstio;
4633a7c4 1796 struct sockaddr saddr; /* use a struct to avoid alignment problems */
1e422769 1797 Sock_size_t len = sizeof saddr;
a0d0e21e
LW		 1798 int fd;
1799
1800 ggv = (GV*)POPs;
1801 ngv = (GV*)POPs;
1802
1803 if (!ngv)
1804 goto badexit;
1805 if (!ggv)
1806 goto nuts;
1807
1808 gstio = GvIO(ggv);
1809 if (!gstio || !IoIFP(gstio))
1810 goto nuts;
1811
1812 nstio = GvIOn(ngv);
1813 if (IoIFP(nstio))
1814 do_close(ngv, FALSE);
1815
3028581b 1816 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *)&saddr, &len);
a0d0e21e
LW		 1817 if (fd < 0)
1818 goto badexit;
760ac839
LW		 1819 IoIFP(nstio) = PerlIO_fdopen(fd, "r");
1820 IoOFP(nstio) = PerlIO_fdopen(fd, "w");
a0d0e21e
LW		 1821 IoTYPE(nstio) = 's';
1822 if (!IoIFP(nstio) || !IoOFP(nstio)) {
760ac839
LW		 1823 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
1824 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
3028581b 1825 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
a0d0e21e
LW		 1826 goto badexit;
1827 }
1828
748a9306 1829 PUSHp((char *)&saddr, len);
a0d0e21e
LW		 1830 RETURN;
1831
1832nuts:
1833 if (dowarn)
1834 warn("accept() on closed fd");
748a9306 1835 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 1836
1837badexit:
1838 RETPUSHUNDEF;
1839
1840#else
1841 DIE(no_sock_func, "accept");
1842#endif
1843}
1844
1845PP(pp_shutdown)
1846{
4e35701f 1847 djSP; dTARGET;
a0d0e21e
LW		 1848#ifdef HAS_SOCKET
1849 int how = POPi;
1850 GV *gv = (GV*)POPs;
1851 register IO *io = GvIOn(gv);
1852
1853 if (!io || !IoIFP(io))
1854 goto nuts;
1855
3028581b 1856 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
a0d0e21e
LW		 1857 RETURN;
1858
1859nuts:
1860 if (dowarn)
1861 warn("shutdown() on closed fd");
748a9306 1862 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 1863 RETPUSHUNDEF;
1864#else
1865 DIE(no_sock_func, "shutdown");
1866#endif
1867}
1868
1869PP(pp_gsockopt)
1870{
1871#ifdef HAS_SOCKET
1872 return pp_ssockopt(ARGS);
1873#else
1874 DIE(no_sock_func, "getsockopt");
1875#endif
1876}
1877
1878PP(pp_ssockopt)
1879{
4e35701f 1880 djSP;
a0d0e21e
LW		 1881#ifdef HAS_SOCKET
1882 int optype = op->op_type;
1883 SV *sv;
1884 int fd;
1885 unsigned int optname;
1886 unsigned int lvl;
1887 GV *gv;
1888 register IO *io;
1e422769 1889 Sock_size_t len;
a0d0e21e
LW		 1890
1891 if (optype == OP_GSOCKOPT)
1892 sv = sv_2mortal(NEWSV(22, 257));
1893 else
1894 sv = POPs;
1895 optname = (unsigned int) POPi;
1896 lvl = (unsigned int) POPi;
1897
1898 gv = (GV*)POPs;
1899 io = GvIOn(gv);
1900 if (!io || !IoIFP(io))
1901 goto nuts;
1902
760ac839 1903 fd = PerlIO_fileno(IoIFP(io));
a0d0e21e
LW		 1904 switch (optype) {
1905 case OP_GSOCKOPT:
748a9306 1906 SvGROW(sv, 257);
a0d0e21e 1907 (void)SvPOK_only(sv);
748a9306
LW		 1908 SvCUR_set(sv,256);
1909 *SvEND(sv) ='\0';
1e422769 1910 len = SvCUR(sv);
3028581b 1911 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
a0d0e21e 1912 goto nuts2;
1e422769 1913 SvCUR_set(sv, len);
748a9306 1914 *SvEND(sv) ='\0';
a0d0e21e
LW		 1915 PUSHs(sv);
1916 break;
1917 case OP_SSOCKOPT: {
1e422769 1918 char *buf;
1919 int aint;
1920 if (SvPOKp(sv)) {
1921 buf = SvPV(sv, na);
1922 len = na;
1923 }
a0d0e21e
LW		 1924 else if (SvOK(sv)) {
1925 aint = (int)SvIV(sv);
1926 buf = (char*)&aint;
1927 len = sizeof(int);
1928 }
3028581b 1929 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
a0d0e21e
LW		 1930 goto nuts2;
1931 PUSHs(&sv_yes);
1932 }
1933 break;
1934 }
1935 RETURN;
1936
1937nuts:
1938 if (dowarn)
1939 warn("[gs]etsockopt() on closed fd");
748a9306 1940 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 1941nuts2:
1942 RETPUSHUNDEF;
1943
1944#else
1945 DIE(no_sock_func, "setsockopt");
1946#endif
1947}
1948
1949PP(pp_getsockname)
1950{
1951#ifdef HAS_SOCKET
1952 return pp_getpeername(ARGS);
1953#else
1954 DIE(no_sock_func, "getsockname");
1955#endif
1956}
1957
1958PP(pp_getpeername)
1959{
4e35701f 1960 djSP;
a0d0e21e
LW		 1961#ifdef HAS_SOCKET
1962 int optype = op->op_type;
1963 SV *sv;
1964 int fd;
1965 GV *gv = (GV*)POPs;
1966 register IO *io = GvIOn(gv);
1e422769 1967 Sock_size_t len;
a0d0e21e
LW		 1968
1969 if (!io || !IoIFP(io))
1970 goto nuts;
1971
1972 sv = sv_2mortal(NEWSV(22, 257));
748a9306 1973 (void)SvPOK_only(sv);
1e422769 1974 len = 256;
1975 SvCUR_set(sv, len);
748a9306 1976 *SvEND(sv) ='\0';
760ac839 1977 fd = PerlIO_fileno(IoIFP(io));
a0d0e21e
LW		 1978 switch (optype) {
1979 case OP_GETSOCKNAME:
3028581b 1980 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
a0d0e21e
LW		 1981 goto nuts2;
1982 break;
1983 case OP_GETPEERNAME:
3028581b 1984 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
a0d0e21e 1985 goto nuts2;
490ab354
JH		 1986#if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
1987 {
1988 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";
1989 /* If the call succeeded, make sure we don't have a zeroed port/addr */
1990 if (((struct sockaddr *)SvPVX(sv))->sa_family == AF_INET &&
1991 !memcmp((char *)SvPVX(sv) + sizeof(u_short), nowhere,
1992 sizeof(u_short) + sizeof(struct in_addr))) {
1993 goto nuts2;
1994 }
1995 }
1996#endif
a0d0e21e
LW		 1997 break;
1998 }
13826f2c
CS		 1999#ifdef BOGUS_GETNAME_RETURN
2000 /* Interactive Unix, getpeername() and getsockname()
2001 does not return valid namelen */
1e422769 2002 if (len == BOGUS_GETNAME_RETURN)
2003 len = sizeof(struct sockaddr);
13826f2c 2004#endif
1e422769 2005 SvCUR_set(sv, len);
748a9306 2006 *SvEND(sv) ='\0';
a0d0e21e
LW		 2007 PUSHs(sv);
2008 RETURN;
2009
2010nuts:
2011 if (dowarn)
2012 warn("get{sock, peer}name() on closed fd");
748a9306 2013 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2014nuts2:
2015 RETPUSHUNDEF;
2016
2017#else
2018 DIE(no_sock_func, "getpeername");
2019#endif
2020}
2021
2022/* Stat calls. */
2023
2024PP(pp_lstat)
2025{
2026 return pp_stat(ARGS);
2027}
2028
2029PP(pp_stat)
2030{
4e35701f 2031 djSP;
a0d0e21e 2032 GV *tmpgv;
54310121 2033 I32 gimme;
a0d0e21e
LW		 2034 I32 max = 13;
2035
2036 if (op->op_flags & OPf_REF) {
2037 tmpgv = cGVOP->op_gv;
748a9306 2038 do_fstat:
a0d0e21e
LW		 2039 if (tmpgv != defgv) {
2040 laststype = OP_STAT;
2041 statgv = tmpgv;
2042 sv_setpv(statname, "");
36477c24 2043 laststatval = (GvIO(tmpgv) && IoIFP(GvIOp(tmpgv))
3028581b 2044 ? PerlLIO_fstat(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), &statcache) : -1);
a0d0e21e 2045 }
36477c24 2046 if (laststatval < 0)
a0d0e21e
LW		 2047 max = 0;
2048 }
2049 else {
748a9306
LW		 2050 SV* sv = POPs;
2051 if (SvTYPE(sv) == SVt_PVGV) {
2052 tmpgv = (GV*)sv;
2053 goto do_fstat;
2054 }
2055 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2056 tmpgv = (GV*)SvRV(sv);
2057 goto do_fstat;
2058 }
2059 sv_setpv(statname, SvPV(sv,na));
a0d0e21e
LW		 2060 statgv = Nullgv;
2061#ifdef HAS_LSTAT
2062 laststype = op->op_type;
2063 if (op->op_type == OP_LSTAT)
3028581b 2064 laststatval = PerlLIO_lstat(SvPV(statname, na), &statcache);
a0d0e21e
LW		 2065 else
2066#endif
2067 laststatval = Stat(SvPV(statname, na), &statcache);
2068 if (laststatval < 0) {
2069 if (dowarn && strchr(SvPV(statname, na), '\n'))
2070 warn(warn_nl, "stat");
2071 max = 0;
2072 }
2073 }
2074
54310121 2075 gimme = GIMME_V;
2076 if (gimme != G_ARRAY) {
2077 if (gimme != G_VOID)
2078 XPUSHs(boolSV(max));
2079 RETURN;
a0d0e21e
LW		 2080 }
2081 if (max) {
36477c24 2082 EXTEND(SP, max);
2083 EXTEND_MORTAL(max);
a0d0e21e
LW		 2084 PUSHs(sv_2mortal(newSViv((I32)statcache.st_dev)));
2085 PUSHs(sv_2mortal(newSViv((I32)statcache.st_ino)));
2086 PUSHs(sv_2mortal(newSViv((I32)statcache.st_mode)));
2087 PUSHs(sv_2mortal(newSViv((I32)statcache.st_nlink)));
2088 PUSHs(sv_2mortal(newSViv((I32)statcache.st_uid)));
2089 PUSHs(sv_2mortal(newSViv((I32)statcache.st_gid)));
cbdc8872 2090#ifdef USE_STAT_RDEV
a0d0e21e 2091 PUSHs(sv_2mortal(newSViv((I32)statcache.st_rdev)));
cbdc8872 2092#else
2093 PUSHs(sv_2mortal(newSVpv("", 0)));
2094#endif
a0d0e21e 2095 PUSHs(sv_2mortal(newSViv((I32)statcache.st_size)));
cbdc8872 2096#ifdef BIG_TIME
2097 PUSHs(sv_2mortal(newSVnv((U32)statcache.st_atime)));
2098 PUSHs(sv_2mortal(newSVnv((U32)statcache.st_mtime)));
2099 PUSHs(sv_2mortal(newSVnv((U32)statcache.st_ctime)));
2100#else
a0d0e21e
LW		 2101 PUSHs(sv_2mortal(newSViv((I32)statcache.st_atime)));
2102 PUSHs(sv_2mortal(newSViv((I32)statcache.st_mtime)));
2103 PUSHs(sv_2mortal(newSViv((I32)statcache.st_ctime)));
cbdc8872 2104#endif
a0d0e21e
LW		 2105#ifdef USE_STAT_BLOCKS
2106 PUSHs(sv_2mortal(newSViv((I32)statcache.st_blksize)));
2107 PUSHs(sv_2mortal(newSViv((I32)statcache.st_blocks)));
2108#else
2109 PUSHs(sv_2mortal(newSVpv("", 0)));
2110 PUSHs(sv_2mortal(newSVpv("", 0)));
2111#endif
2112 }
2113 RETURN;
2114}
2115
2116PP(pp_ftrread)
2117{
2118 I32 result = my_stat(ARGS);
4e35701f 2119 djSP;
a0d0e21e
LW		 2120 if (result < 0)
2121 RETPUSHUNDEF;
2122 if (cando(S_IRUSR, 0, &statcache))
2123 RETPUSHYES;
2124 RETPUSHNO;
2125}
2126
2127PP(pp_ftrwrite)
2128{
2129 I32 result = my_stat(ARGS);
4e35701f 2130 djSP;
a0d0e21e
LW		 2131 if (result < 0)
2132 RETPUSHUNDEF;
2133 if (cando(S_IWUSR, 0, &statcache))
2134 RETPUSHYES;
2135 RETPUSHNO;
2136}
2137
2138PP(pp_ftrexec)
2139{
2140 I32 result = my_stat(ARGS);
4e35701f 2141 djSP;
a0d0e21e
LW		 2142 if (result < 0)
2143 RETPUSHUNDEF;
2144 if (cando(S_IXUSR, 0, &statcache))
2145 RETPUSHYES;
2146 RETPUSHNO;
2147}
2148
2149PP(pp_fteread)
2150{
2151 I32 result = my_stat(ARGS);
4e35701f 2152 djSP;
a0d0e21e
LW		 2153 if (result < 0)
2154 RETPUSHUNDEF;
2155 if (cando(S_IRUSR, 1, &statcache))
2156 RETPUSHYES;
2157 RETPUSHNO;
2158}
2159
2160PP(pp_ftewrite)
2161{
2162 I32 result = my_stat(ARGS);
4e35701f 2163 djSP;
a0d0e21e
LW		 2164 if (result < 0)
2165 RETPUSHUNDEF;
2166 if (cando(S_IWUSR, 1, &statcache))
2167 RETPUSHYES;
2168 RETPUSHNO;
2169}
2170
2171PP(pp_fteexec)
2172{
2173 I32 result = my_stat(ARGS);
4e35701f 2174 djSP;
a0d0e21e
LW		 2175 if (result < 0)
2176 RETPUSHUNDEF;
2177 if (cando(S_IXUSR, 1, &statcache))
2178 RETPUSHYES;
2179 RETPUSHNO;
2180}
2181
2182PP(pp_ftis)
2183{
2184 I32 result = my_stat(ARGS);
4e35701f 2185 djSP;
a0d0e21e
LW		 2186 if (result < 0)
2187 RETPUSHUNDEF;
2188 RETPUSHYES;
2189}
2190
2191PP(pp_fteowned)
2192{
2193 return pp_ftrowned(ARGS);
2194}
2195
2196PP(pp_ftrowned)
2197{
2198 I32 result = my_stat(ARGS);
4e35701f 2199 djSP;
a0d0e21e
LW		 2200 if (result < 0)
2201 RETPUSHUNDEF;
2202 if (statcache.st_uid == (op->op_type == OP_FTEOWNED ? euid : uid) )
2203 RETPUSHYES;
2204 RETPUSHNO;
2205}
2206
2207PP(pp_ftzero)
2208{
2209 I32 result = my_stat(ARGS);
4e35701f 2210 djSP;
a0d0e21e
LW		 2211 if (result < 0)
2212 RETPUSHUNDEF;
2213 if (!statcache.st_size)
2214 RETPUSHYES;
2215 RETPUSHNO;
2216}
2217
2218PP(pp_ftsize)
2219{
2220 I32 result = my_stat(ARGS);
4e35701f 2221 djSP; dTARGET;
a0d0e21e
LW		 2222 if (result < 0)
2223 RETPUSHUNDEF;
2224 PUSHi(statcache.st_size);
2225 RETURN;
2226}
2227
2228PP(pp_ftmtime)
2229{
2230 I32 result = my_stat(ARGS);
4e35701f 2231 djSP; dTARGET;
a0d0e21e
LW		 2232 if (result < 0)
2233 RETPUSHUNDEF;
53a31ece 2234 PUSHn( ((I32)basetime - (I32)statcache.st_mtime) / 86400.0 );
a0d0e21e
LW		 2235 RETURN;
2236}
2237
2238PP(pp_ftatime)
2239{
2240 I32 result = my_stat(ARGS);
4e35701f 2241 djSP; dTARGET;
a0d0e21e
LW		 2242 if (result < 0)
2243 RETPUSHUNDEF;
53a31ece 2244 PUSHn( ((I32)basetime - (I32)statcache.st_atime) / 86400.0 );
a0d0e21e
LW		 2245 RETURN;
2246}
2247
2248PP(pp_ftctime)
2249{
2250 I32 result = my_stat(ARGS);
4e35701f 2251 djSP; dTARGET;
a0d0e21e
LW		 2252 if (result < 0)
2253 RETPUSHUNDEF;
53a31ece 2254 PUSHn( ((I32)basetime - (I32)statcache.st_ctime) / 86400.0 );
a0d0e21e
LW		 2255 RETURN;
2256}
2257
2258PP(pp_ftsock)
2259{
2260 I32 result = my_stat(ARGS);
4e35701f 2261 djSP;
a0d0e21e
LW		 2262 if (result < 0)
2263 RETPUSHUNDEF;
2264 if (S_ISSOCK(statcache.st_mode))
2265 RETPUSHYES;
2266 RETPUSHNO;
2267}
2268
2269PP(pp_ftchr)
2270{
2271 I32 result = my_stat(ARGS);
4e35701f 2272 djSP;
a0d0e21e
LW		 2273 if (result < 0)
2274 RETPUSHUNDEF;
2275 if (S_ISCHR(statcache.st_mode))
2276 RETPUSHYES;
2277 RETPUSHNO;
2278}
2279
2280PP(pp_ftblk)
2281{
2282 I32 result = my_stat(ARGS);
4e35701f 2283 djSP;
a0d0e21e
LW		 2284 if (result < 0)
2285 RETPUSHUNDEF;
2286 if (S_ISBLK(statcache.st_mode))
2287 RETPUSHYES;
2288 RETPUSHNO;
2289}
2290
2291PP(pp_ftfile)
2292{
2293 I32 result = my_stat(ARGS);
4e35701f 2294 djSP;
a0d0e21e
LW		 2295 if (result < 0)
2296 RETPUSHUNDEF;
2297 if (S_ISREG(statcache.st_mode))
2298 RETPUSHYES;
2299 RETPUSHNO;
2300}
2301
2302PP(pp_ftdir)
2303{
2304 I32 result = my_stat(ARGS);
4e35701f 2305 djSP;
a0d0e21e
LW		 2306 if (result < 0)
2307 RETPUSHUNDEF;
2308 if (S_ISDIR(statcache.st_mode))
2309 RETPUSHYES;
2310 RETPUSHNO;
2311}
2312
2313PP(pp_ftpipe)
2314{
2315 I32 result = my_stat(ARGS);
4e35701f 2316 djSP;
a0d0e21e
LW		 2317 if (result < 0)
2318 RETPUSHUNDEF;
2319 if (S_ISFIFO(statcache.st_mode))
2320 RETPUSHYES;
2321 RETPUSHNO;
2322}
2323
2324PP(pp_ftlink)
2325{
2326 I32 result = my_lstat(ARGS);
4e35701f 2327 djSP;
a0d0e21e
LW		 2328 if (result < 0)
2329 RETPUSHUNDEF;
2330 if (S_ISLNK(statcache.st_mode))
2331 RETPUSHYES;
2332 RETPUSHNO;
2333}
2334
2335PP(pp_ftsuid)
2336{
4e35701f 2337 djSP;
a0d0e21e
LW		 2338#ifdef S_ISUID
2339 I32 result = my_stat(ARGS);
2340 SPAGAIN;
2341 if (result < 0)
2342 RETPUSHUNDEF;
2343 if (statcache.st_mode & S_ISUID)
2344 RETPUSHYES;
2345#endif
2346 RETPUSHNO;
2347}
2348
2349PP(pp_ftsgid)
2350{
4e35701f 2351 djSP;
a0d0e21e
LW		 2352#ifdef S_ISGID
2353 I32 result = my_stat(ARGS);
2354 SPAGAIN;
2355 if (result < 0)
2356 RETPUSHUNDEF;
2357 if (statcache.st_mode & S_ISGID)
2358 RETPUSHYES;
2359#endif
2360 RETPUSHNO;
2361}
2362
2363PP(pp_ftsvtx)
2364{
4e35701f 2365 djSP;
a0d0e21e
LW		 2366#ifdef S_ISVTX
2367 I32 result = my_stat(ARGS);
2368 SPAGAIN;
2369 if (result < 0)
2370 RETPUSHUNDEF;
2371 if (statcache.st_mode & S_ISVTX)
2372 RETPUSHYES;
2373#endif
2374 RETPUSHNO;
2375}
2376
2377PP(pp_fttty)
2378{
4e35701f 2379 djSP;
a0d0e21e
LW		 2380 int fd;
2381 GV *gv;
fb73857a 2382 char *tmps = Nullch;
2383
2384 if (op->op_flags & OPf_REF)
a0d0e21e 2385 gv = cGVOP->op_gv;
fb73857a 2386 else if (isGV(TOPs))
2387 gv = (GV*)POPs;
2388 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
2389 gv = (GV*)SvRV(POPs);
a0d0e21e
LW		 2390 else
2391 gv = gv_fetchpv(tmps = POPp, FALSE, SVt_PVIO);
fb73857a 2392
a0d0e21e 2393 if (GvIO(gv) && IoIFP(GvIOp(gv)))
760ac839 2394 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
fb73857a 2395 else if (tmps && isDIGIT(*tmps))
a0d0e21e
LW		 2396 fd = atoi(tmps);
2397 else
2398 RETPUSHUNDEF;
3028581b 2399 if (PerlLIO_isatty(fd))
a0d0e21e
LW		 2400 RETPUSHYES;
2401 RETPUSHNO;
2402}
2403
16d20bd9
AD		 2404#if defined(atarist) /* this will work with atariST. Configure will
2405 make guesses for other systems. */
2406# define FILE_base(f) ((f)->_base)
2407# define FILE_ptr(f) ((f)->_ptr)
2408# define FILE_cnt(f) ((f)->_cnt)
2409# define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
a0d0e21e
LW		 2410#endif
2411
2412PP(pp_fttext)
2413{
4e35701f 2414 djSP;
a0d0e21e
LW		 2415 I32 i;
2416 I32 len;
2417 I32 odd = 0;
2418 STDCHAR tbuf[512];
2419 register STDCHAR *s;
2420 register IO *io;
5f05dabc 2421 register SV *sv;
2422 GV *gv;
a0d0e21e 2423
5f05dabc 2424 if (op->op_flags & OPf_REF)
2425 gv = cGVOP->op_gv;
2426 else if (isGV(TOPs))
2427 gv = (GV*)POPs;
2428 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
2429 gv = (GV*)SvRV(POPs);
2430 else
2431 gv = Nullgv;
2432
2433 if (gv) {
a0d0e21e 2434 EXTEND(SP, 1);
5f05dabc 2435 if (gv == defgv) {
a0d0e21e
LW		 2436 if (statgv)
2437 io = GvIO(statgv);
2438 else {
2439 sv = statname;
2440 goto really_filename;
2441 }
2442 }
2443 else {
5f05dabc 2444 statgv = gv;
2445 laststatval = -1;
a0d0e21e
LW		 2446 sv_setpv(statname, "");
2447 io = GvIO(statgv);
2448 }
2449 if (io && IoIFP(io)) {
5f05dabc 2450 if (! PerlIO_has_base(IoIFP(io)))
2451 DIE("-T and -B not implemented on filehandles");
3028581b 2452 laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &statcache);
5f05dabc 2453 if (laststatval < 0)
2454 RETPUSHUNDEF;
a0d0e21e
LW		 2455 if (S_ISDIR(statcache.st_mode)) /* handle NFS glitch */
2456 if (op->op_type == OP_FTTEXT)
2457 RETPUSHNO;
2458 else
2459 RETPUSHYES;
760ac839
LW		 2460 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
2461 i = PerlIO_getc(IoIFP(io));
a0d0e21e 2462 if (i != EOF)
760ac839 2463 (void)PerlIO_ungetc(IoIFP(io),i);
a0d0e21e 2464 }
760ac839 2465 if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
a0d0e21e 2466 RETPUSHYES;
760ac839
LW		 2467 len = PerlIO_get_bufsiz(IoIFP(io));
2468 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
2469 /* sfio can have large buffers - limit to 512 */
2470 if (len > 512)
2471 len = 512;
a0d0e21e
LW		 2472 }
2473 else {
2474 if (dowarn)
2475 warn("Test on unopened file <%s>",
2476 GvENAME(cGVOP->op_gv));
748a9306 2477 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW		 2478 RETPUSHUNDEF;
2479 }
2480 }
2481 else {
2482 sv = POPs;
5f05dabc 2483 really_filename:
a0d0e21e 2484 statgv = Nullgv;
5f05dabc 2485 laststatval = -1;
a0d0e21e 2486 sv_setpv(statname, SvPV(sv, na));
a0d0e21e 2487#ifdef HAS_OPEN3
3028581b 2488 i = PerlLIO_open3(SvPV(sv, na), O_RDONLY, 0);
a0d0e21e 2489#else
3028581b 2490 i = PerlLIO_open(SvPV(sv, na), 0);
a0d0e21e
LW		 2491#endif
2492 if (i < 0) {
2493 if (dowarn && strchr(SvPV(sv, na), '\n'))
2494 warn(warn_nl, "open");
2495 RETPUSHUNDEF;
2496 }
3028581b 2497 laststatval = PerlLIO_fstat(i, &statcache);
5f05dabc 2498 if (laststatval < 0)
2499 RETPUSHUNDEF;
3028581b
GS		 2500 len = PerlLIO_read(i, tbuf, 512);
2501 (void)PerlLIO_close(i);
a0d0e21e
LW		 2502 if (len <= 0) {
2503 if (S_ISDIR(statcache.st_mode) && op->op_type == OP_FTTEXT)
2504 RETPUSHNO; /* special case NFS directories */
2505 RETPUSHYES; /* null file is anything */
2506 }
2507 s = tbuf;
2508 }
2509
2510 /* now scan s to look for textiness */
4633a7c4 2511 /* XXX ASCII dependent code */
a0d0e21e
LW		 2512
2513 for (i = 0; i < len; i++, s++) {
2514 if (!*s) { /* null never allowed in text */
2515 odd += len;
2516 break;
2517 }
2518 else if (*s & 128)
2519 odd++;
2520 else if (*s < 32 &&
2521 *s != '\n' && *s != '\r' && *s != '\b' &&
2522 *s != '\t' && *s != '\f' && *s != 27)
2523 odd++;
2524 }
2525
4633a7c4 2526 if ((odd * 3 > len) == (op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
a0d0e21e
LW		 2527 RETPUSHNO;
2528 else
2529 RETPUSHYES;
2530}
2531
2532PP(pp_ftbinary)
2533{
2534 return pp_fttext(ARGS);
2535}
2536
2537/* File calls. */
2538
2539PP(pp_chdir)
2540{
4e35701f 2541 djSP; dTARGET;
a0d0e21e
LW		 2542 char *tmps;
2543 SV **svp;
2544
2545 if (MAXARG < 1)
2546 tmps = Nullch;
2547 else
2548 tmps = POPp;
2549 if (!tmps || !*tmps) {
2550 svp = hv_fetch(GvHVn(envgv), "HOME", 4, FALSE);
2551 if (svp)
2552 tmps = SvPV(*svp, na);
2553 }
2554 if (!tmps || !*tmps) {
2555 svp = hv_fetch(GvHVn(envgv), "LOGDIR", 6, FALSE);
2556 if (svp)
2557 tmps = SvPV(*svp, na);
2558 }
2559 TAINT_PROPER("chdir");
3028581b 2560 PUSHi( PerlDir_chdir(tmps) >= 0 );
748a9306
LW		 2561#ifdef VMS
2562 /* Clear the DEFAULT element of ENV so we'll get the new value
2563 * in the future. */
4633a7c4 2564 hv_delete(GvHVn(envgv),"DEFAULT",7,G_DISCARD);
748a9306 2565#endif
a0d0e21e
LW		 2566 RETURN;
2567}
2568
2569PP(pp_chown)
2570{
4e35701f 2571 djSP; dMARK; dTARGET;
a0d0e21e
LW		 2572 I32 value;
2573#ifdef HAS_CHOWN
2574 value = (I32)apply(op->op_type, MARK, SP);
2575 SP = MARK;
2576 PUSHi(value);
2577 RETURN;
2578#else
2579 DIE(no_func, "Unsupported function chown");
2580#endif
2581}
2582
2583PP(pp_chroot)
2584{
4e35701f 2585 djSP; dTARGET;
a0d0e21e
LW		 2586 char *tmps;
2587#ifdef HAS_CHROOT
2588 tmps = POPp;
2589 TAINT_PROPER("chroot");
2590 PUSHi( chroot(tmps) >= 0 );
2591 RETURN;
2592#else
2593 DIE(no_func, "chroot");
2594#endif
2595}
2596
2597PP(pp_unlink)
2598{
4e35701f 2599 djSP; dMARK; dTARGET;
a0d0e21e
LW		 2600 I32 value;
2601 value = (I32)apply(op->op_type, MARK, SP);
2602 SP = MARK;
2603 PUSHi(value);
2604 RETURN;
2605}
2606
2607PP(pp_chmod)
2608{
4e35701f 2609 djSP; dMARK; dTARGET;
a0d0e21e
LW		 2610 I32 value;
2611 value = (I32)apply(op->op_type, MARK, SP);
2612 SP = MARK;
2613 PUSHi(value);
2614 RETURN;
2615}
2616
2617PP(pp_utime)
2618{
4e35701f 2619 djSP; dMARK; dTARGET;
a0d0e21e
LW		 2620 I32 value;
2621 value = (I32)apply(op->op_type, MARK, SP);
2622 SP = MARK;
2623 PUSHi(value);
2624 RETURN;
2625}
2626
2627PP(pp_rename)
2628{
4e35701f 2629 djSP; dTARGET;
a0d0e21e
LW		 2630 int anum;
2631
2632 char *tmps2 = POPp;
2633 char *tmps = SvPV(TOPs, na);
2634 TAINT_PROPER("rename");
2635#ifdef HAS_RENAME
2636 anum = rename(tmps, tmps2);
2637#else
ed969818
W		 2638 if (!(anum = Stat(tmps, &statbuf))) {
2639 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
2640 anum = 1;
2641 else {
2642 if (euid || Stat(tmps2, &statbuf) < 0 || !S_ISDIR(statbuf.st_mode))
2643 (void)UNLINK(tmps2);
2644 if (!(anum = link(tmps, tmps2)))
2645 anum = UNLINK(tmps);
2646 }
a0d0e21e
LW		 2647 }
2648#endif
2649 SETi( anum >= 0 );
2650 RETURN;
2651}
2652
2653PP(pp_link)
2654{
4e35701f 2655 djSP; dTARGET;
a0d0e21e
LW		 2656#ifdef HAS_LINK
2657 char *tmps2 = POPp;
2658 char *tmps = SvPV(TOPs, na);
2659 TAINT_PROPER("link");
2660 SETi( link(tmps, tmps2) >= 0 );
2661#else
2662 DIE(no_func, "Unsupported function link");
2663#endif
2664 RETURN;
2665}
2666
2667PP(pp_symlink)
2668{
4e35701f 2669 djSP; dTARGET;
a0d0e21e
LW		 2670#ifdef HAS_SYMLINK
2671 char *tmps2 = POPp;
2672 char *tmps = SvPV(TOPs, na);
2673 TAINT_PROPER("symlink");
2674 SETi( symlink(tmps, tmps2) >= 0 );
2675 RETURN;
2676#else
2677 DIE(no_func, "symlink");
2678#endif
2679}
2680
2681PP(pp_readlink)
2682{
4e35701f 2683 djSP; dTARGET;
a0d0e21e
LW		 2684#ifdef HAS_SYMLINK
2685 char *tmps;
46fc3d4c 2686 char buf[MAXPATHLEN];
a0d0e21e 2687 int len;
46fc3d4c 2688
fb73857a 2689#ifndef INCOMPLETE_TAINTS
2690 TAINT;
2691#endif
a0d0e21e
LW		 2692 tmps = POPp;
2693 len = readlink(tmps, buf, sizeof buf);
2694 EXTEND(SP, 1);
2695 if (len < 0)
2696 RETPUSHUNDEF;
2697 PUSHp(buf, len);
2698 RETURN;
2699#else
2700 EXTEND(SP, 1);
2701 RETSETUNDEF; /* just pretend it's a normal file */
2702#endif
2703}
2704
2705#if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
2706static int
2707dooneliner(cmd, filename)
2708char *cmd;
2709char *filename;
2710{
1e422769 2711 char *save_filename = filename;
2712 char *cmdline;
2713 char *s;
760ac839 2714 PerlIO *myfp;
1e422769 2715 int anum = 1;
a0d0e21e 2716
1e422769 2717 New(666, cmdline, strlen(cmd) + (strlen(filename) * 2) + 10, char);
2718 strcpy(cmdline, cmd);
2719 strcat(cmdline, " ");
2720 for (s = cmdline + strlen(cmdline); *filename; ) {
a0d0e21e
LW		 2721 *s++ = '\\';
2722 *s++ = *filename++;
2723 }
2724 strcpy(s, " 2>&1");
3028581b 2725 myfp = PerlProc_popen(cmdline, "r");
1e422769 2726 Safefree(cmdline);
2727
a0d0e21e 2728 if (myfp) {
1e422769 2729 SV *tmpsv = sv_newmortal();
760ac839
LW		 2730 /* Need to save/restore 'rs' ?? */
2731 s = sv_gets(tmpsv, myfp, 0);
3028581b 2732 (void)PerlProc_pclose(myfp);
a0d0e21e 2733 if (s != Nullch) {
1e422769 2734 int e;
2735 for (e = 1;
a0d0e21e 2736#ifdef HAS_SYS_ERRLIST
1e422769 2737 e <= sys_nerr
2738#endif
2739 ; e++)
2740 {
2741 /* you don't see this */
2742 char *errmsg =
2743#ifdef HAS_SYS_ERRLIST
2744 sys_errlist[e]
a0d0e21e 2745#else
1e422769 2746 strerror(e)
a0d0e21e 2747#endif
1e422769 2748 ;
2749 if (!errmsg)
2750 break;
2751 if (instr(s, errmsg)) {
2752 SETERRNO(e,0);
2753 return 0;
2754 }
a0d0e21e 2755 }
748a9306 2756 SETERRNO(0,0);
a0d0e21e
LW		 2757#ifndef EACCES
2758#define EACCES EPERM
2759#endif
1e422769 2760 if (instr(s, "cannot make"))
748a9306 2761 SETERRNO(EEXIST,RMS$_FEX);
1e422769 2762 else if (instr(s, "existing file"))
748a9306 2763 SETERRNO(EEXIST,RMS$_FEX);
1e422769 2764 else if (instr(s, "ile exists"))
748a9306 2765 SETERRNO(EEXIST,RMS$_FEX);
1e422769 2766 else if (instr(s, "non-exist"))
748a9306 2767 SETERRNO(ENOENT,RMS$_FNF);
1e422769 2768 else if (instr(s, "does not exist"))
748a9306 2769 SETERRNO(ENOENT,RMS$_FNF);
1e422769 2770 else if (instr(s, "not empty"))
748a9306 2771 SETERRNO(EBUSY,SS$_DEVOFFLINE);
1e422769 2772 else if (instr(s, "cannot access"))
748a9306 2773 SETERRNO(EACCES,RMS$_PRV);
a0d0e21e 2774 else
748a9306 2775 SETERRNO(EPERM,RMS$_PRV);
a0d0e21e
LW		 2776 return 0;
2777 }
2778 else { /* some mkdirs return no failure indication */
5d94fbed 2779 anum = (Stat(save_filename, &statbuf) >= 0);
a0d0e21e
LW		 2780 if (op->op_type == OP_RMDIR)
2781 anum = !anum;
2782 if (anum)
748a9306 2783 SETERRNO(0,0);
a0d0e21e 2784 else
748a9306 2785 SETERRNO(EACCES,RMS$_PRV); /* a guess */
a0d0e21e
LW		 2786 }
2787 return anum;
2788 }
2789 else
2790 return 0;
2791}
2792#endif
2793
2794PP(pp_mkdir)
2795{
4e35701f 2796 djSP; dTARGET;
a0d0e21e
LW		 2797 int mode = POPi;
2798#ifndef HAS_MKDIR
2799 int oldumask;
2800#endif
2801 char *tmps = SvPV(TOPs, na);
2802
2803 TAINT_PROPER("mkdir");
2804#ifdef HAS_MKDIR
3028581b 2805 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
a0d0e21e
LW		 2806#else
2807 SETi( dooneliner("mkdir", tmps) );
3028581b
GS		 2808 oldumask = PerlLIO_umask(0);
2809 PerlLIO_umask(oldumask);
2810 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
a0d0e21e
LW		 2811#endif
2812 RETURN;
2813}
2814
2815PP(pp_rmdir)
2816{
4e35701f 2817 djSP; dTARGET;
a0d0e21e
LW		 2818 char *tmps;
2819
2820 tmps = POPp;
2821 TAINT_PROPER("rmdir");
2822#ifdef HAS_RMDIR
3028581b 2823 XPUSHi( PerlDir_rmdir(tmps) >= 0 );
a0d0e21e
LW		 2824#else
2825 XPUSHi( dooneliner("rmdir", tmps) );
2826#endif
2827 RETURN;
2828}
2829
2830/* Directory calls. */
2831
2832PP(pp_open_dir)
2833{
4e35701f 2834 djSP;
a0d0e21e
LW		 2835#if defined(Direntry_t) && defined(HAS_READDIR)
2836 char *dirname = POPp;
2837 GV *gv = (GV*)POPs;
2838 register IO *io = GvIOn(gv);
2839
2840 if (!io)
2841 goto nope;
2842
2843 if (IoDIRP(io))
3028581b
GS		 2844 PerlDir_close(IoDIRP(io));
2845 if (!(IoDIRP(io) = PerlDir_open(dirname)))
a0d0e21e
LW		 2846 goto nope;
2847
2848 RETPUSHYES;
2849nope:
2850 if (!errno)
748a9306 2851 SETERRNO(EBADF,RMS$_DIR);
a0d0e21e
LW		 2852 RETPUSHUNDEF;
2853#else
2854 DIE(no_dir_func, "opendir");
2855#endif
2856}
2857
2858PP(pp_readdir)
2859{
4e35701f 2860 djSP;
a0d0e21e
LW		 2861#if defined(Direntry_t) && defined(HAS_READDIR)
2862#ifndef I_DIRENT
2863 Direntry_t *readdir _((DIR *));
2864#endif
2865 register Direntry_t *dp;
2866 GV *gv = (GV*)POPs;
2867 register IO *io = GvIOn(gv);
fb73857a 2868 SV *sv;
a0d0e21e
LW		 2869
2870 if (!io || !IoDIRP(io))
2871 goto nope;
2872
2873 if (GIMME == G_ARRAY) {
2874 /*SUPPRESS 560*/
3028581b 2875 while (dp = (Direntry_t *)PerlDir_read(IoDIRP(io))) {
a0d0e21e 2876#ifdef DIRNAMLEN
fb73857a 2877 sv = newSVpv(dp->d_name, dp->d_namlen);
a0d0e21e 2878#else
fb73857a 2879 sv = newSVpv(dp->d_name, 0);
2880#endif
2881#ifndef INCOMPLETE_TAINTS
2882 SvTAINTED_on(sv);
a0d0e21e 2883#endif
fb73857a 2884 XPUSHs(sv_2mortal(sv));
a0d0e21e
LW		 2885 }
2886 }
2887 else {
3028581b 2888 if (!(dp = (Direntry_t *)PerlDir_read(IoDIRP(io))))
a0d0e21e
LW		 2889 goto nope;
2890#ifdef DIRNAMLEN
fb73857a 2891 sv = newSVpv(dp->d_name, dp->d_namlen);
a0d0e21e 2892#else
fb73857a 2893 sv = newSVpv(dp->d_name, 0);
a0d0e21e 2894#endif
fb73857a 2895#ifndef INCOMPLETE_TAINTS
2896 SvTAINTED_on(sv);
2897#endif
2898 XPUSHs(sv_2mortal(sv));
a0d0e21e
LW		 2899 }
2900 RETURN;
2901
2902nope:
2903 if (!errno)
748a9306 2904 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 2905 if (GIMME == G_ARRAY)
2906 RETURN;
2907 else
2908 RETPUSHUNDEF;
2909#else
2910 DIE(no_dir_func, "readdir");
2911#endif
2912}
2913
2914PP(pp_telldir)
2915{
4e35701f 2916 djSP; dTARGET;
a0d0e21e 2917#if defined(HAS_TELLDIR) || defined(telldir)
8ac85365 2918#if !defined(telldir) && !defined(HAS_TELLDIR_PROTOTYPE) && !defined(DONT_DECLARE_STD)
a0d0e21e
LW		 2919 long telldir _((DIR *));
2920#endif
2921 GV *gv = (GV*)POPs;
2922 register IO *io = GvIOn(gv);
2923
2924 if (!io || !IoDIRP(io))
2925 goto nope;
2926
3028581b 2927 PUSHi( PerlDir_tell(IoDIRP(io)) );
a0d0e21e
LW		 2928 RETURN;
2929nope:
2930 if (!errno)
748a9306 2931 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 2932 RETPUSHUNDEF;
2933#else
2934 DIE(no_dir_func, "telldir");
2935#endif
2936}
2937
2938PP(pp_seekdir)
2939{
4e35701f 2940 djSP;
a0d0e21e
LW		 2941#if defined(HAS_SEEKDIR) || defined(seekdir)
2942 long along = POPl;
2943 GV *gv = (GV*)POPs;
2944 register IO *io = GvIOn(gv);
2945
2946 if (!io || !IoDIRP(io))
2947 goto nope;
2948
3028581b 2949 (void)PerlDir_seek(IoDIRP(io), along);
a0d0e21e
LW		 2950
2951 RETPUSHYES;
2952nope:
2953 if (!errno)
748a9306 2954 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 2955 RETPUSHUNDEF;
2956#else
2957 DIE(no_dir_func, "seekdir");
2958#endif
2959}
2960
2961PP(pp_rewinddir)
2962{
4e35701f 2963 djSP;
a0d0e21e
LW		 2964#if defined(HAS_REWINDDIR) || defined(rewinddir)
2965 GV *gv = (GV*)POPs;
2966 register IO *io = GvIOn(gv);
2967
2968 if (!io || !IoDIRP(io))
2969 goto nope;
2970
3028581b 2971 (void)PerlDir_rewind(IoDIRP(io));
a0d0e21e
LW		 2972 RETPUSHYES;
2973nope:
2974 if (!errno)
748a9306 2975 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 2976 RETPUSHUNDEF;
2977#else
2978 DIE(no_dir_func, "rewinddir");
2979#endif
2980}
2981
2982PP(pp_closedir)
2983{
4e35701f 2984 djSP;
a0d0e21e
LW		 2985#if defined(Direntry_t) && defined(HAS_READDIR)
2986 GV *gv = (GV*)POPs;
2987 register IO *io = GvIOn(gv);
2988
2989 if (!io || !IoDIRP(io))
2990 goto nope;
2991
2992#ifdef VOID_CLOSEDIR
3028581b 2993 PerlDir_close(IoDIRP(io));
a0d0e21e 2994#else
3028581b 2995 if (PerlDir_close(IoDIRP(io)) < 0) {
748a9306 2996 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
a0d0e21e 2997 goto nope;
748a9306 2998 }
a0d0e21e
LW		 2999#endif
3000 IoDIRP(io) = 0;
3001
3002 RETPUSHYES;
3003nope:
3004 if (!errno)
748a9306 3005 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW		 3006 RETPUSHUNDEF;
3007#else
3008 DIE(no_dir_func, "closedir");
3009#endif
3010}
3011
3012/* Process control. */
3013
3014PP(pp_fork)
3015{
44a8e56a 3016#ifdef HAS_FORK
4e35701f 3017 djSP; dTARGET;
a0d0e21e
LW		 3018 int childpid;
3019 GV *tmpgv;
3020
3021 EXTEND(SP, 1);
a0d0e21e
LW		 3022 childpid = fork();
3023 if (childpid < 0)
3024 RETSETUNDEF;
3025 if (!childpid) {
3026 /*SUPPRESS 560*/
3027 if (tmpgv = gv_fetchpv("$", TRUE, SVt_PV))
1e422769 3028 sv_setiv(GvSV(tmpgv), (IV)getpid());
a0d0e21e
LW		 3029 hv_clear(pidstatus); /* no kids, so don't wait for 'em */
3030 }
3031 PUSHi(childpid);
3032 RETURN;
3033#else
3034 DIE(no_func, "Unsupported function fork");
3035#endif
3036}
3037
3038PP(pp_wait)
3039{
2d7a9237 3040#if !defined(DOSISH) || defined(OS2) || defined(WIN32)
4e35701f 3041 djSP; dTARGET;
a0d0e21e
LW		 3042 int childpid;
3043 int argflags;
a0d0e21e 3044
44a8e56a 3045 childpid = wait4pid(-1, &argflags, 0);
f86702cc 3046 STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
44a8e56a 3047 XPUSHi(childpid);
a0d0e21e
LW		 3048 RETURN;
3049#else
3050 DIE(no_func, "Unsupported function wait");
3051#endif
3052}
3053
3054PP(pp_waitpid)
3055{
2d7a9237 3056#if !defined(DOSISH) || defined(OS2) || defined(WIN32)
4e35701f 3057 djSP; dTARGET;
a0d0e21e
LW		 3058 int childpid;
3059 int optype;
3060 int argflags;
a0d0e21e 3061
a0d0e21e
LW		 3062 optype = POPi;
3063 childpid = TOPi;
3064 childpid = wait4pid(childpid, &argflags, optype);
f86702cc 3065 STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
44a8e56a 3066 SETi(childpid);
a0d0e21e
LW		 3067 RETURN;
3068#else
2d7a9237 3069 DIE(no_func, "Unsupported function waitpid");
a0d0e21e
LW		 3070#endif
3071}
3072
3073PP(pp_system)
3074{
4e35701f 3075 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW		 3076 I32 value;
3077 int childpid;
3078 int result;
3079 int status;
ff68c719 3080 Sigsave_t ihand,qhand; /* place to save signals during system() */
a0d0e21e 3081
a0d0e21e
LW		 3082 if (SP - MARK == 1) {
3083 if (tainting) {
3084 char *junk = SvPV(TOPs, na);
3085 TAINT_ENV();
3086 TAINT_PROPER("system");
3087 }
3088 }
1e422769 3089#if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2)
a0d0e21e
LW		 3090 while ((childpid = vfork()) == -1) {
3091 if (errno != EAGAIN) {
3092 value = -1;
3093 SP = ORIGMARK;
3094 PUSHi(value);
3095 RETURN;
3096 }
3097 sleep(5);
3098 }
3099 if (childpid > 0) {
ff68c719 3100 rsignal_save(SIGINT, SIG_IGN, &ihand);
3101 rsignal_save(SIGQUIT, SIG_IGN, &qhand);
748a9306
LW		 3102 do {
3103 result = wait4pid(childpid, &status, 0);
3104 } while (result == -1 && errno == EINTR);
ff68c719 3105 (void)rsignal_restore(SIGINT, &ihand);
3106 (void)rsignal_restore(SIGQUIT, &qhand);
91e9c03f 3107 STATUS_NATIVE_SET(result == -1 ? -1 : status);
a0d0e21e
LW		 3108 do_execfree(); /* free any memory child malloced on vfork */
3109 SP = ORIGMARK;
ff0cee69 3110 PUSHi(STATUS_CURRENT);
a0d0e21e
LW		 3111 RETURN;
3112 }
3113 if (op->op_flags & OPf_STACKED) {
3114 SV *really = *++MARK;
3115 value = (I32)do_aexec(really, MARK, SP);
3116 }
3117 else if (SP - MARK != 1)
3118 value = (I32)do_aexec(Nullsv, MARK, SP);
3119 else {
3120 value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), na));
3121 }
3028581b 3122 PerlProc__exit(-1);
c3293030 3123#else /* ! FORK or VMS or OS/2 */
a0d0e21e
LW		 3124 if (op->op_flags & OPf_STACKED) {
3125 SV *really = *++MARK;
4e35701f 3126 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
a0d0e21e
LW		 3127 }
3128 else if (SP - MARK != 1)
4e35701f 3129 value = (I32)do_aspawn(Nullsv, (void **)MARK, (void **)SP);
a0d0e21e
LW		 3130 else {
3131 value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), na));
3132 }
f86702cc 3133 STATUS_NATIVE_SET(value);
a0d0e21e
LW		 3134 do_execfree();
3135 SP = ORIGMARK;
ff0cee69 3136 PUSHi(STATUS_CURRENT);
a0d0e21e
LW		 3137#endif /* !FORK or VMS */
3138 RETURN;
3139}
3140
3141PP(pp_exec)
3142{
4e35701f 3143 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW		 3144 I32 value;
3145
3146 if (op->op_flags & OPf_STACKED) {
3147 SV *really = *++MARK;
3148 value = (I32)do_aexec(really, MARK, SP);
3149 }
3150 else if (SP - MARK != 1)
3151#ifdef VMS
3152 value = (I32)vms_do_aexec(Nullsv, MARK, SP);
3153#else
3154 value = (I32)do_aexec(Nullsv, MARK, SP);
3155#endif
3156 else {
3157 if (tainting) {
3158 char *junk = SvPV(*SP, na);
3159 TAINT_ENV();
3160 TAINT_PROPER("exec");
3161 }
3162#ifdef VMS
3163 value = (I32)vms_do_exec(SvPVx(sv_mortalcopy(*SP), na));
3164#else
3165 value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), na));
3166#endif
3167 }
3168 SP = ORIGMARK;
3169 PUSHi(value);
3170 RETURN;
3171}
3172
3173PP(pp_kill)
3174{
4e35701f 3175 djSP; dMARK; dTARGET;
a0d0e21e
LW		 3176 I32 value;
3177#ifdef HAS_KILL
3178 value = (I32)apply(op->op_type, MARK, SP);
3179 SP = MARK;
3180 PUSHi(value);
3181 RETURN;
3182#else
3183 DIE(no_func, "Unsupported function kill");
3184#endif
3185}
3186
3187PP(pp_getppid)
3188{
3189#ifdef HAS_GETPPID
4e35701f 3190 djSP; dTARGET;
a0d0e21e
LW		 3191 XPUSHi( getppid() );
3192 RETURN;
3193#else
3194 DIE(no_func, "getppid");
3195#endif
3196}
3197
3198PP(pp_getpgrp)
3199{
3200#ifdef HAS_GETPGRP
4e35701f 3201 djSP; dTARGET;
a0d0e21e
LW		 3202 int pid;
3203 I32 value;
3204
3205 if (MAXARG < 1)
3206 pid = 0;
3207 else
3208 pid = SvIVx(POPs);
c3293030
IZ		 3209#ifdef BSD_GETPGRP
3210 value = (I32)BSD_GETPGRP(pid);
a0d0e21e 3211#else
aa689395 3212 if (pid != 0 && pid != getpid())
a0d0e21e
LW		 3213 DIE("POSIX getpgrp can't take an argument");
3214 value = (I32)getpgrp();
3215#endif
3216 XPUSHi(value);
3217 RETURN;
3218#else
3219 DIE(no_func, "getpgrp()");
3220#endif
3221}
3222
3223PP(pp_setpgrp)
3224{
3225#ifdef HAS_SETPGRP
4e35701f 3226 djSP; dTARGET;
a0d0e21e
LW		 3227 int pgrp;
3228 int pid;
3229 if (MAXARG < 2) {
3230 pgrp = 0;
3231 pid = 0;
3232 }
3233 else {
3234 pgrp = POPi;
3235 pid = TOPi;
3236 }
3237
3238 TAINT_PROPER("setpgrp");
c3293030
IZ		 3239#ifdef BSD_SETPGRP
3240 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
a0d0e21e 3241#else
c90c0ff4 3242 if ((pgrp != 0 && pgrp != getpid()) || (pid != 0 && pid != getpid()))
a0d0e21e 3243 DIE("POSIX setpgrp can't take an argument");
a0d0e21e
LW		 3244 SETi( setpgrp() >= 0 );
3245#endif /* USE_BSDPGRP */
3246 RETURN;
3247#else
3248 DIE(no_func, "setpgrp()");
3249#endif
3250}
3251
3252PP(pp_getpriority)
3253{
4e35701f 3254 djSP; dTARGET;
a0d0e21e
LW		 3255 int which;
3256 int who;
3257#ifdef HAS_GETPRIORITY
3258 who = POPi;
3259 which = TOPi;
3260 SETi( getpriority(which, who) );
3261 RETURN;
3262#else
3263 DIE(no_func, "getpriority()");
3264#endif
3265}
3266
3267PP(pp_setpriority)
3268{
4e35701f 3269 djSP; dTARGET;
a0d0e21e
LW		 3270 int which;
3271 int who;
3272 int niceval;
3273#ifdef HAS_SETPRIORITY
3274 niceval = POPi;
3275 who = POPi;
3276 which = TOPi;
3277 TAINT_PROPER("setpriority");
3278 SETi( setpriority(which, who, niceval) >= 0 );
3279 RETURN;
3280#else
3281 DIE(no_func, "setpriority()");
3282#endif
3283}
3284
3285/* Time calls. */
3286
3287PP(pp_time)
3288{
4e35701f 3289 djSP; dTARGET;
cbdc8872 3290#ifdef BIG_TIME
3291 XPUSHn( time(Null(Time_t*)) );
3292#else
a0d0e21e 3293 XPUSHi( time(Null(Time_t*)) );
cbdc8872 3294#endif
a0d0e21e
LW		 3295 RETURN;
3296}
3297
cd52b7b2 3298/* XXX The POSIX name is CLK_TCK; it is to be preferred
3299 to HZ. Probably. For now, assume that if the system
3300 defines HZ, it does so correctly. (Will this break
3301 on VMS?)
3302 Probably we ought to use _sysconf(_SC_CLK_TCK), if
3303 it's supported. --AD 9/96.
3304*/
3305
a0d0e21e 3306#ifndef HZ
cd52b7b2 3307# ifdef CLK_TCK
3308# define HZ CLK_TCK
3309# else
3310# define HZ 60
3311# endif
a0d0e21e
LW		 3312#endif
3313
3314PP(pp_tms)
3315{
4e35701f 3316 djSP;
a0d0e21e 3317
55497cff 3318#ifndef HAS_TIMES
a0d0e21e
LW		 3319 DIE("times not implemented");
3320#else
3321 EXTEND(SP, 4);
3322
3323#ifndef VMS
3324 (void)times(&timesbuf);
3325#else
3326 (void)times((tbuffer_t *)&timesbuf); /* time.h uses different name for */
3327 /* struct tms, though same data */
3328 /* is returned. */
3329#endif
3330
3331 PUSHs(sv_2mortal(newSVnv(((double)timesbuf.tms_utime)/HZ)));
3332 if (GIMME == G_ARRAY) {
3333 PUSHs(sv_2mortal(newSVnv(((double)timesbuf.tms_stime)/HZ)));
3334 PUSHs(sv_2mortal(newSVnv(((double)timesbuf.tms_cutime)/HZ)));
3335 PUSHs(sv_2mortal(newSVnv(((double)timesbuf.tms_cstime)/HZ)));
3336 }
3337 RETURN;
55497cff 3338#endif /* HAS_TIMES */
a0d0e21e
LW		 3339}
3340
3341PP(pp_localtime)
3342{
3343 return pp_gmtime(ARGS);
3344}
3345
3346PP(pp_gmtime)
3347{
4e35701f 3348 djSP;
a0d0e21e
LW		 3349 Time_t when;
3350 struct tm *tmbuf;
3351 static char *dayname[] = {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
3352 static char *monname[] = {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
3353 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
3354
3355 if (MAXARG < 1)
3356 (void)time(&when);
3357 else
cbdc8872 3358#ifdef BIG_TIME
3359 when = (Time_t)SvNVx(POPs);
3360#else
a0d0e21e 3361 when = (Time_t)SvIVx(POPs);
cbdc8872 3362#endif
a0d0e21e
LW		 3363
3364 if (op->op_type == OP_LOCALTIME)
3365 tmbuf = localtime(&when);
3366 else
3367 tmbuf = gmtime(&when);
3368
3369 EXTEND(SP, 9);
bbce6d69 3370 EXTEND_MORTAL(9);
a0d0e21e
LW		 3371 if (GIMME != G_ARRAY) {
3372 dTARGET;
46fc3d4c 3373 SV *tsv;
a0d0e21e
LW		 3374 if (!tmbuf)
3375 RETPUSHUNDEF;
46fc3d4c 3376 tsv = newSVpvf("%s %s %2d %02d:%02d:%02d %d",
3377 dayname[tmbuf->tm_wday],
3378 monname[tmbuf->tm_mon],
3379 tmbuf->tm_mday,
3380 tmbuf->tm_hour,
3381 tmbuf->tm_min,
3382 tmbuf->tm_sec,
3383 tmbuf->tm_year + 1900);
3384 PUSHs(sv_2mortal(tsv));
a0d0e21e
LW		 3385 }
3386 else if (tmbuf) {
3387 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_sec)));
3388 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_min)));
3389 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_hour)));
3390 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_mday)));
3391 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_mon)));
3392 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_year)));
3393 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_wday)));
3394 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_yday)));
3395 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_isdst)));
3396 }
3397 RETURN;
3398}
3399
3400PP(pp_alarm)
3401{
4e35701f 3402 djSP; dTARGET;
a0d0e21e
LW		 3403 int anum;
3404#ifdef HAS_ALARM
3405 anum = POPi;
3406 anum = alarm((unsigned int)anum);
3407 EXTEND(SP, 1);
3408 if (anum < 0)
3409 RETPUSHUNDEF;
3410 PUSHi((I32)anum);
3411 RETURN;
3412#else
3413 DIE(no_func, "Unsupported function alarm");
a0d0e21e
LW		 3414#endif
3415}
3416
3417PP(pp_sleep)
3418{
4e35701f 3419 djSP; dTARGET;
a0d0e21e
LW		 3420 I32 duration;
3421 Time_t lasttime;
3422 Time_t when;
3423
3424 (void)time(&lasttime);
3425 if (MAXARG < 1)
76c32331 3426 Pause();
a0d0e21e
LW		 3427 else {
3428 duration = POPi;
3429 sleep((unsigned int)duration);
3430 }
3431 (void)time(&when);
3432 XPUSHi(when - lasttime);
3433 RETURN;
3434}
3435
3436/* Shared memory. */
3437
3438PP(pp_shmget)
3439{
3440 return pp_semget(ARGS);
3441}
3442
3443PP(pp_shmctl)
3444{
3445 return pp_semctl(ARGS);
3446}
3447
3448PP(pp_shmread)
3449{
3450 return pp_shmwrite(ARGS);
3451}
3452
3453PP(pp_shmwrite)
3454{
3455#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 3456 djSP; dMARK; dTARGET;
a0d0e21e
LW		 3457 I32 value = (I32)(do_shmio(op->op_type, MARK, SP) >= 0);
3458 SP = MARK;
3459 PUSHi(value);
3460 RETURN;
3461#else
748a9306 3462 return pp_semget(ARGS);
a0d0e21e
LW		 3463#endif
3464}
3465
3466/* Message passing. */
3467
3468PP(pp_msgget)
3469{
3470 return pp_semget(ARGS);
3471}
3472
3473PP(pp_msgctl)
3474{
3475 return pp_semctl(ARGS);
3476}
3477
3478PP(pp_msgsnd)
3479{
3480#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 3481 djSP; dMARK; dTARGET;
a0d0e21e
LW		 3482 I32 value = (I32)(do_msgsnd(MARK, SP) >= 0);
3483 SP = MARK;
3484 PUSHi(value);
3485 RETURN;
3486#else
748a9306 3487 return pp_semget(ARGS);
a0d0e21e
LW		 3488#endif
3489}
3490
3491PP(pp_msgrcv)
3492{
3493#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 3494 djSP; dMARK; dTARGET;
a0d0e21e
LW		 3495 I32 value = (I32)(do_msgrcv(MARK, SP) >= 0);
3496 SP = MARK;
3497 PUSHi(value);
3498 RETURN;
3499#else
748a9306 3500 return pp_semget(ARGS);
a0d0e21e
LW		 3501#endif
3502}
3503
3504/* Semaphores. */
3505
3506PP(pp_semget)
3507{
3508#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 3509 djSP; dMARK; dTARGET;
a0d0e21e
LW		 3510 int anum = do_ipcget(op->op_type, MARK, SP);
3511 SP = MARK;
3512 if (anum == -1)
3513 RETPUSHUNDEF;
3514 PUSHi(anum);
3515 RETURN;
3516#else
3517 DIE("System V IPC is not implemented on this machine");
3518#endif
3519}
3520
3521PP(pp_semctl)
3522{
3523#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 3524 djSP; dMARK; dTARGET;
a0d0e21e
LW		 3525 int anum = do_ipcctl(op->op_type, MARK, SP);
3526 SP = MARK;
3527 if (anum == -1)
3528 RETSETUNDEF;
3529 if (anum != 0) {
3530 PUSHi(anum);
3531 }
3532 else {
8903cb82 3533 PUSHp(zero_but_true, ZBTLEN);
a0d0e21e
LW		 3534 }
3535 RETURN;
3536#else
748a9306 3537 return pp_semget(ARGS);
a0d0e21e
LW		 3538#endif
3539}
3540
3541PP(pp_semop)
3542{
3543#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 3544 djSP; dMARK; dTARGET;
a0d0e21e
LW		 3545 I32 value = (I32)(do_semop(MARK, SP) >= 0);
3546 SP = MARK;
3547 PUSHi(value);
3548 RETURN;
3549#else
748a9306 3550 return pp_semget(ARGS);
a0d0e21e
LW		 3551#endif
3552}
3553
3554/* Get system info. */
3555
3556PP(pp_ghbyname)
3557{
3558#ifdef HAS_SOCKET
3559 return pp_ghostent(ARGS);
3560#else
3561 DIE(no_sock_func, "gethostbyname");
3562#endif
3563}
3564
3565PP(pp_ghbyaddr)
3566{
3567#ifdef HAS_SOCKET
3568 return pp_ghostent(ARGS);
3569#else
3570 DIE(no_sock_func, "gethostbyaddr");
3571#endif
3572}
3573
3574PP(pp_ghostent)
3575{
4e35701f 3576 djSP;
a0d0e21e
LW		 3577#ifdef HAS_SOCKET
3578 I32 which = op->op_type;
3579 register char **elem;
3580 register SV *sv;
8ac85365 3581#if defined(HAS_GETHOSTENT) && !defined(DONT_DECLARE_STD)
4599a1de
JH		 3582 struct hostent *PerlSock_gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
3583 struct hostent *PerlSock_gethostbyname(Netdb_name_t);
31da6858 3584#ifndef PerlSock_gethostent
3028581b 3585 struct hostent *PerlSock_gethostent(void);
a0d0e21e 3586#endif
31da6858 3587#endif
a0d0e21e
LW		 3588 struct hostent *hent;
3589 unsigned long len;
3590
3591 EXTEND(SP, 10);
3592 if (which == OP_GHBYNAME) {
3028581b 3593 hent = PerlSock_gethostbyname(POPp);
a0d0e21e
LW		 3594 }
3595 else if (which == OP_GHBYADDR) {
3596 int addrtype = POPi;
748a9306 3597 SV *addrsv = POPs;
a0d0e21e 3598 STRLEN addrlen;
4599a1de 3599 Netdb_host_t addr = (Netdb_host_t) SvPV(addrsv, addrlen);
a0d0e21e 3600
4599a1de 3601 hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
a0d0e21e
LW		 3602 }
3603 else
3604#ifdef HAS_GETHOSTENT
3028581b 3605 hent = PerlSock_gethostent();
a0d0e21e
LW		 3606#else
3607 DIE("gethostent not implemented");
3608#endif
3609
3610#ifdef HOST_NOT_FOUND
3611 if (!hent)
f86702cc 3612 STATUS_NATIVE_SET(h_errno);
a0d0e21e
LW		 3613#endif
3614
3615 if (GIMME != G_ARRAY) {
3616 PUSHs(sv = sv_newmortal());
3617 if (hent) {
3618 if (which == OP_GHBYNAME) {
fd0af264 3619 if (hent->h_addr)
3620 sv_setpvn(sv, hent->h_addr, hent->h_length);
a0d0e21e
LW		 3621 }
3622 else
3623 sv_setpv(sv, (char*)hent->h_name);
3624 }
3625 RETURN;
3626 }
3627
3628 if (hent) {
3629 PUSHs(sv = sv_mortalcopy(&sv_no));
3630 sv_setpv(sv, (char*)hent->h_name);
3631 PUSHs(sv = sv_mortalcopy(&sv_no));
3632 for (elem = hent->h_aliases; elem && *elem; elem++) {
3633 sv_catpv(sv, *elem);
3634 if (elem[1])
3635 sv_catpvn(sv, " ", 1);
3636 }
3637 PUSHs(sv = sv_mortalcopy(&sv_no));
1e422769 3638 sv_setiv(sv, (IV)hent->h_addrtype);
a0d0e21e
LW		 3639 PUSHs(sv = sv_mortalcopy(&sv_no));
3640 len = hent->h_length;
1e422769 3641 sv_setiv(sv, (IV)len);
a0d0e21e
LW		 3642#ifdef h_addr
3643 for (elem = hent->h_addr_list; elem && *elem; elem++) {
3644 XPUSHs(sv = sv_mortalcopy(&sv_no));
3645 sv_setpvn(sv, *elem, len);
3646 }
3647#else
3648 PUSHs(sv = sv_mortalcopy(&sv_no));
fd0af264 3649 if (hent->h_addr)
3650 sv_setpvn(sv, hent->h_addr, len);
a0d0e21e
LW		 3651#endif /* h_addr */
3652 }
3653 RETURN;
3654#else
3655 DIE(no_sock_func, "gethostent");
3656#endif
3657}
3658
3659PP(pp_gnbyname)
3660{
3661#ifdef HAS_SOCKET
3662 return pp_gnetent(ARGS);
3663#else
3664 DIE(no_sock_func, "getnetbyname");
3665#endif
3666}
3667
3668PP(pp_gnbyaddr)
3669{
3670#ifdef HAS_SOCKET
3671 return pp_gnetent(ARGS);
3672#else
3673 DIE(no_sock_func, "getnetbyaddr");
3674#endif
3675}
3676
3677PP(pp_gnetent)
3678{
4e35701f 3679 djSP;
a0d0e21e
LW		 3680#ifdef HAS_SOCKET
3681 I32 which = op->op_type;
3682 register char **elem;
3683 register SV *sv;
c09156bb 3684#ifdef NETDB_H_OMITS_GETNET
4599a1de
JH		 3685 struct netent *getnetbyaddr(Netdb_net_t, int);
3686 struct netent *getnetbyname(Netdb_name_t);
8ac85365
NIS		 3687 struct netent *getnetent(void);
3688#endif
a0d0e21e
LW		 3689 struct netent *nent;
3690
3691 if (which == OP_GNBYNAME)
3692 nent = getnetbyname(POPp);
3693 else if (which == OP_GNBYADDR) {
3694 int addrtype = POPi;
4599a1de 3695 Netdb_net_t addr = (Netdb_net_t) U_L(POPn);
3fd537d4 3696 nent = getnetbyaddr(addr, addrtype);
a0d0e21e
LW		 3697 }
3698 else
3699 nent = getnetent();
3700
3701 EXTEND(SP, 4);
3702 if (GIMME != G_ARRAY) {
3703 PUSHs(sv = sv_newmortal());
3704 if (nent) {
3705 if (which == OP_GNBYNAME)
1e422769 3706 sv_setiv(sv, (IV)nent->n_net);
a0d0e21e
LW		 3707 else
3708 sv_setpv(sv, nent->n_name);
3709 }
3710 RETURN;
3711 }
3712
3713 if (nent) {
3714 PUSHs(sv = sv_mortalcopy(&sv_no));
3715 sv_setpv(sv, nent->n_name);
3716 PUSHs(sv = sv_mortalcopy(&sv_no));
c90c0ff4 3717 for (elem = nent->n_aliases; elem && *elem; elem++) {
a0d0e21e
LW		 3718 sv_catpv(sv, *elem);
3719 if (elem[1])
3720 sv_catpvn(sv, " ", 1);
3721 }
3722 PUSHs(sv = sv_mortalcopy(&sv_no));
1e422769 3723 sv_setiv(sv, (IV)nent->n_addrtype);
a0d0e21e 3724 PUSHs(sv = sv_mortalcopy(&sv_no));
1e422769 3725 sv_setiv(sv, (IV)nent->n_net);
a0d0e21e
LW		 3726 }
3727
3728 RETURN;
3729#else
3730 DIE(no_sock_func, "getnetent");
3731#endif
3732}
3733
3734PP(pp_gpbyname)
3735{
3736#ifdef HAS_SOCKET
3737 return pp_gprotoent(ARGS);
3738#else
3739 DIE(no_sock_func, "getprotobyname");
3740#endif
3741}
3742
3743PP(pp_gpbynumber)
3744{
3745#ifdef HAS_SOCKET
3746 return pp_gprotoent(ARGS);
3747#else
3748 DIE(no_sock_func, "getprotobynumber");
3749#endif
3750}
3751
3752PP(pp_gprotoent)
3753{
4e35701f 3754 djSP;
a0d0e21e
LW		 3755#ifdef HAS_SOCKET
3756 I32 which = op->op_type;
3757 register char **elem;
8ac85365
NIS		 3758 register SV *sv;
3759#ifndef DONT_DECLARE_STD
4599a1de 3760 struct protoent *PerlSock_getprotobyname(Netdb_name_t);
3028581b 3761 struct protoent *PerlSock_getprotobynumber(int);
31da6858 3762#ifndef PerlSock_getprotoent
3028581b 3763 struct protoent *PerlSock_getprotoent(void);
8ac85365 3764#endif
31da6858 3765#endif
a0d0e21e
LW		 3766 struct protoent *pent;
3767
3768 if (which == OP_GPBYNAME)
3028581b 3769 pent = PerlSock_getprotobyname(POPp);
a0d0e21e 3770 else if (which == OP_GPBYNUMBER)
3028581b 3771 pent = PerlSock_getprotobynumber(POPi);
a0d0e21e 3772 else
3028581b 3773 pent = PerlSock_getprotoent();
a0d0e21e
LW		 3774
3775 EXTEND(SP, 3);
3776 if (GIMME != G_ARRAY) {
3777 PUSHs(sv = sv_newmortal());
3778 if (pent) {
3779 if (which == OP_GPBYNAME)
1e422769 3780 sv_setiv(sv, (IV)pent->p_proto);
a0d0e21e
LW		 3781 else
3782 sv_setpv(sv, pent->p_name);
3783 }
3784 RETURN;
3785 }
3786
3787 if (pent) {
3788 PUSHs(sv = sv_mortalcopy(&sv_no));
3789 sv_setpv(sv, pent->p_name);
3790 PUSHs(sv = sv_mortalcopy(&sv_no));
c90c0ff4 3791 for (elem = pent->p_aliases; elem && *elem; elem++) {
a0d0e21e
LW		 3792 sv_catpv(sv, *elem);
3793 if (elem[1])
3794 sv_catpvn(sv, " ", 1);
3795 }
3796 PUSHs(sv = sv_mortalcopy(&sv_no));
1e422769 3797 sv_setiv(sv, (IV)pent->p_proto);
a0d0e21e
LW		 3798 }
3799
3800 RETURN;
3801#else
3802 DIE(no_sock_func, "getprotoent");
3803#endif
3804}
3805
3806PP(pp_gsbyname)
3807{
3808#ifdef HAS_SOCKET
3809 return pp_gservent(ARGS);
3810#else
3811 DIE(no_sock_func, "getservbyname");
3812#endif
3813}
3814
3815PP(pp_gsbyport)
3816{
3817#ifdef HAS_SOCKET
3818 return pp_gservent(ARGS);
3819#else
3820 DIE(no_sock_func, "getservbyport");
3821#endif
3822}
3823
3824PP(pp_gservent)
3825{
4e35701f 3826 djSP;
a0d0e21e
LW		 3827#ifdef HAS_SOCKET
3828 I32 which = op->op_type;
3829 register char **elem;
3830 register SV *sv;
8ac85365 3831#ifndef DONT_DECLARE_STD
4599a1de
JH		 3832 struct servent *PerlSock_getservbyname(Netdb_name_t, Netdb_name_t);
3833 struct servent *PerlSock_getservbyport(int, Netdb_name_t);
31da6858 3834#ifndef PerlSock_getservent
3028581b 3835 struct servent *PerlSock_getservent(void);
8ac85365 3836#endif
31da6858 3837#endif
a0d0e21e
LW		 3838 struct servent *sent;
3839
3840 if (which == OP_GSBYNAME) {
3841 char *proto = POPp;
3842 char *name = POPp;
3843
3844 if (proto && !*proto)
3845 proto = Nullch;
3846
3028581b 3847 sent = PerlSock_getservbyname(name, proto);
a0d0e21e
LW		 3848 }
3849 else if (which == OP_GSBYPORT) {
3850 char *proto = POPp;
36477c24 3851 unsigned short port = POPu;
a0d0e21e 3852
36477c24 3853#ifdef HAS_HTONS
3028581b 3854 port = PerlSock_htons(port);
36477c24 3855#endif
3028581b 3856 sent = PerlSock_getservbyport(port, proto);
a0d0e21e
LW		 3857 }
3858 else
3028581b 3859 sent = PerlSock_getservent();
a0d0e21e
LW		 3860
3861 EXTEND(SP, 4);
3862 if (GIMME != G_ARRAY) {
3863 PUSHs(sv = sv_newmortal());
3864 if (sent) {
3865 if (which == OP_GSBYNAME) {
3866#ifdef HAS_NTOHS
3028581b 3867 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
a0d0e21e 3868#else
1e422769 3869 sv_setiv(sv, (IV)(sent->s_port));
a0d0e21e
LW		 3870#endif
3871 }
3872 else
3873 sv_setpv(sv, sent->s_name);
3874 }
3875 RETURN;
3876 }
3877
3878 if (sent) {
3879 PUSHs(sv = sv_mortalcopy(&sv_no));
3880 sv_setpv(sv, sent->s_name);
3881 PUSHs(sv = sv_mortalcopy(&sv_no));
c90c0ff4 3882 for (elem = sent->s_aliases; elem && *elem; elem++) {
a0d0e21e
LW		 3883 sv_catpv(sv, *elem);
3884 if (elem[1])
3885 sv_catpvn(sv, " ", 1);
3886 }
3887 PUSHs(sv = sv_mortalcopy(&sv_no));
3888#ifdef HAS_NTOHS
1e422769 3889 sv_setiv(sv, (IV)ntohs(sent->s_port));
a0d0e21e 3890#else
1e422769 3891 sv_setiv(sv, (IV)(sent->s_port));
a0d0e21e
LW		 3892#endif
3893 PUSHs(sv = sv_mortalcopy(&sv_no));
3894 sv_setpv(sv, sent->s_proto);
3895 }
3896
3897 RETURN;
3898#else
3899 DIE(no_sock_func, "getservent");
3900#endif
3901}
3902
3903PP(pp_shostent)
3904{
4e35701f 3905 djSP;
a0d0e21e
LW		 3906#ifdef HAS_SOCKET
3907 sethostent(TOPi);
3908 RETSETYES;
3909#else
3910 DIE(no_sock_func, "sethostent");
3911#endif
3912}
3913
3914PP(pp_snetent)
3915{
4e35701f 3916 djSP;
a0d0e21e
LW		 3917#ifdef HAS_SOCKET
3918 setnetent(TOPi);
3919 RETSETYES;
3920#else
3921 DIE(no_sock_func, "setnetent");
3922#endif
3923}
3924
3925PP(pp_sprotoent)
3926{
4e35701f 3927 djSP;
a0d0e21e
LW		 3928#ifdef HAS_SOCKET
3929 setprotoent(TOPi);
3930 RETSETYES;
3931#else
3932 DIE(no_sock_func, "setprotoent");
3933#endif
3934}
3935
3936PP(pp_sservent)
3937{
4e35701f 3938 djSP;
a0d0e21e
LW		 3939#ifdef HAS_SOCKET
3940 setservent(TOPi);
3941 RETSETYES;
3942#else
3943 DIE(no_sock_func, "setservent");
3944#endif
3945}
3946
3947PP(pp_ehostent)
3948{
4e35701f 3949 djSP;
a0d0e21e
LW		 3950#ifdef HAS_SOCKET
3951 endhostent();
3952 EXTEND(sp,1);
3953 RETPUSHYES;
3954#else
3955 DIE(no_sock_func, "endhostent");
3956#endif
3957}
3958
3959PP(pp_enetent)
3960{
4e35701f 3961 djSP;
a0d0e21e
LW		 3962#ifdef HAS_SOCKET
3963 endnetent();
3964 EXTEND(sp,1);
3965 RETPUSHYES;
3966#else
3967 DIE(no_sock_func, "endnetent");
3968#endif
3969}
3970
3971PP(pp_eprotoent)
3972{
4e35701f 3973 djSP;
a0d0e21e
LW		 3974#ifdef HAS_SOCKET
3975 endprotoent();
3976 EXTEND(sp,1);
3977 RETPUSHYES;
3978#else
3979 DIE(no_sock_func, "endprotoent");
3980#endif
3981}
3982
3983PP(pp_eservent)
3984{
4e35701f 3985 djSP;
a0d0e21e
LW		 3986#ifdef HAS_SOCKET
3987 endservent();
3988 EXTEND(sp,1);
3989 RETPUSHYES;
3990#else
3991 DIE(no_sock_func, "endservent");
3992#endif
3993}
3994
3995PP(pp_gpwnam)
3996{
3997#ifdef HAS_PASSWD
3998 return pp_gpwent(ARGS);
3999#else
4000 DIE(no_func, "getpwnam");
4001#endif
4002}
4003
4004PP(pp_gpwuid)
4005{
4006#ifdef HAS_PASSWD
4007 return pp_gpwent(ARGS);
4008#else
4009 DIE(no_func, "getpwuid");
4010#endif
4011}
4012
4013PP(pp_gpwent)
4014{
4e35701f 4015 djSP;
a0d0e21e
LW		 4016#ifdef HAS_PASSWD
4017 I32 which = op->op_type;
4018 register SV *sv;
4019 struct passwd *pwent;
4020
4021 if (which == OP_GPWNAM)
4022 pwent = getpwnam(POPp);
4023 else if (which == OP_GPWUID)
4024 pwent = getpwuid(POPi);
4025 else
4026 pwent = (struct passwd *)getpwent();
4027
4028 EXTEND(SP, 10);
4029 if (GIMME != G_ARRAY) {
4030 PUSHs(sv = sv_newmortal());
4031 if (pwent) {
4032 if (which == OP_GPWNAM)
1e422769 4033 sv_setiv(sv, (IV)pwent->pw_uid);
a0d0e21e
LW		 4034 else
4035 sv_setpv(sv, pwent->pw_name);
4036 }
4037 RETURN;
4038 }
4039
4040 if (pwent) {
4041 PUSHs(sv = sv_mortalcopy(&sv_no));
4042 sv_setpv(sv, pwent->pw_name);
4043 PUSHs(sv = sv_mortalcopy(&sv_no));
4044 sv_setpv(sv, pwent->pw_passwd);
4045 PUSHs(sv = sv_mortalcopy(&sv_no));
1e422769 4046 sv_setiv(sv, (IV)pwent->pw_uid);
a0d0e21e 4047 PUSHs(sv = sv_mortalcopy(&sv_no));
1e422769 4048 sv_setiv(sv, (IV)pwent->pw_gid);
a0d0e21e
LW		 4049 PUSHs(sv = sv_mortalcopy(&sv_no));
4050#ifdef PWCHANGE
1e422769 4051 sv_setiv(sv, (IV)pwent->pw_change);
a0d0e21e
LW		 4052#else
4053#ifdef PWQUOTA
1e422769 4054 sv_setiv(sv, (IV)pwent->pw_quota);
a0d0e21e
LW		 4055#else
4056#ifdef PWAGE
4057 sv_setpv(sv, pwent->pw_age);
4058#endif
4059#endif
4060#endif
4061 PUSHs(sv = sv_mortalcopy(&sv_no));
4062#ifdef PWCLASS
4063 sv_setpv(sv, pwent->pw_class);
4064#else
4065#ifdef PWCOMMENT
4066 sv_setpv(sv, pwent->pw_comment);
4067#endif
4068#endif
4069 PUSHs(sv = sv_mortalcopy(&sv_no));
4070 sv_setpv(sv, pwent->pw_gecos);
fb73857a 4071#ifndef INCOMPLETE_TAINTS
4072 SvTAINTED_on(sv);
4073#endif
a0d0e21e
LW		 4074 PUSHs(sv = sv_mortalcopy(&sv_no));
4075 sv_setpv(sv, pwent->pw_dir);
4076 PUSHs(sv = sv_mortalcopy(&sv_no));
4077 sv_setpv(sv, pwent->pw_shell);
4078#ifdef PWEXPIRE
4079 PUSHs(sv = sv_mortalcopy(&sv_no));
1e422769 4080 sv_setiv(sv, (IV)pwent->pw_expire);
a0d0e21e
LW		 4081#endif
4082 }
4083 RETURN;
4084#else
4085 DIE(no_func, "getpwent");
4086#endif
4087}
4088
4089PP(pp_spwent)
4090{
4e35701f 4091 djSP;
5aabfad6 4092#if defined(HAS_PASSWD) && !defined(CYGWIN32)
a0d0e21e
LW		 4093 setpwent();
4094 RETPUSHYES;
4095#else
4096 DIE(no_func, "setpwent");
4097#endif
4098}
4099
4100PP(pp_epwent)
4101{
4e35701f 4102 djSP;
a0d0e21e
LW		 4103#ifdef HAS_PASSWD
4104 endpwent();
4105 RETPUSHYES;
4106#else
4107 DIE(no_func, "endpwent");
4108#endif
4109}
4110
4111PP(pp_ggrnam)
4112{
4113#ifdef HAS_GROUP
4114 return pp_ggrent(ARGS);
4115#else
4116 DIE(no_func, "getgrnam");
4117#endif
4118}
4119
4120PP(pp_ggrgid)
4121{
4122#ifdef HAS_GROUP
4123 return pp_ggrent(ARGS);
4124#else
4125 DIE(no_func, "getgrgid");
4126#endif
4127}
4128
4129PP(pp_ggrent)
4130{
4e35701f 4131 djSP;
a0d0e21e
LW		 4132#ifdef HAS_GROUP
4133 I32 which = op->op_type;
4134 register char **elem;
4135 register SV *sv;
4136 struct group *grent;
4137
4138 if (which == OP_GGRNAM)
4139 grent = (struct group *)getgrnam(POPp);
4140 else if (which == OP_GGRGID)
4141 grent = (struct group *)getgrgid(POPi);
4142 else
4143 grent = (struct group *)getgrent();
4144
4145 EXTEND(SP, 4);
4146 if (GIMME != G_ARRAY) {
4147 PUSHs(sv = sv_newmortal());
4148 if (grent) {
4149 if (which == OP_GGRNAM)
1e422769 4150 sv_setiv(sv, (IV)grent->gr_gid);
a0d0e21e
LW		 4151 else
4152 sv_setpv(sv, grent->gr_name);
4153 }
4154 RETURN;
4155 }
4156
4157 if (grent) {
4158 PUSHs(sv = sv_mortalcopy(&sv_no));
4159 sv_setpv(sv, grent->gr_name);
4160 PUSHs(sv = sv_mortalcopy(&sv_no));
4161 sv_setpv(sv, grent->gr_passwd);
4162 PUSHs(sv = sv_mortalcopy(&sv_no));
1e422769 4163 sv_setiv(sv, (IV)grent->gr_gid);
a0d0e21e 4164 PUSHs(sv = sv_mortalcopy(&sv_no));
c90c0ff4 4165 for (elem = grent->gr_mem; elem && *elem; elem++) {
a0d0e21e
LW		 4166 sv_catpv(sv, *elem);
4167 if (elem[1])
4168 sv_catpvn(sv, " ", 1);
4169 }
4170 }
4171
4172 RETURN;
4173#else
4174 DIE(no_func, "getgrent");
4175#endif
4176}
4177
4178PP(pp_sgrent)
4179{
4e35701f 4180 djSP;
a0d0e21e
LW		 4181#ifdef HAS_GROUP
4182 setgrent();
4183 RETPUSHYES;
4184#else
4185 DIE(no_func, "setgrent");
4186#endif
4187}
4188
4189PP(pp_egrent)
4190{
4e35701f 4191 djSP;
a0d0e21e
LW		 4192#ifdef HAS_GROUP
4193 endgrent();
4194 RETPUSHYES;
4195#else
4196 DIE(no_func, "endgrent");
4197#endif
4198}
4199
4200PP(pp_getlogin)
4201{
4e35701f 4202 djSP; dTARGET;
a0d0e21e
LW		 4203#ifdef HAS_GETLOGIN
4204 char *tmps;
4205 EXTEND(SP, 1);
4206 if (!(tmps = getlogin()))
4207 RETPUSHUNDEF;
4208 PUSHp(tmps, strlen(tmps));
4209 RETURN;
4210#else
4211 DIE(no_func, "getlogin");
4212#endif
4213}
4214
4215/* Miscellaneous. */
4216
4217PP(pp_syscall)
4218{
8ac85365 4219#ifdef HAS_SYSCALL
4e35701f 4220 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW		 4221 register I32 items = SP - MARK;
4222 unsigned long a[20];
4223 register I32 i = 0;
4224 I32 retval = -1;
748a9306 4225 MAGIC *mg;
a0d0e21e
LW		 4226
4227 if (tainting) {
4228 while (++MARK <= SP) {
bbce6d69 4229 if (SvTAINTED(*MARK)) {
4230 TAINT;
4231 break;
4232 }
a0d0e21e
LW		 4233 }
4234 MARK = ORIGMARK;
4235 TAINT_PROPER("syscall");
4236 }
4237
4238 /* This probably won't work on machines where sizeof(long) != sizeof(int)
4239 * or where sizeof(long) != sizeof(char*). But such machines will
4240 * not likely have syscall implemented either, so who cares?
4241 */
4242 while (++MARK <= SP) {
4243 if (SvNIOK(*MARK) || !i)
4244 a[i++] = SvIV(*MARK);
748a9306
LW		 4245 else if (*MARK == &sv_undef)
4246 a[i++] = 0;
4247 else
4248 a[i++] = (unsigned long)SvPV_force(*MARK, na);
a0d0e21e
LW		 4249 if (i > 15)
4250 break;
4251 }
4252 switch (items) {
4253 default:
4254 DIE("Too many args to syscall");
4255 case 0:
4256 DIE("Too few args to syscall");
4257 case 1:
4258 retval = syscall(a[0]);
4259 break;
4260 case 2:
4261 retval = syscall(a[0],a[1]);
4262 break;
4263 case 3:
4264 retval = syscall(a[0],a[1],a[2]);
4265 break;
4266 case 4:
4267 retval = syscall(a[0],a[1],a[2],a[3]);
4268 break;
4269 case 5:
4270 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
4271 break;
4272 case 6:
4273 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
4274 break;
4275 case 7:
4276 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
4277 break;
4278 case 8:
4279 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
4280 break;
4281#ifdef atarist
4282 case 9:
4283 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
4284 break;
4285 case 10:
4286 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
4287 break;
4288 case 11:
4289 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
4290 a[10]);
4291 break;
4292 case 12:
4293 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
4294 a[10],a[11]);
4295 break;
4296 case 13:
4297 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
4298 a[10],a[11],a[12]);
4299 break;
4300 case 14:
4301 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
4302 a[10],a[11],a[12],a[13]);
4303 break;
4304#endif /* atarist */
4305 }
4306 SP = ORIGMARK;
4307 PUSHi(retval);
4308 RETURN;
4309#else
4310 DIE(no_func, "syscall");
4311#endif
4312}
4313
ff68c719 4314#ifdef FCNTL_EMULATE_FLOCK
4315
4316/* XXX Emulate flock() with fcntl().
4317 What's really needed is a good file locking module.
4318*/
4319
4320static int
8ac85365 4321fcntl_emulate_flock(int fd, int operation)
ff68c719 4322{
4323 struct flock flock;
4324
4325 switch (operation & ~LOCK_NB) {
4326 case LOCK_SH:
4327 flock.l_type = F_RDLCK;
4328 break;
4329 case LOCK_EX:
4330 flock.l_type = F_WRLCK;
4331 break;
4332 case LOCK_UN:
4333 flock.l_type = F_UNLCK;
4334 break;
4335 default:
4336 errno = EINVAL;
4337 return -1;
4338 }
4339 flock.l_whence = SEEK_SET;
4340 flock.l_start = flock.l_len = 0L;
4341
4342 return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
4343}
4344
4345#endif /* FCNTL_EMULATE_FLOCK */
4346
4347#ifdef LOCKF_EMULATE_FLOCK
16d20bd9
AD		 4348
4349/* XXX Emulate flock() with lockf(). This is just to increase
4350 portability of scripts. The calls are not completely
4351 interchangeable. What's really needed is a good file
4352 locking module.
4353*/
4354
76c32331 4355/* The lockf() constants might have been defined in <unistd.h>.
4356 Unfortunately, <unistd.h> causes troubles on some mixed
4357 (BSD/POSIX) systems, such as SunOS 4.1.3.
16d20bd9
AD		 4358
4359 Further, the lockf() constants aren't POSIX, so they might not be
4360 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
4361 just stick in the SVID values and be done with it. Sigh.
4362*/
4363
4364# ifndef F_ULOCK
4365# define F_ULOCK 0 /* Unlock a previously locked region */
4366# endif
4367# ifndef F_LOCK
4368# define F_LOCK 1 /* Lock a region for exclusive use */
4369# endif
4370# ifndef F_TLOCK
4371# define F_TLOCK 2 /* Test and lock a region for exclusive use */
4372# endif
4373# ifndef F_TEST
4374# define F_TEST 3 /* Test a region for other processes locks */
4375# endif
4376
55497cff 4377static int
16d20bd9
AD		 4378lockf_emulate_flock (fd, operation)
4379int fd;
4380int operation;
4381{
4382 int i;
84902520
TB		 4383 int save_errno;
4384 Off_t pos;
4385
4386 /* flock locks entire file so for lockf we need to do the same */
4387 save_errno = errno;
3028581b 4388 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
84902520 4389 if (pos > 0) /* is seekable and needs to be repositioned */
3028581b 4390 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
08b714dd 4391 pos = -1; /* seek failed, so don't seek back afterwards */
84902520
TB		 4392 errno = save_errno;
4393
16d20bd9
AD		 4394 switch (operation) {
4395
4396 /* LOCK_SH - get a shared lock */
4397 case LOCK_SH:
4398 /* LOCK_EX - get an exclusive lock */
4399 case LOCK_EX:
4400 i = lockf (fd, F_LOCK, 0);
4401 break;
4402
4403 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
4404 case LOCK_SH|LOCK_NB:
4405 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
4406 case LOCK_EX|LOCK_NB:
4407 i = lockf (fd, F_TLOCK, 0);
4408 if (i == -1)
4409 if ((errno == EAGAIN) || (errno == EACCES))
4410 errno = EWOULDBLOCK;
4411 break;
4412
ff68c719 4413 /* LOCK_UN - unlock (non-blocking is a no-op) */
16d20bd9 4414 case LOCK_UN:
ff68c719 4415 case LOCK_UN|LOCK_NB:
16d20bd9
AD		 4416 i = lockf (fd, F_ULOCK, 0);
4417 break;
4418
4419 /* Default - can't decipher operation */
4420 default:
4421 i = -1;
4422 errno = EINVAL;
4423 break;
4424 }
84902520
TB		 4425
4426 if (pos > 0) /* need to restore position of the handle */
3028581b 4427 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
84902520 4428
16d20bd9
AD		 4429 return (i);
4430}
ff68c719 4431
4432#endif /* LOCKF_EMULATE_FLOCK */
4e35701f 4433
Unnamed repository; edit this file 'description' to name the repository.