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