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