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