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