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