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