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