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