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