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