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
Update README.threads and Todo.5.005.
[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
25#ifdef I_SYS_WAIT
26# include <sys/wait.h>
27#endif
28
29#ifdef I_SYS_RESOURCE
30# include <sys/resource.h>
16d20bd9 31#endif
a0d0e21e
LW		 32
33#if defined(HAS_SOCKET) && !defined(VMS) /* VMS handles sockets via vmsish.h */
34# include <sys/socket.h>
35# include <netdb.h>
36# ifndef ENOTSOCK
37# ifdef I_NET_ERRNO
38# include <net/errno.h>
39# endif
40# endif
41#endif
42
43#ifdef HAS_SELECT
44#ifdef I_SYS_SELECT
a0d0e21e
LW		 45#include <sys/select.h>
46#endif
47#endif
a0d0e21e
LW		 48
49#ifdef HOST_NOT_FOUND
50extern int h_errno;
51#endif
52
53#ifdef HAS_PASSWD
54# ifdef I_PWD
55# include <pwd.h>
56# else
57 struct passwd *getpwnam _((char *));
58 struct passwd *getpwuid _((Uid_t));
59# endif
60 struct passwd *getpwent _((void));
61#endif
62
63#ifdef HAS_GROUP
64# ifdef I_GRP
65# include <grp.h>
66# else
67 struct group *getgrnam _((char *));
68 struct group *getgrgid _((Gid_t));
69# endif
70 struct group *getgrent _((void));
71#endif
72
73#ifdef I_UTIME
3e3baf6d 74# ifdef _MSC_VER
3fe9a6f1 75# include <sys/utime.h>
76# else
77# include <utime.h>
78# endif
a0d0e21e
LW		 79#endif
80#ifdef I_FCNTL
81#include <fcntl.h>
82#endif
83#ifdef I_SYS_FILE
84#include <sys/file.h>
85#endif
86
54310121 87/* Put this after #includes because fork and vfork prototypes may conflict. */
88#ifndef HAS_VFORK
89# define vfork fork
90#endif
91
d574b85e
CS		 92/* Put this after #includes because <unistd.h> defines _XOPEN_*. */
93#ifndef Sock_size_t
137443ea 94# if _XOPEN_VERSION >= 5 || defined(_XOPEN_SOURCE_EXTENDED) || defined(__GLIBC__)
d574b85e
CS		 95# define Sock_size_t Size_t
96# else
97# define Sock_size_t int
98# endif
54310121 99#endif
100
a0d0e21e
LW		 101#if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
102static int dooneliner _((char *cmd, char *filename));
103#endif
cbdc8872 104
105#ifdef HAS_CHSIZE
cd52b7b2 106# ifdef my_chsize /* Probably #defined to Perl_my_chsize in embed.h */
107# undef my_chsize
108# endif
cbdc8872 109# define my_chsize chsize
110#endif
111
ff68c719 112#ifdef HAS_FLOCK
113# define FLOCK flock
114#else /* no flock() */
115
36477c24 116 /* fcntl.h might not have been included, even if it exists, because
117 the current Configure only sets I_FCNTL if it's needed to pick up
118 the *_OK constants. Make sure it has been included before testing
119 the fcntl() locking constants. */
120# if defined(HAS_FCNTL) && !defined(I_FCNTL)
121# include <fcntl.h>
122# endif
123
ff68c719 124# if defined(HAS_FCNTL) && defined(F_SETLK) && defined (F_SETLKW)
125# define FLOCK fcntl_emulate_flock
126# define FCNTL_EMULATE_FLOCK
127# else /* no flock() or fcntl(F_SETLK,...) */
128# ifdef HAS_LOCKF
129# define FLOCK lockf_emulate_flock
130# define LOCKF_EMULATE_FLOCK
131# endif /* lockf */
132# endif /* no flock() or fcntl(F_SETLK,...) */
133
134# ifdef FLOCK
13826f2c 135 static int FLOCK _((int, int));
ff68c719 136
137 /*
138 * These are the flock() constants. Since this sytems doesn't have
139 * flock(), the values of the constants are probably not available.
140 */
141# ifndef LOCK_SH
142# define LOCK_SH 1
143# endif
144# ifndef LOCK_EX
145# define LOCK_EX 2
146# endif
147# ifndef LOCK_NB
148# define LOCK_NB 4
149# endif
150# ifndef LOCK_UN
151# define LOCK_UN 8
152# endif
153# endif /* emulating flock() */
154
155#endif /* no flock() */
55497cff 156
46fc3d4c 157#ifndef MAXPATHLEN
158# ifdef PATH_MAX
159# define MAXPATHLEN PATH_MAX
160# else
161# define MAXPATHLEN 1024
162# endif
163#endif
55497cff 164
8903cb82 165#define ZBTLEN 10
166static char zero_but_true[ZBTLEN + 1] = "0 but true";
167
a0d0e21e
LW		 168/* Pushy I/O. */
169
170PP(pp_backtick)
171{
172 dSP; dTARGET;
760ac839 173 PerlIO *fp;
a0d0e21e 174 char *tmps = POPp;
54310121 175 I32 gimme = GIMME_V;
176
a0d0e21e
LW		 177 TAINT_PROPER("``");
178 fp = my_popen(tmps, "r");
179 if (fp) {
54310121 180 if (gimme == G_VOID) {
96827780
MB		 181 char tmpbuf[256];
182 while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0)
54310121 183 /*SUPPRESS 530*/
184 ;
185 }
186 else if (gimme == G_SCALAR) {
aa689395 187 sv_setpv(TARG, ""); /* note that this preserves previous buffer */
a0d0e21e
LW		 188 while (sv_gets(TARG, fp, SvCUR(TARG)) != Nullch)
189 /*SUPPRESS 530*/
190 ;
191 XPUSHs(TARG);
aa689395 192 SvTAINTED_on(TARG);
a0d0e21e
LW		 193 }
194 else {
195 SV *sv;
196
197 for (;;) {
198 sv = NEWSV(56, 80);
199 if (sv_gets(sv, fp, 0) == Nullch) {
200 SvREFCNT_dec(sv);
201 break;
202 }
203 XPUSHs(sv_2mortal(sv));
204 if (SvLEN(sv) - SvCUR(sv) > 20) {
205 SvLEN_set(sv, SvCUR(sv)+1);
206 Renew(SvPVX(sv), SvLEN(sv), char);
207 }
aa689395 208 SvTAINTED_on(sv);
a0d0e21e
LW		 209 }
210 }
f86702cc 211 STATUS_NATIVE_SET(my_pclose(fp));
aa689395 212 TAINT; /* "I believe that this is not gratuitous!" */
a0d0e21e
LW		 213 }
214 else {
f86702cc 215 STATUS_NATIVE_SET(-1);
54310121 216 if (gimme == G_SCALAR)
a0d0e21e
LW		 217 RETPUSHUNDEF;
218 }
219
220 RETURN;
221}
222
223PP(pp_glob)
224{
225 OP *result;
226 ENTER;
a0d0e21e 227
c90c0ff4 228#ifndef VMS
7bac28a0 229 if (tainting) {
230 /*
231 * The external globbing program may use things we can't control,
232 * so for security reasons we must assume the worst.
233 */
234 TAINT;
235 taint_proper(no_security, "glob");
236 }
c90c0ff4 237#endif /* !VMS */
7bac28a0 238
a0d0e21e
LW		 239 SAVESPTR(last_in_gv); /* We don't want this to be permanent. */
240 last_in_gv = (GV*)*stack_sp--;
241
c07a80fd 242 SAVESPTR(rs); /* This is not permanent, either. */
243 rs = sv_2mortal(newSVpv("", 1));
244#ifndef DOSISH
245#ifndef CSH
246 *SvPVX(rs) = '\n';
a0d0e21e 247#endif /* !CSH */
55497cff 248#endif /* !DOSISH */
c07a80fd 249
a0d0e21e
LW		 250 result = do_readline();
251 LEAVE;
252 return result;
253}
254
255PP(pp_indread)
256{
257 last_in_gv = gv_fetchpv(SvPVx(GvSV((GV*)(*stack_sp--)), na), TRUE,SVt_PVIO);
258 return do_readline();
259}
260
261PP(pp_rcatline)
262{
263 last_in_gv = cGVOP->op_gv;
264 return do_readline();
265}
266
267PP(pp_warn)
268{
269 dSP; dMARK;
270 char *tmps;
271 if (SP - MARK != 1) {
272 dTARGET;
273 do_join(TARG, &sv_no, MARK, SP);
274 tmps = SvPV(TARG, na);
275 SP = MARK + 1;
276 }
277 else {
278 tmps = SvPV(TOPs, na);
279 }
280 if (!tmps || !*tmps) {
a863c7d1
MB		 281 (void)SvUPGRADE(errsv, SVt_PV);
282 if (SvPOK(errsv) && SvCUR(errsv))
283 sv_catpv(errsv, "\t...caught");
284 tmps = SvPV(errsv, na);
a0d0e21e
LW		 285 }
286 if (!tmps || !*tmps)
287 tmps = "Warning: something's wrong";
288 warn("%s", tmps);
289 RETSETYES;
290}
291
292PP(pp_die)
293{
294 dSP; dMARK;
295 char *tmps;
296 if (SP - MARK != 1) {
297 dTARGET;
298 do_join(TARG, &sv_no, MARK, SP);
299 tmps = SvPV(TARG, na);
300 SP = MARK + 1;
301 }
302 else {
303 tmps = SvPV(TOPs, na);
304 }
305 if (!tmps || !*tmps) {
a863c7d1
MB		 306 (void)SvUPGRADE(errsv, SVt_PV);
307 if (SvPOK(errsv) && SvCUR(errsv))
308 sv_catpv(errsv, "\t...propagated");
309 tmps = SvPV(errsv, na);
a0d0e21e
LW		 310 }
311 if (!tmps || !*tmps)
312 tmps = "Died";
313 DIE("%s", tmps);
314}
315
316/* I/O. */
317
318PP(pp_open)
319{
320 dSP; dTARGET;
321 GV *gv;
322 SV *sv;
323 char *tmps;
324 STRLEN len;
325
326 if (MAXARG > 1)
327 sv = POPs;
5f05dabc 328 if (!isGV(TOPs))
4633a7c4 329 DIE(no_usym, "filehandle");
5f05dabc 330 if (MAXARG <= 1)
331 sv = GvSV(TOPs);
a0d0e21e 332 gv = (GV*)POPs;
5f05dabc 333 if (!isGV(gv))
334 DIE(no_usym, "filehandle");
36477c24 335 if (GvIOp(gv))
336 IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
a0d0e21e 337 tmps = SvPV(sv, len);
36477c24 338 if (do_open(gv, tmps, len, FALSE, 0, 0, Nullfp))
a0d0e21e 339 PUSHi( (I32)forkprocess );
a0d0e21e
LW		 340 else if (forkprocess == 0) /* we are a new child */
341 PUSHi(0);
342 else
343 RETPUSHUNDEF;
344 RETURN;
345}
346
347PP(pp_close)
348{
349 dSP;
350 GV *gv;
351
352 if (MAXARG == 0)
353 gv = defoutgv;
354 else
355 gv = (GV*)POPs;
356 EXTEND(SP, 1);
54310121 357 PUSHs(boolSV(do_close(gv, TRUE)));
a0d0e21e
LW		 358 RETURN;
359}
360
361PP(pp_pipe_op)
362{
363 dSP;
364#ifdef HAS_PIPE
365 GV *rgv;
366 GV *wgv;
367 register IO *rstio;
368 register IO *wstio;
369 int fd[2];
370
371 wgv = (GV*)POPs;
372 rgv = (GV*)POPs;
373
374 if (!rgv || !wgv)
375 goto badexit;
376
4633a7c4
LW		 377 if (SvTYPE(rgv) != SVt_PVGV || SvTYPE(wgv) != SVt_PVGV)
378 DIE(no_usym, "filehandle");
a0d0e21e
LW		 379 rstio = GvIOn(rgv);
380 wstio = GvIOn(wgv);
381
382 if (IoIFP(rstio))
383 do_close(rgv, FALSE);
384 if (IoIFP(wstio))
385 do_close(wgv, FALSE);
386
387 if (pipe(fd) < 0)
388 goto badexit;
389
760ac839
LW		 390 IoIFP(rstio) = PerlIO_fdopen(fd[0], "r");
391 IoOFP(wstio) = PerlIO_fdopen(fd[1], "w");
a0d0e21e
LW		 392 IoIFP(wstio) = IoOFP(wstio);
393 IoTYPE(rstio) = '<';
394 IoTYPE(wstio) = '>';
395
396 if (!IoIFP(rstio) || !IoOFP(wstio)) {
760ac839 397 if (IoIFP(rstio)) PerlIO_close(IoIFP(rstio));
a0d0e21e 398 else close(fd[0]);
760ac839 399 if (IoOFP(wstio)) PerlIO_close(IoOFP(wstio));
a0d0e21e
LW		 400 else close(fd[1]);
401 goto badexit;
402 }
403
404 RETPUSHYES;
405
406badexit:
407 RETPUSHUNDEF;
408#else
409 DIE(no_func, "pipe");
410#endif
411}
412
413PP(pp_fileno)
414{
415 dSP; dTARGET;
416 GV *gv;
417 IO *io;
760ac839 418 PerlIO *fp;
a0d0e21e
LW		 419 if (MAXARG < 1)
420 RETPUSHUNDEF;
421 gv = (GV*)POPs;
422 if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io)))
423 RETPUSHUNDEF;
760ac839 424 PUSHi(PerlIO_fileno(fp));
a0d0e21e
LW		 425 RETURN;
426}
427
428PP(pp_umask)
429{
430 dSP; dTARGET;
431 int anum;
432
433#ifdef HAS_UMASK
434 if (MAXARG < 1) {
435 anum = umask(0);
436 (void)umask(anum);
437 }
438 else
439 anum = umask(POPi);
440 TAINT_PROPER("umask");
441 XPUSHi(anum);
442#else
443 DIE(no_func, "Unsupported function umask");
444#endif
445 RETURN;
446}
447
448PP(pp_binmode)
449{
450 dSP;
451 GV *gv;
452 IO *io;
760ac839 453 PerlIO *fp;
a0d0e21e
LW		 454
455 if (MAXARG < 1)
456 RETPUSHUNDEF;
457
458 gv = (GV*)POPs;
459
460 EXTEND(SP, 1);
461 if (!(io = GvIO(gv)) || !(fp = IoIFP(io)))
55497cff 462 RETPUSHUNDEF;
a0d0e21e
LW		 463
464#ifdef DOSISH
465#ifdef atarist
760ac839 466 if (!PerlIO_flush(fp) && (fp->_flag |= _IOBIN))
a0d0e21e
LW		 467 RETPUSHYES;
468 else
469 RETPUSHUNDEF;
470#else
3e3baf6d
TB		 471 if (setmode(PerlIO_fileno(fp), OP_BINARY) != -1) {
472#if defined(WIN32) && defined(__BORLANDC__)
473 /* The translation mode of the stream is maintained independent
474 * of the translation mode of the fd in the Borland RTL (heavy
475 * digging through their runtime sources reveal). User has to
476 * set the mode explicitly for the stream (though they don't
477 * document this anywhere). GSAR 97-5-24
478 */
479 PerlIO_seek(fp,0L,0);
480 fp->flags |= _F_BIN;
481#endif
a0d0e21e 482 RETPUSHYES;
3e3baf6d 483 }
a0d0e21e
LW		 484 else
485 RETPUSHUNDEF;
486#endif
487#else
cbdc8872 488#if defined(USEMYBINMODE)
489 if (my_binmode(fp,IoTYPE(io)) != NULL)
490 RETPUSHYES;
491 else
492 RETPUSHUNDEF;
493#else
a0d0e21e
LW		 494 RETPUSHYES;
495#endif
cbdc8872 496#endif
497
a0d0e21e
LW		 498}
499
500PP(pp_tie)
501{
502 dSP;
503 SV *varsv;
504 HV* stash;
505 GV *gv;
506 BINOP myop;
507 SV *sv;
508 SV **mark = stack_base + ++*markstack_ptr; /* reuse in entersub */
509 I32 markoff = mark - stack_base - 1;
510 char *methname;
54310121 511 bool oldcatch = CATCH_GET;
a0d0e21e
LW		 512
513 varsv = mark[0];
514 if (SvTYPE(varsv) == SVt_PVHV)
515 methname = "TIEHASH";
516 else if (SvTYPE(varsv) == SVt_PVAV)
517 methname = "TIEARRAY";
518 else if (SvTYPE(varsv) == SVt_PVGV)
519 methname = "TIEHANDLE";
520 else
521 methname = "TIESCALAR";
522
523 stash = gv_stashsv(mark[1], FALSE);
8ebc5c01 524 if (!stash || !(gv = gv_fetchmethod(stash, methname)))
a0d0e21e
LW		 525 DIE("Can't locate object method \"%s\" via package \"%s\"",
526 methname, SvPV(mark[1],na));
527
528 Zero(&myop, 1, BINOP);
529 myop.op_last = (OP *) &myop;
530 myop.op_next = Nullop;
54310121 531 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
532 CATCH_SET(TRUE);
a0d0e21e
LW		 533
534 ENTER;
462e5cf6 535 SAVEOP();
a0d0e21e 536 op = (OP *) &myop;
84902520 537 if (PERLDB_SUB && curstash != debstash)
cbdc8872 538 op->op_private |= OPpENTERSUB_DB;
a0d0e21e 539
8ebc5c01 540 XPUSHs((SV*)GvCV(gv));
a0d0e21e
LW		 541 PUTBACK;
542
11343788 543 if (op = pp_entersub(ARGS))
53a31ece 544 runops();
a0d0e21e
LW		 545 SPAGAIN;
546
54310121 547 CATCH_SET(oldcatch);
a0d0e21e
LW		 548 sv = TOPs;
549 if (sv_isobject(sv)) {
550 if (SvTYPE(varsv) == SVt_PVHV || SvTYPE(varsv) == SVt_PVAV) {
551 sv_unmagic(varsv, 'P');
552 sv_magic(varsv, sv, 'P', Nullch, 0);
553 }
554 else {
555 sv_unmagic(varsv, 'q');
556 sv_magic(varsv, sv, 'q', Nullch, 0);
557 }
558 }
559 LEAVE;
560 SP = stack_base + markoff;
561 PUSHs(sv);
562 RETURN;
563}
564
565PP(pp_untie)
566{
567 dSP;
cbdc8872 568 SV * sv ;
569
570 sv = POPs;
55497cff 571
572 if (dowarn) {
cbdc8872 573 MAGIC * mg ;
574 if (SvMAGICAL(sv)) {
575 if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
576 mg = mg_find(sv, 'P') ;
577 else
578 mg = mg_find(sv, 'q') ;
579
580 if (mg && SvREFCNT(SvRV(mg->mg_obj)) > 1)
ff0cee69 581 warn("untie attempted while %lu inner references still exist",
582 (unsigned long)SvREFCNT(SvRV(mg->mg_obj)) - 1 ) ;
cbdc8872 583 }
584 }
585
586 if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
587 sv_unmagic(sv, 'P');
a0d0e21e 588 else
cbdc8872 589 sv_unmagic(sv, 'q');
55497cff 590 RETPUSHYES;
a0d0e21e
LW		 591}
592
c07a80fd 593PP(pp_tied)
594{
a5f75d66 595 dSP;
c07a80fd 596 SV * sv ;
597 MAGIC * mg ;
598
599 sv = POPs;
600 if (SvMAGICAL(sv)) {
601 if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
602 mg = mg_find(sv, 'P') ;
603 else
604 mg = mg_find(sv, 'q') ;
605
606 if (mg) {
607 PUSHs(sv_2mortal(newSVsv(mg->mg_obj))) ;
608 RETURN ;
609 }
610 }
611
612 RETPUSHUNDEF;
613}
614
a0d0e21e
LW		 615PP(pp_dbmopen)
616{
617 dSP;
618 HV *hv;
619 dPOPPOPssrl;
620 HV* stash;
621 GV *gv;
622 BINOP myop;
623 SV *sv;
54310121 624 bool oldcatch = CATCH_GET;
a0d0e21e
LW		 625
626 hv = (HV*)POPs;
627
628 sv = sv_mortalcopy(&sv_no);
629 sv_setpv(sv, "AnyDBM_File");
630 stash = gv_stashsv(sv, FALSE);
8ebc5c01 631 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
a0d0e21e 632 PUTBACK;
4633a7c4 633 perl_require_pv("AnyDBM_File.pm");
a0d0e21e 634 SPAGAIN;
8ebc5c01 635 if (!(gv = gv_fetchmethod(stash, "TIEHASH")))
a0d0e21e
LW		 636 DIE("No dbm on this machine");
637 }
638
639 Zero(&myop, 1, BINOP);
640 myop.op_last = (OP *) &myop;
641 myop.op_next = Nullop;
54310121 642 myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
643 CATCH_SET(TRUE);
a0d0e21e
LW		 644
645 ENTER;
462e5cf6 646 SAVEOP();
a0d0e21e 647 op = (OP *) &myop;
84902520 648 if (PERLDB_SUB && curstash != debstash)
cbdc8872 649 op->op_private |= OPpENTERSUB_DB;
a0d0e21e 650 PUTBACK;
11343788 651 pp_pushmark(ARGS);
a0d0e21e
LW		 652
653 EXTEND(sp, 5);
654 PUSHs(sv);
655 PUSHs(left);
656 if (SvIV(right))
657 PUSHs(sv_2mortal(newSViv(O_RDWR|O_CREAT)));
658 else
659 PUSHs(sv_2mortal(newSViv(O_RDWR)));
660 PUSHs(right);
8ebc5c01 661 PUSHs((SV*)GvCV(gv));
a0d0e21e
LW		 662 PUTBACK;
663
11343788 664 if (op = pp_entersub(ARGS))
53a31ece 665 runops();
a0d0e21e
LW		 666 SPAGAIN;
667
668 if (!sv_isobject(TOPs)) {
669 sp--;
670 op = (OP *) &myop;
671 PUTBACK;
11343788 672 pp_pushmark(ARGS);
a0d0e21e
LW		 673
674 PUSHs(sv);
675 PUSHs(left);
676 PUSHs(sv_2mortal(newSViv(O_RDONLY)));
677 PUSHs(right);
8ebc5c01 678 PUSHs((SV*)GvCV(gv));
a0d0e21e
LW		 679 PUTBACK;
680
11343788 681 if (op = pp_entersub(ARGS))
53a31ece 682 runops();
a0d0e21e
LW		 683 SPAGAIN;
684 }
685
54310121 686 CATCH_SET(oldcatch);
a0d0e21e
LW		 687 if (sv_isobject(TOPs))
688 sv_magic((SV*)hv, TOPs, 'P', Nullch, 0);
689 LEAVE;
690 RETURN;
691}
692
693PP(pp_dbmclose)
694{
695 return pp_untie(ARGS);
696}
697
698PP(pp_sselect)
699{
700 dSP; dTARGET;
701#ifdef HAS_SELECT
702 register I32 i;
703 register I32 j;
704 register char *s;
705 register SV *sv;
706 double value;
707 I32 maxlen = 0;
708 I32 nfound;
709 struct timeval timebuf;
710 struct timeval *tbuf = &timebuf;
711 I32 growsize;
712 char *fd_sets[4];
713#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
714 I32 masksize;
715 I32 offset;
716 I32 k;
717
718# if BYTEORDER & 0xf0000
719# define ORDERBYTE (0x88888888 - BYTEORDER)
720# else
721# define ORDERBYTE (0x4444 - BYTEORDER)
722# endif
723
724#endif
725
726 SP -= 4;
727 for (i = 1; i <= 3; i++) {
728 if (!SvPOK(SP[i]))
729 continue;
730 j = SvCUR(SP[i]);
731 if (maxlen < j)
732 maxlen = j;
733 }
734
735#if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
44a8e56a 736#if defined(__linux__) || defined(OS2)
4633a7c4
LW		 737 growsize = sizeof(fd_set);
738#else
a0d0e21e 739 growsize = maxlen; /* little endians can use vecs directly */
4633a7c4 740#endif
a0d0e21e
LW		 741#else
742#ifdef NFDBITS
743
744#ifndef NBBY
745#define NBBY 8
746#endif
747
748 masksize = NFDBITS / NBBY;
749#else
750 masksize = sizeof(long); /* documented int, everyone seems to use long */
751#endif
752 growsize = maxlen + (masksize - (maxlen % masksize));
753 Zero(&fd_sets[0], 4, char*);
754#endif
755
756 sv = SP[4];
757 if (SvOK(sv)) {
758 value = SvNV(sv);
759 if (value < 0.0)
760 value = 0.0;
761 timebuf.tv_sec = (long)value;
762 value -= (double)timebuf.tv_sec;
763 timebuf.tv_usec = (long)(value * 1000000.0);
764 }
765 else
766 tbuf = Null(struct timeval*);
767
768 for (i = 1; i <= 3; i++) {
769 sv = SP[i];
770 if (!SvOK(sv)) {
771 fd_sets[i] = 0;
772 continue;
773 }
774 else if (!SvPOK(sv))
775 SvPV_force(sv,na); /* force string conversion */
776 j = SvLEN(sv);
777 if (j < growsize) {
778 Sv_Grow(sv, growsize);
a0d0e21e 779 }
c07a80fd 780 j = SvCUR(sv);
781 s = SvPVX(sv) + j;
782 while (++j <= growsize) {
783 *s++ = '\0';
784 }
785
a0d0e21e
LW		 786#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
787 s = SvPVX(sv);
788 New(403, fd_sets[i], growsize, char);
789 for (offset = 0; offset < growsize; offset += masksize) {
790 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
791 fd_sets[i][j+offset] = s[(k % masksize) + offset];
792 }
793#else
794 fd_sets[i] = SvPVX(sv);
795#endif
796 }
797
798 nfound = select(
799 maxlen * 8,
800 (Select_fd_set_t) fd_sets[1],
801 (Select_fd_set_t) fd_sets[2],
802 (Select_fd_set_t) fd_sets[3],
803 tbuf);
804 for (i = 1; i <= 3; i++) {
805 if (fd_sets[i]) {
806 sv = SP[i];
807#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
808 s = SvPVX(sv);
809 for (offset = 0; offset < growsize; offset += masksize) {
810 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
811 s[(k % masksize) + offset] = fd_sets[i][j+offset];
812 }
813 Safefree(fd_sets[i]);
814#endif
815 SvSETMAGIC(sv);
816 }
817 }
818
819 PUSHi(nfound);
820 if (GIMME == G_ARRAY && tbuf) {
821 value = (double)(timebuf.tv_sec) +
822 (double)(timebuf.tv_usec) / 1000000.0;
823 PUSHs(sv = sv_mortalcopy(&sv_no));
824 sv_setnv(sv, value);
825 }
826 RETURN;
827#else
828 DIE("select not implemented");
829#endif
830}
831
4633a7c4
LW		 832void
833setdefout(gv)
834GV *gv;
835{
11343788 836 dTHR;
4633a7c4
LW		 837 if (gv)
838 (void)SvREFCNT_inc(gv);
839 if (defoutgv)
840 SvREFCNT_dec(defoutgv);
841 defoutgv = gv;
842}
843
a0d0e21e
LW		 844PP(pp_select)
845{
846 dSP; dTARGET;
4633a7c4
LW		 847 GV *newdefout, *egv;
848 HV *hv;
849
850 newdefout = (op->op_private > 0) ? ((GV *) POPs) : NULL;
851
852 egv = GvEGV(defoutgv);
853 if (!egv)
854 egv = defoutgv;
855 hv = GvSTASH(egv);
856 if (! hv)
857 XPUSHs(&sv_undef);
858 else {
cbdc8872 859 GV **gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
f86702cc 860 if (gvp && *gvp == egv) {
aac0dd9a 861 gv_efullname3(TARG, defoutgv, Nullch);
f86702cc 862 XPUSHTARG;
863 }
864 else {
865 XPUSHs(sv_2mortal(newRV((SV*)egv)));
866 }
4633a7c4
LW		 867 }
868
869 if (newdefout) {
870 if (!GvIO(newdefout))
871 gv_IOadd(newdefout);
872 setdefout(newdefout);
873 }
874
a0d0e21e
LW		 875 RETURN;
876}
877
878PP(pp_getc)
879{
880 dSP; dTARGET;
881 GV *gv;
2ae324a7 882 MAGIC *mg;
a0d0e21e
LW		 883
884 if (MAXARG <= 0)
885 gv = stdingv;
886 else
887 gv = (GV*)POPs;
888 if (!gv)
889 gv = argvgv;
2ae324a7 890
891 if (SvMAGICAL(gv) && (mg = mg_find((SV*)gv, 'q'))) {
54310121 892 I32 gimme = GIMME_V;
2ae324a7 893 PUSHMARK(SP);
894 XPUSHs(mg->mg_obj);
895 PUTBACK;
896 ENTER;
54310121 897 perl_call_method("GETC", gimme);
2ae324a7 898 LEAVE;
899 SPAGAIN;
54310121 900 if (gimme == G_SCALAR)
901 SvSetMagicSV_nosteal(TARG, TOPs);
2ae324a7 902 RETURN;
903 }
a0d0e21e
LW		 904 if (!gv || do_eof(gv)) /* make sure we have fp with something */
905 RETPUSHUNDEF;
bbce6d69 906 TAINT;
a0d0e21e 907 sv_setpv(TARG, " ");
760ac839 908 *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
a0d0e21e
LW		 909 PUSHTARG;
910 RETURN;
911}
912
913PP(pp_read)
914{
915 return pp_sysread(ARGS);
916}
917
918static OP *
919doform(cv,gv,retop)
920CV *cv;
921GV *gv;
922OP *retop;
923{
11343788 924 dTHR;
a0d0e21e 925 register CONTEXT *cx;
54310121 926 I32 gimme = GIMME_V;
a0d0e21e
LW		 927 AV* padlist = CvPADLIST(cv);
928 SV** svp = AvARRAY(padlist);
929
930 ENTER;
931 SAVETMPS;
932
933 push_return(retop);
934 PUSHBLOCK(cx, CXt_SUB, stack_sp);
935 PUSHFORMAT(cx);
936 SAVESPTR(curpad);
937 curpad = AvARRAY((AV*)svp[1]);
938
4633a7c4 939 setdefout(gv); /* locally select filehandle so $% et al work */
a0d0e21e
LW		 940 return CvSTART(cv);
941}
942
943PP(pp_enterwrite)
944{
945 dSP;
946 register GV *gv;
947 register IO *io;
948 GV *fgv;
949 CV *cv;
950
951 if (MAXARG == 0)
952 gv = defoutgv;
953 else {
954 gv = (GV*)POPs;
955 if (!gv)
956 gv = defoutgv;
957 }
958 EXTEND(SP, 1);
959 io = GvIO(gv);
960 if (!io) {
961 RETPUSHNO;
962 }
963 if (IoFMT_GV(io))
964 fgv = IoFMT_GV(io);
965 else
966 fgv = gv;
967
968 cv = GvFORM(fgv);
a0d0e21e
LW		 969 if (!cv) {
970 if (fgv) {
748a9306 971 SV *tmpsv = sv_newmortal();
aac0dd9a 972 gv_efullname3(tmpsv, fgv, Nullch);
748a9306 973 DIE("Undefined format \"%s\" called",SvPVX(tmpsv));
a0d0e21e
LW		 974 }
975 DIE("Not a format reference");
976 }
44a8e56a 977 if (CvCLONE(cv))
978 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
a0d0e21e 979
44a8e56a 980 IoFLAGS(io) &= ~IOf_DIDTOP;
a0d0e21e
LW		 981 return doform(cv,gv,op->op_next);
982}
983
984PP(pp_leavewrite)
985{
986 dSP;
987 GV *gv = cxstack[cxstack_ix].blk_sub.gv;
988 register IO *io = GvIOp(gv);
760ac839
LW		 989 PerlIO *ofp = IoOFP(io);
990 PerlIO *fp;
a0d0e21e
LW		 991 SV **newsp;
992 I32 gimme;
993 register CONTEXT *cx;
994
760ac839 995 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
a0d0e21e
LW		 996 (long)IoLINES_LEFT(io), (long)FmLINES(formtarget)));
997 if (IoLINES_LEFT(io) < FmLINES(formtarget) &&
998 formtarget != toptarget)
999 {
4633a7c4
LW		 1000 GV *fgv;
1001 CV *cv;
a0d0e21e
LW		 1002 if (!IoTOP_GV(io)) {
1003 GV *topgv;
46fc3d4c 1004 SV *topname;
a0d0e21e
LW		 1005
1006 if (!IoTOP_NAME(io)) {
1007 if (!IoFMT_NAME(io))
1008 IoFMT_NAME(io) = savepv(GvNAME(gv));
46fc3d4c 1009 topname = sv_2mortal(newSVpvf("%s_TOP", IoFMT_NAME(io)));
1010 topgv = gv_fetchpv(SvPVX(topname), FALSE, SVt_PVFM);
748a9306 1011 if ((topgv && GvFORM(topgv)) ||
a0d0e21e 1012 !gv_fetchpv("top",FALSE,SVt_PVFM))
46fc3d4c 1013 IoTOP_NAME(io) = savepv(SvPVX(topname));
a0d0e21e
LW		 1014 else
1015 IoTOP_NAME(io) = savepv("top");
1016 }
1017 topgv = gv_fetchpv(IoTOP_NAME(io),FALSE, SVt_PVFM);
1018 if (!topgv || !GvFORM(topgv)) {
1019 IoLINES_LEFT(io) = 100000000;
1020 goto forget_top;
1021 }
1022 IoTOP_GV(io) = topgv;
1023 }
748a9306
LW		 1024 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1025 I32 lines = IoLINES_LEFT(io);
1026 char *s = SvPVX(formtarget);
8e07c86e
AD		 1027 if (lines <= 0) /* Yow, header didn't even fit!!! */
1028 goto forget_top;
748a9306
LW		 1029 while (lines-- > 0) {
1030 s = strchr(s, '\n');
1031 if (!s)
1032 break;
1033 s++;
1034 }
1035 if (s) {
760ac839 1036 PerlIO_write(ofp, SvPVX(formtarget), s - SvPVX(formtarget));
748a9306
LW		 1037 sv_chop(formtarget, s);
1038 FmLINES(formtarget) -= IoLINES_LEFT(io);
1039 }
1040 }
a0d0e21e 1041 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
760ac839 1042 PerlIO_write(ofp, SvPVX(formfeed), SvCUR(formfeed));
a0d0e21e
LW		 1043 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1044 IoPAGE(io)++;
1045 formtarget = toptarget;
748a9306 1046 IoFLAGS(io) |= IOf_DIDTOP;
4633a7c4
LW		 1047 fgv = IoTOP_GV(io);
1048 if (!fgv)
1049 DIE("bad top format reference");
1050 cv = GvFORM(fgv);
1051 if (!cv) {
1052 SV *tmpsv = sv_newmortal();
aac0dd9a 1053 gv_efullname3(tmpsv, fgv, Nullch);
4633a7c4
LW		 1054 DIE("Undefined top format \"%s\" called",SvPVX(tmpsv));
1055 }
44a8e56a 1056 if (CvCLONE(cv))
1057 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
4633a7c4 1058 return doform(cv,gv,op);
a0d0e21e
LW		 1059 }
1060
1061 forget_top:
1062 POPBLOCK(cx,curpm);
1063 POPFORMAT(cx);
1064 LEAVE;
1065
1066 fp = IoOFP(io);
1067 if (!fp) {
1068 if (dowarn) {
1069 if (IoIFP(io))
1070 warn("Filehandle only opened for input");
1071 else
1072 warn("Write on closed filehandle");
1073 }
1074 PUSHs(&sv_no);
1075 }
1076 else {
1077 if ((IoLINES_LEFT(io) -= FmLINES(formtarget)) < 0) {
1078 if (dowarn)
1079 warn("page overflow");
1080 }
760ac839
LW		 1081 if (!PerlIO_write(ofp, SvPVX(formtarget), SvCUR(formtarget)) ||
1082 PerlIO_error(fp))
a0d0e21e
LW		 1083 PUSHs(&sv_no);
1084 else {
1085 FmLINES(formtarget) = 0;
1086 SvCUR_set(formtarget, 0);
748a9306 1087 *SvEND(formtarget) = '\0';
a0d0e21e 1088 if (IoFLAGS(io) & IOf_FLUSH)
760ac839 1089 (void)PerlIO_flush(fp);
a0d0e21e
LW		 1090 PUSHs(&sv_yes);
1091 }
1092 }
1093 formtarget = bodytarget;
1094 PUTBACK;
1095 return pop_return();
1096}
1097
1098PP(pp_prtf)
1099{
1100 dSP; dMARK; dORIGMARK;
1101 GV *gv;
1102 IO *io;
760ac839 1103 PerlIO *fp;
26db47c4 1104 SV *sv;
46fc3d4c 1105 MAGIC *mg;
a0d0e21e
LW		 1106
1107 if (op->op_flags & OPf_STACKED)
1108 gv = (GV*)*++MARK;
1109 else
1110 gv = defoutgv;
46fc3d4c 1111
1112 if (SvMAGICAL(gv) && (mg = mg_find((SV*)gv, 'q'))) {
1113 if (MARK == ORIGMARK) {
1114 EXTEND(SP, 1);
1115 ++MARK;
1116 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1117 ++SP;
1118 }
1119 PUSHMARK(MARK - 1);
1120 *MARK = mg->mg_obj;
1121 PUTBACK;
1122 ENTER;
1123 perl_call_method("PRINTF", G_SCALAR);
1124 LEAVE;
1125 SPAGAIN;
1126 MARK = ORIGMARK + 1;
1127 *MARK = *SP;
1128 SP = MARK;
1129 RETURN;
1130 }
1131
26db47c4 1132 sv = NEWSV(0,0);
a0d0e21e 1133 if (!(io = GvIO(gv))) {
748a9306 1134 if (dowarn) {
aac0dd9a 1135 gv_fullname3(sv, gv, Nullch);
748a9306
LW		 1136 warn("Filehandle %s never opened", SvPV(sv,na));
1137 }
1138 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW		 1139 goto just_say_no;
1140 }
1141 else if (!(fp = IoOFP(io))) {
1142 if (dowarn) {
aac0dd9a 1143 gv_fullname3(sv, gv, Nullch);
a0d0e21e 1144 if (IoIFP(io))
748a9306 1145 warn("Filehandle %s opened only for input", SvPV(sv,na));
a0d0e21e 1146 else
748a9306 1147 warn("printf on closed filehandle %s", SvPV(sv,na));
a0d0e21e 1148 }
748a9306 1149 SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
a0d0e21e
LW		 1150 goto just_say_no;
1151 }
1152 else {
36477c24 1153#ifdef USE_LOCALE_NUMERIC
bbce6d69 1154 if (op->op_private & OPpLOCALE)
36477c24 1155 SET_NUMERIC_LOCAL();
bbce6d69 1156 else
36477c24 1157 SET_NUMERIC_STANDARD();
1158#endif
a0d0e21e
LW		 1159 do_sprintf(sv, SP - MARK, MARK + 1);
1160 if (!do_print(sv, fp))
1161 goto just_say_no;
1162
1163 if (IoFLAGS(io) & IOf_FLUSH)
760ac839 1164 if (PerlIO_flush(fp) == EOF)
a0d0e21e
LW		 1165 goto just_say_no;
1166 }
1167 SvREFCNT_dec(sv);
1168 SP = ORIGMARK;
1169 PUSHs(&sv_yes);
1170 RETURN;
1171
1172 just_say_no:
1173 SvREFCNT_dec(sv);
1174 SP = ORIGMARK;
1175 PUSHs(&sv_undef);
1176 RETURN;
1177}
1178
c07a80fd 1179PP(pp_sysopen)
1180{
a5f75d66 1181 dSP;
c07a80fd 1182 GV *gv;
c07a80fd 1183 SV *sv;
1184 char *tmps;
1185 STRLEN len;
1186 int mode, perm;
1187
1188 if (MAXARG > 3)
1189 perm = POPi;
1190 else
1191 perm = 0666;
1192 mode = POPi;
1193 sv = POPs;
1194 gv = (GV *)POPs;
1195
1196 tmps = SvPV(sv, len);
1197 if (do_open(gv, tmps, len, TRUE, mode, perm, Nullfp)) {
1198 IoLINES(GvIOp(gv)) = 0;
1199 PUSHs(&sv_yes);
1200 }
1201 else {
1202 PUSHs(&sv_undef);
1203 }
1204 RETURN;
1205}
1206
a0d0e21e
LW		 1207PP(pp_sysread)
1208{
1209 dSP; dMARK; dORIGMARK; dTARGET;
1210 int offset;
1211 GV *gv;
1212 IO *io;
1213 char *buffer;
5b54f415 1214 SSize_t length;
1e422769 1215 Sock_size_t bufsize;
748a9306 1216 SV *bufsv;
a0d0e21e 1217 STRLEN blen;
2ae324a7 1218 MAGIC *mg;
a0d0e21e
LW		 1219
1220 gv = (GV*)*++MARK;
064096e1 1221 if ((op->op_type == OP_READ || op->op_type == OP_SYSREAD) &&
137443ea 1222 SvMAGICAL(gv) && (mg = mg_find((SV*)gv, 'q')))
1223 {
2ae324a7 1224 SV *sv;
1225
1226 PUSHMARK(MARK-1);
1227 *MARK = mg->mg_obj;
1228 ENTER;
1229 perl_call_method("READ", G_SCALAR);
1230 LEAVE;
1231 SPAGAIN;
1232 sv = POPs;
1233 SP = ORIGMARK;
1234 PUSHs(sv);
1235 RETURN;
1236 }
1237
a0d0e21e
LW		 1238 if (!gv)
1239 goto say_undef;
748a9306 1240 bufsv = *++MARK;
ff68c719 1241 if (! SvOK(bufsv))
1242 sv_setpvn(bufsv, "", 0);
748a9306 1243 buffer = SvPV_force(bufsv, blen);
a0d0e21e
LW		 1244 length = SvIVx(*++MARK);
1245 if (length < 0)
1246 DIE("Negative length");
748a9306 1247 SETERRNO(0,0);
a0d0e21e
LW		 1248 if (MARK < SP)
1249 offset = SvIVx(*++MARK);
1250 else
1251 offset = 0;
1252 io = GvIO(gv);
1253 if (!io || !IoIFP(io))
1254 goto say_undef;
1255#ifdef HAS_SOCKET
1256 if (op->op_type == OP_RECV) {
46fc3d4c 1257 char namebuf[MAXPATHLEN];
490ab354
JH		 1258#if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
1259 bufsize = sizeof (struct sockaddr_in);
1260#else
46fc3d4c 1261 bufsize = sizeof namebuf;
490ab354 1262#endif
748a9306 1263 buffer = SvGROW(bufsv, length+1);
bbce6d69 1264 /* 'offset' means 'flags' here */
760ac839 1265 length = recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
46fc3d4c 1266 (struct sockaddr *)namebuf, &bufsize);
a0d0e21e
LW		 1267 if (length < 0)
1268 RETPUSHUNDEF;
748a9306
LW		 1269 SvCUR_set(bufsv, length);
1270 *SvEND(bufsv) = '\0';
1271 (void)SvPOK_only(bufsv);
1272 SvSETMAGIC(bufsv);
aac0dd9a 1273 /* This should not be marked tainted if the fp is marked clean */
bbce6d69 1274 if (!(IoFLAGS(io) & IOf_UNTAINT))
1275 SvTAINTED_on(bufsv);
a0d0e21e 1276 SP = ORIGMARK;
46fc3d4c 1277 sv_setpvn(TARG, namebuf, bufsize);
a0d0e21e
LW		 1278 PUSHs(TARG);
1279 RETURN;
1280 }
1281#else
1282 if (op->op_type == OP_RECV)
1283 DIE(no_sock_func, "recv");
1284#endif
bbce6d69 1285 if (offset < 0) {
1286 if (-offset > blen)
1287 DIE("Offset outside string");
1288 offset += blen;
1289 }
cd52b7b2 1290 bufsize = SvCUR(bufsv);
748a9306 1291 buffer = SvGROW(bufsv, length+offset+1);
cd52b7b2 1292 if (offset > bufsize) { /* Zero any newly allocated space */
1293 Zero(buffer+bufsize, offset-bufsize, char);
1294 }
a0d0e21e 1295 if (op->op_type == OP_SYSREAD) {
760ac839 1296 length = read(PerlIO_fileno(IoIFP(io)), buffer+offset, length);
a0d0e21e
LW		 1297 }
1298 else
1299#ifdef HAS_SOCKET__bad_code_maybe
1300 if (IoTYPE(io) == 's') {
46fc3d4c 1301 char namebuf[MAXPATHLEN];
490ab354
JH		 1302#if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
1303 bufsize = sizeof (struct sockaddr_in);
1304#else
46fc3d4c 1305 bufsize = sizeof namebuf;
490ab354 1306#endif
760ac839 1307 length = recvfrom(PerlIO_fileno(IoIFP(io)), buffer+offset, length, 0,
46fc3d4c 1308 (struct sockaddr *)namebuf, &bufsize);
a0d0e21e
LW		 1309 }
1310 else
1311#endif
760ac839 1312 length = PerlIO_read(IoIFP(io), buffer+offset, length);
a0d0e21e
LW		 1313 if (length < 0)
1314 goto say_undef;
748a9306
LW		 1315 SvCUR_set(bufsv, length+offset);
1316 *SvEND(bufsv) = '\0';
1317 (void)SvPOK_only(bufsv);
1318 SvSETMAGIC(bufsv);
aac0dd9a 1319 /* This should not be marked tainted if the fp is marked clean */
bbce6d69 1320 if (!(IoFLAGS(io) & IOf_UNTAINT))
1321 SvTAINTED_on(bufsv);
a0d0e21e
LW		 1322 SP = ORIGMARK;
1323 PUSHi(length);
1324 RETURN;
1325
1326 say_undef:
1327 SP = ORIGMARK;
1328 RETPUSHUNDEF;
1329}
1330
1331PP(pp_syswrite)
1332{
1333 return pp_send(ARGS);
1334}
1335
1336PP(pp_send)
1337{
1338 dSP; dMARK; dORIGMARK; dTARGET;
1339 GV *gv;
1340 IO *io;
1341 int offset;
748a9306 1342 SV *bufsv;
a0d0e21e
LW		 1343 char *buffer;
1344 int length;
1345 STRLEN blen;
1346
1347 gv = (GV*)*++MARK;
1348 if (!gv)
1349 goto say_undef;
748a9306
LW		 1350 bufsv = *++MARK;
1351 buffer = SvPV(bufsv, blen);
a0d0e21e
LW		 1352 length = SvIVx(*++MARK);
1353 if (length < 0)
1354 DIE("Negative length");
748a9306 1355 SETERRNO(0,0);
a0d0e21e
LW		 1356 io = GvIO(gv);
1357 if (!io || !IoIFP(io)) {
1358 length = -1;
1359 if (dowarn) {
1360 if (op->op_type == OP_SYSWRITE)
1361 warn("Syswrite on closed filehandle");
1362 else
1363 warn("Send on closed socket");
1364 }
1365 }
1366 else if (op->op_type == OP_SYSWRITE) {
bbce6d69 1367 if (MARK < SP) {
a0d0e21e 1368 offset = SvIVx(*++MARK);
bbce6d69 1369 if (offset < 0) {
1370 if (-offset > blen)
1371 DIE("Offset outside string");
1372 offset += blen;
fb73857a 1373 } else if (offset >= blen && blen > 0)
bbce6d69 1374 DIE("Offset outside string");
1375 } else
a0d0e21e
LW		 1376 offset = 0;
1377 if (length > blen - offset)
1378 length = blen - offset;
760ac839 1379 length = write(PerlIO_fileno(IoIFP(io)), buffer+offset, length);
a0d0e21e
LW		 1380 }
1381#ifdef HAS_SOCKET
1382 else if (SP > MARK) {
1383 char *sockbuf;
1384 STRLEN mlen;
1385 sockbuf = SvPVx(*++MARK, mlen);
760ac839 1386 length = sendto(PerlIO_fileno(IoIFP(io)), buffer, blen, length,
a0d0e21e
LW		 1387 (struct sockaddr *)sockbuf, mlen);
1388 }
1389 else
760ac839 1390 length = send(PerlIO_fileno(IoIFP(io)), buffer, blen, length);
490ab354 1391
a0d0e21e
LW		 1392#else
1393 else
1394 DIE(no_sock_func, "send");
1395#endif
1396 if (length < 0)
1397 goto say_undef;
1398 SP = ORIGMARK;
1399 PUSHi(length);
1400 RETURN;
1401
1402 say_undef:
1403 SP = ORIGMARK;
1404 RETPUSHUNDEF;
1405}
1406
1407PP(pp_recv)
1408{
1409 return pp_sysread(ARGS);
1410}
1411
1412PP(pp_eof)
1413{
1414 dSP;
1415 GV *gv;
1416
1417 if (MAXARG <= 0)
1418 gv = last_in_gv;
1419 else
1420 gv = last_in_gv = (GV*)POPs;
54310121 1421 PUSHs(boolSV(!gv || do_eof(gv)));
a0d0e21e
LW		 1422 RETURN;
1423}
1424
1425PP(pp_tell)
1426{
1427 dSP; dTARGET;
1428 GV *gv;
1429
1430 if (MAXARG <= 0)
1431 gv = last_in_gv;
1432 else
1433 gv = last_in_gv = (GV*)POPs;
1434 PUSHi( do_tell(gv) );
1435 RETURN;
1436}
1437
1438PP(pp_seek)
1439{
137443ea 1440 return pp_sysseek(ARGS);
1441}
1442
1443PP(pp_sysseek)
1444{
a0d0e21e
LW		 1445 dSP;
1446 GV *gv;
1447 int whence = POPi;
1448 long offset = POPl;
1449
1450 gv = last_in_gv = (GV*)POPs;
8903cb82 1451 if (op->op_type == OP_SEEK)
1452 PUSHs(boolSV(do_seek(gv, offset, whence)));
1453 else {
1454 long n = do_sysseek(gv, offset, whence);
1455 PUSHs((n < 0) ? &sv_undef
1456 : sv_2mortal(n ? newSViv((IV)n)
1457 : newSVpv(zero_but_true, ZBTLEN)));
1458 }
a0d0e21e
LW		 1459 RETURN;
1460}
1461
1462PP(pp_truncate)
1463{
1464 dSP;
1465 Off_t len = (Off_t)POPn;
1466 int result = 1;
1467 GV *tmpgv;
1468
748a9306 1469 SETERRNO(0,0);
5d94fbed 1470#if defined(HAS_TRUNCATE) || defined(HAS_CHSIZE) || defined(F_FREESP)
a0d0e21e 1471 if (op->op_flags & OPf_SPECIAL) {
1e422769 1472 tmpgv = gv_fetchpv(POPp, FALSE, SVt_PVIO);
cbdc8872 1473 do_ftruncate:
1e422769 1474 TAINT_PROPER("truncate");
a0d0e21e 1475 if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv)) ||
cbdc8872 1476#ifdef HAS_TRUNCATE
760ac839 1477 ftruncate(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
cbdc8872 1478#else
760ac839 1479 my_chsize(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
cbdc8872 1480#endif
a0d0e21e
LW		 1481 result = 0;
1482 }
1483 else {
cbdc8872 1484 SV *sv = POPs;
1e422769 1485 char *name;
1486
cbdc8872 1487 if (SvTYPE(sv) == SVt_PVGV) {
1488 tmpgv = (GV*)sv; /* *main::FRED for example */
1489 goto do_ftruncate;
1490 }
1491 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
1492 tmpgv = (GV*) SvRV(sv); /* \*main::FRED for example */
1493 goto do_ftruncate;
1494 }
1e422769 1495
1496 name = SvPV(sv, na);
1497 TAINT_PROPER("truncate");
cbdc8872 1498#ifdef HAS_TRUNCATE
1e422769 1499 if (truncate(name, len) < 0)
a0d0e21e 1500 result = 0;
cbdc8872 1501#else
1502 {
1503 int tmpfd;
1e422769 1504 if ((tmpfd = open(name, O_RDWR)) < 0)
bbce6d69 1505 result = 0;
cbdc8872 1506 else {
1507 if (my_chsize(tmpfd, len) < 0)
1508 result = 0;
1509 close(tmpfd);
1510 }
a0d0e21e 1511 }
a0d0e21e 1512#endif
cbdc8872 1513 }
a0d0e21e
LW		 1514
1515 if (result)
1516 RETPUSHYES;
1517 if (!errno)
748a9306 1518 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW		 1519 RETPUSHUNDEF;
1520#else
1521 DIE("truncate not implemented");
1522#endif
1523}
1524
1525PP(pp_fcntl)
1526{
1527 return pp_ioctl(ARGS);
1528}
1529
1530PP(pp_ioctl)
1531{
1532 dSP; dTARGET;
748a9306 1533 SV *argsv = POPs;
a0d0e21e
LW		 1534 unsigned int func = U_I(POPn);
1535 int optype = op->op_type;
1536 char *s;
324aa91a 1537 IV retval;
a0d0e21e
LW		 1538 GV *gv = (GV*)POPs;
1539 IO *io = GvIOn(gv);
1540
748a9306
LW		 1541 if (!io || !argsv || !IoIFP(io)) {
1542 SETERRNO(EBADF,RMS$_IFI); /* well, sort of... */
a0d0e21e
LW		 1543 RETPUSHUNDEF;
1544 }
1545
748a9306 1546 if (SvPOK(argsv) || !SvNIOK(argsv)) {
a0d0e21e 1547 STRLEN len;
324aa91a 1548 STRLEN need;
748a9306 1549 s = SvPV_force(argsv, len);
324aa91a
HF		 1550 need = IOCPARM_LEN(func);
1551 if (len < need) {
1552 s = Sv_Grow(argsv, need + 1);
1553 SvCUR_set(argsv, need);
a0d0e21e
LW		 1554 }
1555
748a9306 1556 s[SvCUR(argsv)] = 17; /* a little sanity check here */
a0d0e21e
LW		 1557 }
1558 else {
748a9306 1559 retval = SvIV(argsv);
a0d0e21e 1560 s = (char*)retval; /* ouch */
a0d0e21e
LW		 1561 }
1562
1563 TAINT_PROPER(optype == OP_IOCTL ? "ioctl" : "fcntl");
1564
1565 if (optype == OP_IOCTL)
1566#ifdef HAS_IOCTL
760ac839 1567 retval = ioctl(PerlIO_fileno(IoIFP(io)), func, s);
a0d0e21e
LW		 1568#else
1569 DIE("ioctl is not implemented");
1570#endif
1571 else
55497cff 1572#ifdef HAS_FCNTL
1573#if defined(OS2) && defined(__EMX__)
760ac839 1574 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
55497cff 1575#else
760ac839 1576 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
55497cff 1577#endif
1578#else
a0d0e21e 1579 DIE("fcntl is not implemented");
a0d0e21e
LW		 1580#endif
1581
748a9306
LW		 1582 if (SvPOK(argsv)) {
1583 if (s[SvCUR(argsv)] != 17)
a0d0e21e
LW		 1584 DIE("Possible memory corruption: %s overflowed 3rd argument",
1585 op_name[optype]);
748a9306
LW		 1586 s[SvCUR(argsv)] = 0; /* put our null back */
1587 SvSETMAGIC(argsv); /* Assume it has changed */
a0d0e21e
LW		 1588 }
1589
1590 if (retval == -1)
1591 RETPUSHUNDEF;
1592 if (retval != 0) {
1593 PUSHi(retval);
1594 }
1595 else {
8903cb82 1596 PUSHp(zero_but_true, ZBTLEN);
a0d0e21e
LW		 1597 }
1598 RETURN;
1599}
1600
1601PP(pp_flock)
1602{
1603 dSP; dTARGET;
1604 I32 value;
1605 int argtype;
1606 GV *gv;
760ac839 1607 PerlIO *fp;
16d20bd9 1608
ff68c719 1609#ifdef FLOCK
a0d0e21e
LW		 1610 argtype = POPi;
1611 if (MAXARG <= 0)
1612 gv = last_in_gv;
1613 else
1614 gv = (GV*)POPs;
1615 if (gv && GvIO(gv))
1616 fp = IoIFP(GvIOp(gv));
1617 else
1618 fp = Nullfp;
1619 if (fp) {
68dc0745 1620 (void)PerlIO_flush(fp);
ff68c719 1621 value = (I32)(FLOCK(PerlIO_fileno(fp), argtype) >= 0);
a0d0e21e
LW		 1622 }
1623 else
1624 value = 0;
1625 PUSHi(value);
1626 RETURN;
1627#else
a0d0e21e 1628 DIE(no_func, "flock()");
a0d0e21e
LW		 1629#endif
1630}
1631
1632/* Sockets. */
1633
1634PP(pp_socket)
1635{
1636 dSP;
1637#ifdef HAS_SOCKET
1638 GV *gv;
1639 register IO *io;
1640 int protocol = POPi;
1641 int type = POPi;
1642 int domain = POPi;
1643 int fd;
1644
1645 gv = (GV*)POPs;
1646
1647 if (!gv) {
748a9306 1648 SETERRNO(EBADF,LIB$_INVARG);
a0d0e21e
LW		 1649 RETPUSHUNDEF;
1650 }
1651
1652 io = GvIOn(gv);
1653 if (IoIFP(io))
1654 do_close(gv, FALSE);
1655
1656 TAINT_PROPER("socket");
1657 fd = socket(domain, type, protocol);
1658 if (fd < 0)
1659 RETPUSHUNDEF;
760ac839
LW		 1660 IoIFP(io) = PerlIO_fdopen(fd, "r"); /* stdio gets confused about sockets */
1661 IoOFP(io) = PerlIO_fdopen(fd, "w");
a0d0e21e
LW		 1662 IoTYPE(io) = 's';
1663 if (!IoIFP(io) || !IoOFP(io)) {
760ac839
LW		 1664 if (IoIFP(io)) PerlIO_close(IoIFP(io));
1665 if (IoOFP(io)) PerlIO_close(IoOFP(io));
a0d0e21e
LW		 1666 if (!IoIFP(io) && !IoOFP(io)) close(fd);
1667 RETPUSHUNDEF;
1668 }
1669
1670 RETPUSHYES;
1671#else
1672 DIE(no_sock_func, "socket");
1673#endif
1674}
1675
1676PP(pp_sockpair)
1677{
1678 dSP;
1679#ifdef HAS_SOCKETPAIR
1680 GV *gv1;
1681 GV *gv2;
1682 register IO *io1;
1683 register IO *io2;
1684 int protocol = POPi;
1685 int type = POPi;
1686 int domain = POPi;
1687 int fd[2];
1688
1689 gv2 = (GV*)POPs;
1690 gv1 = (GV*)POPs;
1691 if (!gv1 || !gv2)
1692 RETPUSHUNDEF;
1693
1694 io1 = GvIOn(gv1);
1695 io2 = GvIOn(gv2);
1696 if (IoIFP(io1))
1697 do_close(gv1, FALSE);
1698 if (IoIFP(io2))
1699 do_close(gv2, FALSE);
1700
1701 TAINT_PROPER("socketpair");
1702 if (socketpair(domain, type, protocol, fd) < 0)
1703 RETPUSHUNDEF;
760ac839
LW		 1704 IoIFP(io1) = PerlIO_fdopen(fd[0], "r");
1705 IoOFP(io1) = PerlIO_fdopen(fd[0], "w");
a0d0e21e 1706 IoTYPE(io1) = 's';
760ac839
LW		 1707 IoIFP(io2) = PerlIO_fdopen(fd[1], "r");
1708 IoOFP(io2) = PerlIO_fdopen(fd[1], "w");
a0d0e21e
LW		 1709 IoTYPE(io2) = 's';
1710 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
760ac839
LW		 1711 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
1712 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
a0d0e21e 1713 if (!IoIFP(io1) && !IoOFP(io1)) close(fd[0]);
760ac839
LW		 1714 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
1715 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
a0d0e21e
LW		 1716 if (!IoIFP(io2) && !IoOFP(io2)) close(fd[1]);
1717 RETPUSHUNDEF;
1718 }
1719
1720 RETPUSHYES;
1721#else
1722 DIE(no_sock_func, "socketpair");
1723#endif
1724}
1725
1726PP(pp_bind)
1727{
1728 dSP;
1729#ifdef HAS_SOCKET
748a9306 1730 SV *addrsv = POPs;
a0d0e21e
LW		 1731 char *addr;
1732 GV *gv = (GV*)POPs;
1733 register IO *io = GvIOn(gv);
1734 STRLEN len;
1735
1736 if (!io || !IoIFP(io))
1737 goto nuts;
1738
748a9306 1739 addr = SvPV(addrsv, len);
a0d0e21e 1740 TAINT_PROPER("bind");
760ac839 1741 if (bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
a0d0e21e
LW		 1742 RETPUSHYES;
1743 else
1744 RETPUSHUNDEF;
1745
1746nuts:
1747 if (dowarn)
1748 warn("bind() on closed fd");
748a9306 1749 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 1750 RETPUSHUNDEF;
1751#else
1752 DIE(no_sock_func, "bind");
1753#endif
1754}
1755
1756PP(pp_connect)
1757{
1758 dSP;
1759#ifdef HAS_SOCKET
748a9306 1760 SV *addrsv = POPs;
a0d0e21e
LW		 1761 char *addr;
1762 GV *gv = (GV*)POPs;
1763 register IO *io = GvIOn(gv);
1764 STRLEN len;
1765
1766 if (!io || !IoIFP(io))
1767 goto nuts;
1768
748a9306 1769 addr = SvPV(addrsv, len);
a0d0e21e 1770 TAINT_PROPER("connect");
760ac839 1771 if (connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
a0d0e21e
LW		 1772 RETPUSHYES;
1773 else
1774 RETPUSHUNDEF;
1775
1776nuts:
1777 if (dowarn)
1778 warn("connect() on closed fd");
748a9306 1779 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 1780 RETPUSHUNDEF;
1781#else
1782 DIE(no_sock_func, "connect");
1783#endif
1784}
1785
1786PP(pp_listen)
1787{
1788 dSP;
1789#ifdef HAS_SOCKET
1790 int backlog = POPi;
1791 GV *gv = (GV*)POPs;
1792 register IO *io = GvIOn(gv);
1793
1794 if (!io || !IoIFP(io))
1795 goto nuts;
1796
760ac839 1797 if (listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
a0d0e21e
LW		 1798 RETPUSHYES;
1799 else
1800 RETPUSHUNDEF;
1801
1802nuts:
1803 if (dowarn)
1804 warn("listen() on closed fd");
748a9306 1805 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 1806 RETPUSHUNDEF;
1807#else
1808 DIE(no_sock_func, "listen");
1809#endif
1810}
1811
1812PP(pp_accept)
1813{
1814 dSP; dTARGET;
1815#ifdef HAS_SOCKET
1816 GV *ngv;
1817 GV *ggv;
1818 register IO *nstio;
1819 register IO *gstio;
4633a7c4 1820 struct sockaddr saddr; /* use a struct to avoid alignment problems */
1e422769 1821 Sock_size_t len = sizeof saddr;
a0d0e21e
LW		 1822 int fd;
1823
1824 ggv = (GV*)POPs;
1825 ngv = (GV*)POPs;
1826
1827 if (!ngv)
1828 goto badexit;
1829 if (!ggv)
1830 goto nuts;
1831
1832 gstio = GvIO(ggv);
1833 if (!gstio || !IoIFP(gstio))
1834 goto nuts;
1835
1836 nstio = GvIOn(ngv);
1837 if (IoIFP(nstio))
1838 do_close(ngv, FALSE);
1839
760ac839 1840 fd = accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *)&saddr, &len);
a0d0e21e
LW		 1841 if (fd < 0)
1842 goto badexit;
760ac839
LW		 1843 IoIFP(nstio) = PerlIO_fdopen(fd, "r");
1844 IoOFP(nstio) = PerlIO_fdopen(fd, "w");
a0d0e21e
LW		 1845 IoTYPE(nstio) = 's';
1846 if (!IoIFP(nstio) || !IoOFP(nstio)) {
760ac839
LW		 1847 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
1848 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
a0d0e21e
LW		 1849 if (!IoIFP(nstio) && !IoOFP(nstio)) close(fd);
1850 goto badexit;
1851 }
1852
748a9306 1853 PUSHp((char *)&saddr, len);
a0d0e21e
LW		 1854 RETURN;
1855
1856nuts:
1857 if (dowarn)
1858 warn("accept() on closed fd");
748a9306 1859 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 1860
1861badexit:
1862 RETPUSHUNDEF;
1863
1864#else
1865 DIE(no_sock_func, "accept");
1866#endif
1867}
1868
1869PP(pp_shutdown)
1870{
1871 dSP; dTARGET;
1872#ifdef HAS_SOCKET
1873 int how = POPi;
1874 GV *gv = (GV*)POPs;
1875 register IO *io = GvIOn(gv);
1876
1877 if (!io || !IoIFP(io))
1878 goto nuts;
1879
760ac839 1880 PUSHi( shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
a0d0e21e
LW		 1881 RETURN;
1882
1883nuts:
1884 if (dowarn)
1885 warn("shutdown() on closed fd");
748a9306 1886 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 1887 RETPUSHUNDEF;
1888#else
1889 DIE(no_sock_func, "shutdown");
1890#endif
1891}
1892
1893PP(pp_gsockopt)
1894{
1895#ifdef HAS_SOCKET
1896 return pp_ssockopt(ARGS);
1897#else
1898 DIE(no_sock_func, "getsockopt");
1899#endif
1900}
1901
1902PP(pp_ssockopt)
1903{
1904 dSP;
1905#ifdef HAS_SOCKET
1906 int optype = op->op_type;
1907 SV *sv;
1908 int fd;
1909 unsigned int optname;
1910 unsigned int lvl;
1911 GV *gv;
1912 register IO *io;
1e422769 1913 Sock_size_t len;
a0d0e21e
LW		 1914
1915 if (optype == OP_GSOCKOPT)
1916 sv = sv_2mortal(NEWSV(22, 257));
1917 else
1918 sv = POPs;
1919 optname = (unsigned int) POPi;
1920 lvl = (unsigned int) POPi;
1921
1922 gv = (GV*)POPs;
1923 io = GvIOn(gv);
1924 if (!io || !IoIFP(io))
1925 goto nuts;
1926
760ac839 1927 fd = PerlIO_fileno(IoIFP(io));
a0d0e21e
LW		 1928 switch (optype) {
1929 case OP_GSOCKOPT:
748a9306 1930 SvGROW(sv, 257);
a0d0e21e 1931 (void)SvPOK_only(sv);
748a9306
LW		 1932 SvCUR_set(sv,256);
1933 *SvEND(sv) ='\0';
1e422769 1934 len = SvCUR(sv);
1935 if (getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
a0d0e21e 1936 goto nuts2;
1e422769 1937 SvCUR_set(sv, len);
748a9306 1938 *SvEND(sv) ='\0';
a0d0e21e
LW		 1939 PUSHs(sv);
1940 break;
1941 case OP_SSOCKOPT: {
1e422769 1942 char *buf;
1943 int aint;
1944 if (SvPOKp(sv)) {
1945 buf = SvPV(sv, na);
1946 len = na;
1947 }
a0d0e21e
LW		 1948 else if (SvOK(sv)) {
1949 aint = (int)SvIV(sv);
1950 buf = (char*)&aint;
1951 len = sizeof(int);
1952 }
1e422769 1953 if (setsockopt(fd, lvl, optname, buf, len) < 0)
a0d0e21e
LW		 1954 goto nuts2;
1955 PUSHs(&sv_yes);
1956 }
1957 break;
1958 }
1959 RETURN;
1960
1961nuts:
1962 if (dowarn)
1963 warn("[gs]etsockopt() on closed fd");
748a9306 1964 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 1965nuts2:
1966 RETPUSHUNDEF;
1967
1968#else
1969 DIE(no_sock_func, "setsockopt");
1970#endif
1971}
1972
1973PP(pp_getsockname)
1974{
1975#ifdef HAS_SOCKET
1976 return pp_getpeername(ARGS);
1977#else
1978 DIE(no_sock_func, "getsockname");
1979#endif
1980}
1981
1982PP(pp_getpeername)
1983{
1984 dSP;
1985#ifdef HAS_SOCKET
1986 int optype = op->op_type;
1987 SV *sv;
1988 int fd;
1989 GV *gv = (GV*)POPs;
1990 register IO *io = GvIOn(gv);
1e422769 1991 Sock_size_t len;
a0d0e21e
LW		 1992
1993 if (!io || !IoIFP(io))
1994 goto nuts;
1995
1996 sv = sv_2mortal(NEWSV(22, 257));
748a9306 1997 (void)SvPOK_only(sv);
1e422769 1998 len = 256;
1999 SvCUR_set(sv, len);
748a9306 2000 *SvEND(sv) ='\0';
760ac839 2001 fd = PerlIO_fileno(IoIFP(io));
a0d0e21e
LW		 2002 switch (optype) {
2003 case OP_GETSOCKNAME:
1e422769 2004 if (getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
a0d0e21e
LW		 2005 goto nuts2;
2006 break;
2007 case OP_GETPEERNAME:
1e422769 2008 if (getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
a0d0e21e 2009 goto nuts2;
490ab354
JH		 2010#if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2011 {
2012 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";
2013 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2014 if (((struct sockaddr *)SvPVX(sv))->sa_family == AF_INET &&
2015 !memcmp((char *)SvPVX(sv) + sizeof(u_short), nowhere,
2016 sizeof(u_short) + sizeof(struct in_addr))) {
2017 goto nuts2;
2018 }
2019 }
2020#endif
a0d0e21e
LW		 2021 break;
2022 }
13826f2c
CS		 2023#ifdef BOGUS_GETNAME_RETURN
2024 /* Interactive Unix, getpeername() and getsockname()
2025 does not return valid namelen */
1e422769 2026 if (len == BOGUS_GETNAME_RETURN)
2027 len = sizeof(struct sockaddr);
13826f2c 2028#endif
1e422769 2029 SvCUR_set(sv, len);
748a9306 2030 *SvEND(sv) ='\0';
a0d0e21e
LW		 2031 PUSHs(sv);
2032 RETURN;
2033
2034nuts:
2035 if (dowarn)
2036 warn("get{sock, peer}name() on closed fd");
748a9306 2037 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2038nuts2:
2039 RETPUSHUNDEF;
2040
2041#else
2042 DIE(no_sock_func, "getpeername");
2043#endif
2044}
2045
2046/* Stat calls. */
2047
2048PP(pp_lstat)
2049{
2050 return pp_stat(ARGS);
2051}
2052
2053PP(pp_stat)
2054{
2055 dSP;
2056 GV *tmpgv;
54310121 2057 I32 gimme;
a0d0e21e
LW		 2058 I32 max = 13;
2059
2060 if (op->op_flags & OPf_REF) {
2061 tmpgv = cGVOP->op_gv;
748a9306 2062 do_fstat:
a0d0e21e
LW		 2063 if (tmpgv != defgv) {
2064 laststype = OP_STAT;
2065 statgv = tmpgv;
2066 sv_setpv(statname, "");
36477c24 2067 laststatval = (GvIO(tmpgv) && IoIFP(GvIOp(tmpgv))
2068 ? Fstat(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), &statcache) : -1);
a0d0e21e 2069 }
36477c24 2070 if (laststatval < 0)
a0d0e21e
LW		 2071 max = 0;
2072 }
2073 else {
748a9306
LW		 2074 SV* sv = POPs;
2075 if (SvTYPE(sv) == SVt_PVGV) {
2076 tmpgv = (GV*)sv;
2077 goto do_fstat;
2078 }
2079 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2080 tmpgv = (GV*)SvRV(sv);
2081 goto do_fstat;
2082 }
2083 sv_setpv(statname, SvPV(sv,na));
a0d0e21e
LW		 2084 statgv = Nullgv;
2085#ifdef HAS_LSTAT
2086 laststype = op->op_type;
2087 if (op->op_type == OP_LSTAT)
2088 laststatval = lstat(SvPV(statname, na), &statcache);
2089 else
2090#endif
2091 laststatval = Stat(SvPV(statname, na), &statcache);
2092 if (laststatval < 0) {
2093 if (dowarn && strchr(SvPV(statname, na), '\n'))
2094 warn(warn_nl, "stat");
2095 max = 0;
2096 }
2097 }
2098
54310121 2099 gimme = GIMME_V;
2100 if (gimme != G_ARRAY) {
2101 if (gimme != G_VOID)
2102 XPUSHs(boolSV(max));
2103 RETURN;
a0d0e21e
LW		 2104 }
2105 if (max) {
36477c24 2106 EXTEND(SP, max);
2107 EXTEND_MORTAL(max);
a0d0e21e
LW		 2108 PUSHs(sv_2mortal(newSViv((I32)statcache.st_dev)));
2109 PUSHs(sv_2mortal(newSViv((I32)statcache.st_ino)));
2110 PUSHs(sv_2mortal(newSViv((I32)statcache.st_mode)));
2111 PUSHs(sv_2mortal(newSViv((I32)statcache.st_nlink)));
2112 PUSHs(sv_2mortal(newSViv((I32)statcache.st_uid)));
2113 PUSHs(sv_2mortal(newSViv((I32)statcache.st_gid)));
cbdc8872 2114#ifdef USE_STAT_RDEV
a0d0e21e 2115 PUSHs(sv_2mortal(newSViv((I32)statcache.st_rdev)));
cbdc8872 2116#else
2117 PUSHs(sv_2mortal(newSVpv("", 0)));
2118#endif
a0d0e21e 2119 PUSHs(sv_2mortal(newSViv((I32)statcache.st_size)));
cbdc8872 2120#ifdef BIG_TIME
2121 PUSHs(sv_2mortal(newSVnv((U32)statcache.st_atime)));
2122 PUSHs(sv_2mortal(newSVnv((U32)statcache.st_mtime)));
2123 PUSHs(sv_2mortal(newSVnv((U32)statcache.st_ctime)));
2124#else
a0d0e21e
LW		 2125 PUSHs(sv_2mortal(newSViv((I32)statcache.st_atime)));
2126 PUSHs(sv_2mortal(newSViv((I32)statcache.st_mtime)));
2127 PUSHs(sv_2mortal(newSViv((I32)statcache.st_ctime)));
cbdc8872 2128#endif
a0d0e21e
LW		 2129#ifdef USE_STAT_BLOCKS
2130 PUSHs(sv_2mortal(newSViv((I32)statcache.st_blksize)));
2131 PUSHs(sv_2mortal(newSViv((I32)statcache.st_blocks)));
2132#else
2133 PUSHs(sv_2mortal(newSVpv("", 0)));
2134 PUSHs(sv_2mortal(newSVpv("", 0)));
2135#endif
2136 }
2137 RETURN;
2138}
2139
2140PP(pp_ftrread)
2141{
2142 I32 result = my_stat(ARGS);
2143 dSP;
2144 if (result < 0)
2145 RETPUSHUNDEF;
2146 if (cando(S_IRUSR, 0, &statcache))
2147 RETPUSHYES;
2148 RETPUSHNO;
2149}
2150
2151PP(pp_ftrwrite)
2152{
2153 I32 result = my_stat(ARGS);
2154 dSP;
2155 if (result < 0)
2156 RETPUSHUNDEF;
2157 if (cando(S_IWUSR, 0, &statcache))
2158 RETPUSHYES;
2159 RETPUSHNO;
2160}
2161
2162PP(pp_ftrexec)
2163{
2164 I32 result = my_stat(ARGS);
2165 dSP;
2166 if (result < 0)
2167 RETPUSHUNDEF;
2168 if (cando(S_IXUSR, 0, &statcache))
2169 RETPUSHYES;
2170 RETPUSHNO;
2171}
2172
2173PP(pp_fteread)
2174{
2175 I32 result = my_stat(ARGS);
2176 dSP;
2177 if (result < 0)
2178 RETPUSHUNDEF;
2179 if (cando(S_IRUSR, 1, &statcache))
2180 RETPUSHYES;
2181 RETPUSHNO;
2182}
2183
2184PP(pp_ftewrite)
2185{
2186 I32 result = my_stat(ARGS);
2187 dSP;
2188 if (result < 0)
2189 RETPUSHUNDEF;
2190 if (cando(S_IWUSR, 1, &statcache))
2191 RETPUSHYES;
2192 RETPUSHNO;
2193}
2194
2195PP(pp_fteexec)
2196{
2197 I32 result = my_stat(ARGS);
2198 dSP;
2199 if (result < 0)
2200 RETPUSHUNDEF;
2201 if (cando(S_IXUSR, 1, &statcache))
2202 RETPUSHYES;
2203 RETPUSHNO;
2204}
2205
2206PP(pp_ftis)
2207{
2208 I32 result = my_stat(ARGS);
2209 dSP;
2210 if (result < 0)
2211 RETPUSHUNDEF;
2212 RETPUSHYES;
2213}
2214
2215PP(pp_fteowned)
2216{
2217 return pp_ftrowned(ARGS);
2218}
2219
2220PP(pp_ftrowned)
2221{
2222 I32 result = my_stat(ARGS);
2223 dSP;
2224 if (result < 0)
2225 RETPUSHUNDEF;
2226 if (statcache.st_uid == (op->op_type == OP_FTEOWNED ? euid : uid) )
2227 RETPUSHYES;
2228 RETPUSHNO;
2229}
2230
2231PP(pp_ftzero)
2232{
2233 I32 result = my_stat(ARGS);
2234 dSP;
2235 if (result < 0)
2236 RETPUSHUNDEF;
2237 if (!statcache.st_size)
2238 RETPUSHYES;
2239 RETPUSHNO;
2240}
2241
2242PP(pp_ftsize)
2243{
2244 I32 result = my_stat(ARGS);
2245 dSP; dTARGET;
2246 if (result < 0)
2247 RETPUSHUNDEF;
2248 PUSHi(statcache.st_size);
2249 RETURN;
2250}
2251
2252PP(pp_ftmtime)
2253{
2254 I32 result = my_stat(ARGS);
2255 dSP; dTARGET;
2256 if (result < 0)
2257 RETPUSHUNDEF;
53a31ece 2258 PUSHn( ((I32)basetime - (I32)statcache.st_mtime) / 86400.0 );
a0d0e21e
LW		 2259 RETURN;
2260}
2261
2262PP(pp_ftatime)
2263{
2264 I32 result = my_stat(ARGS);
2265 dSP; dTARGET;
2266 if (result < 0)
2267 RETPUSHUNDEF;
53a31ece 2268 PUSHn( ((I32)basetime - (I32)statcache.st_atime) / 86400.0 );
a0d0e21e
LW		 2269 RETURN;
2270}
2271
2272PP(pp_ftctime)
2273{
2274 I32 result = my_stat(ARGS);
2275 dSP; dTARGET;
2276 if (result < 0)
2277 RETPUSHUNDEF;
53a31ece 2278 PUSHn( ((I32)basetime - (I32)statcache.st_ctime) / 86400.0 );
a0d0e21e
LW		 2279 RETURN;
2280}
2281
2282PP(pp_ftsock)
2283{
2284 I32 result = my_stat(ARGS);
2285 dSP;
2286 if (result < 0)
2287 RETPUSHUNDEF;
2288 if (S_ISSOCK(statcache.st_mode))
2289 RETPUSHYES;
2290 RETPUSHNO;
2291}
2292
2293PP(pp_ftchr)
2294{
2295 I32 result = my_stat(ARGS);
2296 dSP;
2297 if (result < 0)
2298 RETPUSHUNDEF;
2299 if (S_ISCHR(statcache.st_mode))
2300 RETPUSHYES;
2301 RETPUSHNO;
2302}
2303
2304PP(pp_ftblk)
2305{
2306 I32 result = my_stat(ARGS);
2307 dSP;
2308 if (result < 0)
2309 RETPUSHUNDEF;
2310 if (S_ISBLK(statcache.st_mode))
2311 RETPUSHYES;
2312 RETPUSHNO;
2313}
2314
2315PP(pp_ftfile)
2316{
2317 I32 result = my_stat(ARGS);
2318 dSP;
2319 if (result < 0)
2320 RETPUSHUNDEF;
2321 if (S_ISREG(statcache.st_mode))
2322 RETPUSHYES;
2323 RETPUSHNO;
2324}
2325
2326PP(pp_ftdir)
2327{
2328 I32 result = my_stat(ARGS);
2329 dSP;
2330 if (result < 0)
2331 RETPUSHUNDEF;
2332 if (S_ISDIR(statcache.st_mode))
2333 RETPUSHYES;
2334 RETPUSHNO;
2335}
2336
2337PP(pp_ftpipe)
2338{
2339 I32 result = my_stat(ARGS);
2340 dSP;
2341 if (result < 0)
2342 RETPUSHUNDEF;
2343 if (S_ISFIFO(statcache.st_mode))
2344 RETPUSHYES;
2345 RETPUSHNO;
2346}
2347
2348PP(pp_ftlink)
2349{
2350 I32 result = my_lstat(ARGS);
2351 dSP;
2352 if (result < 0)
2353 RETPUSHUNDEF;
2354 if (S_ISLNK(statcache.st_mode))
2355 RETPUSHYES;
2356 RETPUSHNO;
2357}
2358
2359PP(pp_ftsuid)
2360{
2361 dSP;
2362#ifdef S_ISUID
2363 I32 result = my_stat(ARGS);
2364 SPAGAIN;
2365 if (result < 0)
2366 RETPUSHUNDEF;
2367 if (statcache.st_mode & S_ISUID)
2368 RETPUSHYES;
2369#endif
2370 RETPUSHNO;
2371}
2372
2373PP(pp_ftsgid)
2374{
2375 dSP;
2376#ifdef S_ISGID
2377 I32 result = my_stat(ARGS);
2378 SPAGAIN;
2379 if (result < 0)
2380 RETPUSHUNDEF;
2381 if (statcache.st_mode & S_ISGID)
2382 RETPUSHYES;
2383#endif
2384 RETPUSHNO;
2385}
2386
2387PP(pp_ftsvtx)
2388{
2389 dSP;
2390#ifdef S_ISVTX
2391 I32 result = my_stat(ARGS);
2392 SPAGAIN;
2393 if (result < 0)
2394 RETPUSHUNDEF;
2395 if (statcache.st_mode & S_ISVTX)
2396 RETPUSHYES;
2397#endif
2398 RETPUSHNO;
2399}
2400
2401PP(pp_fttty)
2402{
2403 dSP;
2404 int fd;
2405 GV *gv;
fb73857a 2406 char *tmps = Nullch;
2407
2408 if (op->op_flags & OPf_REF)
a0d0e21e 2409 gv = cGVOP->op_gv;
fb73857a 2410 else if (isGV(TOPs))
2411 gv = (GV*)POPs;
2412 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
2413 gv = (GV*)SvRV(POPs);
a0d0e21e
LW		 2414 else
2415 gv = gv_fetchpv(tmps = POPp, FALSE, SVt_PVIO);
fb73857a 2416
a0d0e21e 2417 if (GvIO(gv) && IoIFP(GvIOp(gv)))
760ac839 2418 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
fb73857a 2419 else if (tmps && isDIGIT(*tmps))
a0d0e21e
LW		 2420 fd = atoi(tmps);
2421 else
2422 RETPUSHUNDEF;
2423 if (isatty(fd))
2424 RETPUSHYES;
2425 RETPUSHNO;
2426}
2427
16d20bd9
AD		 2428#if defined(atarist) /* this will work with atariST. Configure will
2429 make guesses for other systems. */
2430# define FILE_base(f) ((f)->_base)
2431# define FILE_ptr(f) ((f)->_ptr)
2432# define FILE_cnt(f) ((f)->_cnt)
2433# define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
a0d0e21e
LW		 2434#endif
2435
2436PP(pp_fttext)
2437{
2438 dSP;
2439 I32 i;
2440 I32 len;
2441 I32 odd = 0;
2442 STDCHAR tbuf[512];
2443 register STDCHAR *s;
2444 register IO *io;
5f05dabc 2445 register SV *sv;
2446 GV *gv;
a0d0e21e 2447
5f05dabc 2448 if (op->op_flags & OPf_REF)
2449 gv = cGVOP->op_gv;
2450 else if (isGV(TOPs))
2451 gv = (GV*)POPs;
2452 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
2453 gv = (GV*)SvRV(POPs);
2454 else
2455 gv = Nullgv;
2456
2457 if (gv) {
a0d0e21e 2458 EXTEND(SP, 1);
5f05dabc 2459 if (gv == defgv) {
a0d0e21e
LW		 2460 if (statgv)
2461 io = GvIO(statgv);
2462 else {
2463 sv = statname;
2464 goto really_filename;
2465 }
2466 }
2467 else {
5f05dabc 2468 statgv = gv;
2469 laststatval = -1;
a0d0e21e
LW		 2470 sv_setpv(statname, "");
2471 io = GvIO(statgv);
2472 }
2473 if (io && IoIFP(io)) {
5f05dabc 2474 if (! PerlIO_has_base(IoIFP(io)))
2475 DIE("-T and -B not implemented on filehandles");
2476 laststatval = Fstat(PerlIO_fileno(IoIFP(io)), &statcache);
2477 if (laststatval < 0)
2478 RETPUSHUNDEF;
a0d0e21e
LW		 2479 if (S_ISDIR(statcache.st_mode)) /* handle NFS glitch */
2480 if (op->op_type == OP_FTTEXT)
2481 RETPUSHNO;
2482 else
2483 RETPUSHYES;
760ac839
LW		 2484 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
2485 i = PerlIO_getc(IoIFP(io));
a0d0e21e 2486 if (i != EOF)
760ac839 2487 (void)PerlIO_ungetc(IoIFP(io),i);
a0d0e21e 2488 }
760ac839 2489 if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
a0d0e21e 2490 RETPUSHYES;
760ac839
LW		 2491 len = PerlIO_get_bufsiz(IoIFP(io));
2492 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
2493 /* sfio can have large buffers - limit to 512 */
2494 if (len > 512)
2495 len = 512;
a0d0e21e
LW		 2496 }
2497 else {
2498 if (dowarn)
2499 warn("Test on unopened file <%s>",
2500 GvENAME(cGVOP->op_gv));
748a9306 2501 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW		 2502 RETPUSHUNDEF;
2503 }
2504 }
2505 else {
2506 sv = POPs;
5f05dabc 2507 really_filename:
a0d0e21e 2508 statgv = Nullgv;
5f05dabc 2509 laststatval = -1;
a0d0e21e 2510 sv_setpv(statname, SvPV(sv, na));
a0d0e21e
LW		 2511#ifdef HAS_OPEN3
2512 i = open(SvPV(sv, na), O_RDONLY, 0);
2513#else
2514 i = open(SvPV(sv, na), 0);
2515#endif
2516 if (i < 0) {
2517 if (dowarn && strchr(SvPV(sv, na), '\n'))
2518 warn(warn_nl, "open");
2519 RETPUSHUNDEF;
2520 }
5f05dabc 2521 laststatval = Fstat(i, &statcache);
2522 if (laststatval < 0)
2523 RETPUSHUNDEF;
a0d0e21e
LW		 2524 len = read(i, tbuf, 512);
2525 (void)close(i);
2526 if (len <= 0) {
2527 if (S_ISDIR(statcache.st_mode) && op->op_type == OP_FTTEXT)
2528 RETPUSHNO; /* special case NFS directories */
2529 RETPUSHYES; /* null file is anything */
2530 }
2531 s = tbuf;
2532 }
2533
2534 /* now scan s to look for textiness */
4633a7c4 2535 /* XXX ASCII dependent code */
a0d0e21e
LW		 2536
2537 for (i = 0; i < len; i++, s++) {
2538 if (!*s) { /* null never allowed in text */
2539 odd += len;
2540 break;
2541 }
2542 else if (*s & 128)
2543 odd++;
2544 else if (*s < 32 &&
2545 *s != '\n' && *s != '\r' && *s != '\b' &&
2546 *s != '\t' && *s != '\f' && *s != 27)
2547 odd++;
2548 }
2549
4633a7c4 2550 if ((odd * 3 > len) == (op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
a0d0e21e
LW		 2551 RETPUSHNO;
2552 else
2553 RETPUSHYES;
2554}
2555
2556PP(pp_ftbinary)
2557{
2558 return pp_fttext(ARGS);
2559}
2560
2561/* File calls. */
2562
2563PP(pp_chdir)
2564{
2565 dSP; dTARGET;
2566 char *tmps;
2567 SV **svp;
2568
2569 if (MAXARG < 1)
2570 tmps = Nullch;
2571 else
2572 tmps = POPp;
2573 if (!tmps || !*tmps) {
2574 svp = hv_fetch(GvHVn(envgv), "HOME", 4, FALSE);
2575 if (svp)
2576 tmps = SvPV(*svp, na);
2577 }
2578 if (!tmps || !*tmps) {
2579 svp = hv_fetch(GvHVn(envgv), "LOGDIR", 6, FALSE);
2580 if (svp)
2581 tmps = SvPV(*svp, na);
2582 }
2583 TAINT_PROPER("chdir");
2584 PUSHi( 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{
2595 dSP; dMARK; dTARGET;
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{
2609 dSP; dTARGET;
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{
2623 dSP; dMARK; dTARGET;
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{
2633 dSP; dMARK; dTARGET;
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{
2643 dSP; dMARK; dTARGET;
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{
2653 dSP; dTARGET;
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
ed969818
W		 2662 if (!(anum = Stat(tmps, &statbuf))) {
2663 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
2664 anum = 1;
2665 else {
2666 if (euid || Stat(tmps2, &statbuf) < 0 || !S_ISDIR(statbuf.st_mode))
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{
2679 dSP; dTARGET;
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{
2693 dSP; dTARGET;
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{
2707 dSP; dTARGET;
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");
1e422769 2749 myfp = my_popen(cmdline, "r");
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);
a0d0e21e
LW		 2756 (void)my_pclose(myfp);
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 */
5d94fbed 2803 anum = (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{
2820 dSP; dTARGET;
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
8cc95fdb 2829 SETi( Mkdir(tmps, mode) >= 0 );
a0d0e21e
LW		 2830#else
2831 SETi( dooneliner("mkdir", tmps) );
2832 oldumask = umask(0);
2833 umask(oldumask);
2834 chmod(tmps, (mode & ~oldumask) & 0777);
2835#endif
2836 RETURN;
2837}
2838
2839PP(pp_rmdir)
2840{
2841 dSP; dTARGET;
2842 char *tmps;
2843
2844 tmps = POPp;
2845 TAINT_PROPER("rmdir");
2846#ifdef HAS_RMDIR
2847 XPUSHi( rmdir(tmps) >= 0 );
2848#else
2849 XPUSHi( dooneliner("rmdir", tmps) );
2850#endif
2851 RETURN;
2852}
2853
2854/* Directory calls. */
2855
2856PP(pp_open_dir)
2857{
2858 dSP;
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))
2868 closedir(IoDIRP(io));
2869 if (!(IoDIRP(io) = opendir(dirname)))
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{
2884 dSP;
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*/
2899 while (dp = (Direntry_t *)readdir(IoDIRP(io))) {
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 {
2912 if (!(dp = (Direntry_t *)readdir(IoDIRP(io))))
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{
2940 dSP; dTARGET;
2941#if defined(HAS_TELLDIR) || defined(telldir)
2942#if !defined(telldir) && !defined(HAS_TELLDIR_PROTOTYPE)
2943 long telldir _((DIR *));
2944#endif
2945 GV *gv = (GV*)POPs;
2946 register IO *io = GvIOn(gv);
2947
2948 if (!io || !IoDIRP(io))
2949 goto nope;
2950
2951 PUSHi( telldir(IoDIRP(io)) );
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{
2964 dSP;
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
2973 (void)seekdir(IoDIRP(io), along);
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{
2987 dSP;
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
2995 (void)rewinddir(IoDIRP(io));
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{
3008 dSP;
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
3017 closedir(IoDIRP(io));
3018#else
748a9306
LW		 3019 if (closedir(IoDIRP(io)) < 0) {
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
a0d0e21e
LW		 3041 dSP; dTARGET;
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{
44a8e56a 3064#if !defined(DOSISH) || defined(OS2)
a0d0e21e
LW		 3065 dSP; dTARGET;
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{
44a8e56a 3080#if !defined(DOSISH) || defined(OS2)
a0d0e21e
LW		 3081 dSP; dTARGET;
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
3093 DIE(no_func, "Unsupported function wait");
3094#endif
3095}
3096
3097PP(pp_system)
3098{
3099 dSP; dMARK; dORIGMARK; dTARGET;
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 }
3146 _exit(-1);
c3293030 3147#else /* ! FORK or VMS or OS/2 */
a0d0e21e
LW		 3148 if (op->op_flags & OPf_STACKED) {
3149 SV *really = *++MARK;
3150 value = (I32)do_aspawn(really, MARK, SP);
3151 }
3152 else if (SP - MARK != 1)
3153 value = (I32)do_aspawn(Nullsv, MARK, SP);
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{
3167 dSP; dMARK; dORIGMARK; dTARGET;
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{
3199 dSP; dMARK; dTARGET;
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
3214 dSP; dTARGET;
3215 XPUSHi( getppid() );
3216 RETURN;
3217#else
3218 DIE(no_func, "getppid");
3219#endif
3220}
3221
3222PP(pp_getpgrp)
3223{
3224#ifdef HAS_GETPGRP
3225 dSP; dTARGET;
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
3250 dSP; dTARGET;
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{
3278 dSP; dTARGET;
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{
3293 dSP; dTARGET;
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{
3313 dSP; 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{
3340 dSP;
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{
3372 dSP;
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{
3426 dSP; dTARGET;
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{
3443 dSP; dTARGET;
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)
3480 dSP; dMARK; dTARGET;
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)
3505 dSP; dMARK; dTARGET;
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)
3518 dSP; dMARK; dTARGET;
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)
3533 dSP; dMARK; dTARGET;
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)
3548 dSP; dMARK; dTARGET;
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)
3568 dSP; dMARK; dTARGET;
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{
3582#ifdef HAS_SOCKET
3583 return pp_ghostent(ARGS);
3584#else
3585 DIE(no_sock_func, "gethostbyname");
3586#endif
3587}
3588
3589PP(pp_ghbyaddr)
3590{
3591#ifdef HAS_SOCKET
3592 return pp_ghostent(ARGS);
3593#else
3594 DIE(no_sock_func, "gethostbyaddr");
3595#endif
3596}
3597
3598PP(pp_ghostent)
3599{
3600 dSP;
3601#ifdef HAS_SOCKET
3602 I32 which = op->op_type;
3603 register char **elem;
3604 register SV *sv;
3605 struct hostent *gethostbyname();
3606 struct hostent *gethostbyaddr();
3607#ifdef HAS_GETHOSTENT
3608 struct hostent *gethostent();
3609#endif
3610 struct hostent *hent;
3611 unsigned long len;
3612
3613 EXTEND(SP, 10);
3614 if (which == OP_GHBYNAME) {
3615 hent = gethostbyname(POPp);
3616 }
3617 else if (which == OP_GHBYADDR) {
3618 int addrtype = POPi;
748a9306 3619 SV *addrsv = POPs;
a0d0e21e 3620 STRLEN addrlen;
748a9306 3621 char *addr = SvPV(addrsv, addrlen);
a0d0e21e
LW		 3622
3623 hent = gethostbyaddr(addr, addrlen, addrtype);
3624 }
3625 else
3626#ifdef HAS_GETHOSTENT
3627 hent = gethostent();
3628#else
3629 DIE("gethostent not implemented");
3630#endif
3631
3632#ifdef HOST_NOT_FOUND
3633 if (!hent)
f86702cc 3634 STATUS_NATIVE_SET(h_errno);
a0d0e21e
LW		 3635#endif
3636
3637 if (GIMME != G_ARRAY) {
3638 PUSHs(sv = sv_newmortal());
3639 if (hent) {
3640 if (which == OP_GHBYNAME) {
fd0af264 3641 if (hent->h_addr)
3642 sv_setpvn(sv, hent->h_addr, hent->h_length);
a0d0e21e
LW		 3643 }
3644 else
3645 sv_setpv(sv, (char*)hent->h_name);
3646 }
3647 RETURN;
3648 }
3649
3650 if (hent) {
3651 PUSHs(sv = sv_mortalcopy(&sv_no));
3652 sv_setpv(sv, (char*)hent->h_name);
3653 PUSHs(sv = sv_mortalcopy(&sv_no));
3654 for (elem = hent->h_aliases; elem && *elem; elem++) {
3655 sv_catpv(sv, *elem);
3656 if (elem[1])
3657 sv_catpvn(sv, " ", 1);
3658 }
3659 PUSHs(sv = sv_mortalcopy(&sv_no));
1e422769 3660 sv_setiv(sv, (IV)hent->h_addrtype);
a0d0e21e
LW		 3661 PUSHs(sv = sv_mortalcopy(&sv_no));
3662 len = hent->h_length;
1e422769 3663 sv_setiv(sv, (IV)len);
a0d0e21e
LW		 3664#ifdef h_addr
3665 for (elem = hent->h_addr_list; elem && *elem; elem++) {
3666 XPUSHs(sv = sv_mortalcopy(&sv_no));
3667 sv_setpvn(sv, *elem, len);
3668 }
3669#else
3670 PUSHs(sv = sv_mortalcopy(&sv_no));
fd0af264 3671 if (hent->h_addr)
3672 sv_setpvn(sv, hent->h_addr, len);
a0d0e21e
LW		 3673#endif /* h_addr */
3674 }
3675 RETURN;
3676#else
3677 DIE(no_sock_func, "gethostent");
3678#endif
3679}
3680
3681PP(pp_gnbyname)
3682{
3683#ifdef HAS_SOCKET
3684 return pp_gnetent(ARGS);
3685#else
3686 DIE(no_sock_func, "getnetbyname");
3687#endif
3688}
3689
3690PP(pp_gnbyaddr)
3691{
3692#ifdef HAS_SOCKET
3693 return pp_gnetent(ARGS);
3694#else
3695 DIE(no_sock_func, "getnetbyaddr");
3696#endif
3697}
3698
3699PP(pp_gnetent)
3700{
3701 dSP;
3702#ifdef HAS_SOCKET
3703 I32 which = op->op_type;
3704 register char **elem;
3705 register SV *sv;
3706 struct netent *getnetbyname();
3707 struct netent *getnetbyaddr();
3708 struct netent *getnetent();
3709 struct netent *nent;
3710
3711 if (which == OP_GNBYNAME)
3712 nent = getnetbyname(POPp);
3713 else if (which == OP_GNBYADDR) {
3714 int addrtype = POPi;
3715 unsigned long addr = U_L(POPn);
3716 nent = getnetbyaddr((long)addr, addrtype);
3717 }
3718 else
3719 nent = getnetent();
3720
3721 EXTEND(SP, 4);
3722 if (GIMME != G_ARRAY) {
3723 PUSHs(sv = sv_newmortal());
3724 if (nent) {
3725 if (which == OP_GNBYNAME)
1e422769 3726 sv_setiv(sv, (IV)nent->n_net);
a0d0e21e
LW		 3727 else
3728 sv_setpv(sv, nent->n_name);
3729 }
3730 RETURN;
3731 }
3732
3733 if (nent) {
3734 PUSHs(sv = sv_mortalcopy(&sv_no));
3735 sv_setpv(sv, nent->n_name);
3736 PUSHs(sv = sv_mortalcopy(&sv_no));
c90c0ff4 3737 for (elem = nent->n_aliases; elem && *elem; elem++) {
a0d0e21e
LW		 3738 sv_catpv(sv, *elem);
3739 if (elem[1])
3740 sv_catpvn(sv, " ", 1);
3741 }
3742 PUSHs(sv = sv_mortalcopy(&sv_no));
1e422769 3743 sv_setiv(sv, (IV)nent->n_addrtype);
a0d0e21e 3744 PUSHs(sv = sv_mortalcopy(&sv_no));
1e422769 3745 sv_setiv(sv, (IV)nent->n_net);
a0d0e21e
LW		 3746 }
3747
3748 RETURN;
3749#else
3750 DIE(no_sock_func, "getnetent");
3751#endif
3752}
3753
3754PP(pp_gpbyname)
3755{
3756#ifdef HAS_SOCKET
3757 return pp_gprotoent(ARGS);
3758#else
3759 DIE(no_sock_func, "getprotobyname");
3760#endif
3761}
3762
3763PP(pp_gpbynumber)
3764{
3765#ifdef HAS_SOCKET
3766 return pp_gprotoent(ARGS);
3767#else
3768 DIE(no_sock_func, "getprotobynumber");
3769#endif
3770}
3771
3772PP(pp_gprotoent)
3773{
3774 dSP;
3775#ifdef HAS_SOCKET
3776 I32 which = op->op_type;
3777 register char **elem;
3778 register SV *sv;
3779 struct protoent *getprotobyname();
3780 struct protoent *getprotobynumber();
3781 struct protoent *getprotoent();
3782 struct protoent *pent;
3783
3784 if (which == OP_GPBYNAME)
3785 pent = getprotobyname(POPp);
3786 else if (which == OP_GPBYNUMBER)
3787 pent = getprotobynumber(POPi);
3788 else
3789 pent = getprotoent();
3790
3791 EXTEND(SP, 3);
3792 if (GIMME != G_ARRAY) {
3793 PUSHs(sv = sv_newmortal());
3794 if (pent) {
3795 if (which == OP_GPBYNAME)
1e422769 3796 sv_setiv(sv, (IV)pent->p_proto);
a0d0e21e
LW		 3797 else
3798 sv_setpv(sv, pent->p_name);
3799 }
3800 RETURN;
3801 }
3802
3803 if (pent) {
3804 PUSHs(sv = sv_mortalcopy(&sv_no));
3805 sv_setpv(sv, pent->p_name);
3806 PUSHs(sv = sv_mortalcopy(&sv_no));
c90c0ff4 3807 for (elem = pent->p_aliases; elem && *elem; elem++) {
a0d0e21e
LW		 3808 sv_catpv(sv, *elem);
3809 if (elem[1])
3810 sv_catpvn(sv, " ", 1);
3811 }
3812 PUSHs(sv = sv_mortalcopy(&sv_no));
1e422769 3813 sv_setiv(sv, (IV)pent->p_proto);
a0d0e21e
LW		 3814 }
3815
3816 RETURN;
3817#else
3818 DIE(no_sock_func, "getprotoent");
3819#endif
3820}
3821
3822PP(pp_gsbyname)
3823{
3824#ifdef HAS_SOCKET
3825 return pp_gservent(ARGS);
3826#else
3827 DIE(no_sock_func, "getservbyname");
3828#endif
3829}
3830
3831PP(pp_gsbyport)
3832{
3833#ifdef HAS_SOCKET
3834 return pp_gservent(ARGS);
3835#else
3836 DIE(no_sock_func, "getservbyport");
3837#endif
3838}
3839
3840PP(pp_gservent)
3841{
3842 dSP;
3843#ifdef HAS_SOCKET
3844 I32 which = op->op_type;
3845 register char **elem;
3846 register SV *sv;
3847 struct servent *getservbyname();
3848 struct servent *getservbynumber();
3849 struct servent *getservent();
3850 struct servent *sent;
3851
3852 if (which == OP_GSBYNAME) {
3853 char *proto = POPp;
3854 char *name = POPp;
3855
3856 if (proto && !*proto)
3857 proto = Nullch;
3858
3859 sent = getservbyname(name, proto);
3860 }
3861 else if (which == OP_GSBYPORT) {
3862 char *proto = POPp;
36477c24 3863 unsigned short port = POPu;
a0d0e21e 3864
36477c24 3865#ifdef HAS_HTONS
3866 port = htons(port);
3867#endif
a0d0e21e
LW		 3868 sent = getservbyport(port, proto);
3869 }
3870 else
3871 sent = getservent();
3872
3873 EXTEND(SP, 4);
3874 if (GIMME != G_ARRAY) {
3875 PUSHs(sv = sv_newmortal());
3876 if (sent) {
3877 if (which == OP_GSBYNAME) {
3878#ifdef HAS_NTOHS
1e422769 3879 sv_setiv(sv, (IV)ntohs(sent->s_port));
a0d0e21e 3880#else
1e422769 3881 sv_setiv(sv, (IV)(sent->s_port));
a0d0e21e
LW		 3882#endif
3883 }
3884 else
3885 sv_setpv(sv, sent->s_name);
3886 }
3887 RETURN;
3888 }
3889
3890 if (sent) {
3891 PUSHs(sv = sv_mortalcopy(&sv_no));
3892 sv_setpv(sv, sent->s_name);
3893 PUSHs(sv = sv_mortalcopy(&sv_no));
c90c0ff4 3894 for (elem = sent->s_aliases; elem && *elem; elem++) {
a0d0e21e
LW		 3895 sv_catpv(sv, *elem);
3896 if (elem[1])
3897 sv_catpvn(sv, " ", 1);
3898 }
3899 PUSHs(sv = sv_mortalcopy(&sv_no));
3900#ifdef HAS_NTOHS
1e422769 3901 sv_setiv(sv, (IV)ntohs(sent->s_port));
a0d0e21e 3902#else
1e422769 3903 sv_setiv(sv, (IV)(sent->s_port));
a0d0e21e
LW		 3904#endif
3905 PUSHs(sv = sv_mortalcopy(&sv_no));
3906 sv_setpv(sv, sent->s_proto);
3907 }
3908
3909 RETURN;
3910#else
3911 DIE(no_sock_func, "getservent");
3912#endif
3913}
3914
3915PP(pp_shostent)
3916{
3917 dSP;
3918#ifdef HAS_SOCKET
3919 sethostent(TOPi);
3920 RETSETYES;
3921#else
3922 DIE(no_sock_func, "sethostent");
3923#endif
3924}
3925
3926PP(pp_snetent)
3927{
3928 dSP;
3929#ifdef HAS_SOCKET
3930 setnetent(TOPi);
3931 RETSETYES;
3932#else
3933 DIE(no_sock_func, "setnetent");
3934#endif
3935}
3936
3937PP(pp_sprotoent)
3938{
3939 dSP;
3940#ifdef HAS_SOCKET
3941 setprotoent(TOPi);
3942 RETSETYES;
3943#else
3944 DIE(no_sock_func, "setprotoent");
3945#endif
3946}
3947
3948PP(pp_sservent)
3949{
3950 dSP;
3951#ifdef HAS_SOCKET
3952 setservent(TOPi);
3953 RETSETYES;
3954#else
3955 DIE(no_sock_func, "setservent");
3956#endif
3957}
3958
3959PP(pp_ehostent)
3960{
3961 dSP;
3962#ifdef HAS_SOCKET
3963 endhostent();
3964 EXTEND(sp,1);
3965 RETPUSHYES;
3966#else
3967 DIE(no_sock_func, "endhostent");
3968#endif
3969}
3970
3971PP(pp_enetent)
3972{
3973 dSP;
3974#ifdef HAS_SOCKET
3975 endnetent();
3976 EXTEND(sp,1);
3977 RETPUSHYES;
3978#else
3979 DIE(no_sock_func, "endnetent");
3980#endif
3981}
3982
3983PP(pp_eprotoent)
3984{
3985 dSP;
3986#ifdef HAS_SOCKET
3987 endprotoent();
3988 EXTEND(sp,1);
3989 RETPUSHYES;
3990#else
3991 DIE(no_sock_func, "endprotoent");
3992#endif
3993}
3994
3995PP(pp_eservent)
3996{
3997 dSP;
3998#ifdef HAS_SOCKET
3999 endservent();
4000 EXTEND(sp,1);
4001 RETPUSHYES;
4002#else
4003 DIE(no_sock_func, "endservent");
4004#endif
4005}
4006
4007PP(pp_gpwnam)
4008{
4009#ifdef HAS_PASSWD
4010 return pp_gpwent(ARGS);
4011#else
4012 DIE(no_func, "getpwnam");
4013#endif
4014}
4015
4016PP(pp_gpwuid)
4017{
4018#ifdef HAS_PASSWD
4019 return pp_gpwent(ARGS);
4020#else
4021 DIE(no_func, "getpwuid");
4022#endif
4023}
4024
4025PP(pp_gpwent)
4026{
4027 dSP;
4028#ifdef HAS_PASSWD
4029 I32 which = op->op_type;
4030 register SV *sv;
4031 struct passwd *pwent;
4032
4033 if (which == OP_GPWNAM)
4034 pwent = getpwnam(POPp);
4035 else if (which == OP_GPWUID)
4036 pwent = getpwuid(POPi);
4037 else
4038 pwent = (struct passwd *)getpwent();
4039
4040 EXTEND(SP, 10);
4041 if (GIMME != G_ARRAY) {
4042 PUSHs(sv = sv_newmortal());
4043 if (pwent) {
4044 if (which == OP_GPWNAM)
1e422769 4045 sv_setiv(sv, (IV)pwent->pw_uid);
a0d0e21e
LW		 4046 else
4047 sv_setpv(sv, pwent->pw_name);
4048 }
4049 RETURN;
4050 }
4051
4052 if (pwent) {
4053 PUSHs(sv = sv_mortalcopy(&sv_no));
4054 sv_setpv(sv, pwent->pw_name);
4055 PUSHs(sv = sv_mortalcopy(&sv_no));
4056 sv_setpv(sv, pwent->pw_passwd);
4057 PUSHs(sv = sv_mortalcopy(&sv_no));
1e422769 4058 sv_setiv(sv, (IV)pwent->pw_uid);
a0d0e21e 4059 PUSHs(sv = sv_mortalcopy(&sv_no));
1e422769 4060 sv_setiv(sv, (IV)pwent->pw_gid);
a0d0e21e
LW		 4061 PUSHs(sv = sv_mortalcopy(&sv_no));
4062#ifdef PWCHANGE
1e422769 4063 sv_setiv(sv, (IV)pwent->pw_change);
a0d0e21e
LW		 4064#else
4065#ifdef PWQUOTA
1e422769 4066 sv_setiv(sv, (IV)pwent->pw_quota);
a0d0e21e
LW		 4067#else
4068#ifdef PWAGE
4069 sv_setpv(sv, pwent->pw_age);
4070#endif
4071#endif
4072#endif
4073 PUSHs(sv = sv_mortalcopy(&sv_no));
4074#ifdef PWCLASS
4075 sv_setpv(sv, pwent->pw_class);
4076#else
4077#ifdef PWCOMMENT
4078 sv_setpv(sv, pwent->pw_comment);
4079#endif
4080#endif
4081 PUSHs(sv = sv_mortalcopy(&sv_no));
4082 sv_setpv(sv, pwent->pw_gecos);
fb73857a 4083#ifndef INCOMPLETE_TAINTS
4084 SvTAINTED_on(sv);
4085#endif
a0d0e21e
LW		 4086 PUSHs(sv = sv_mortalcopy(&sv_no));
4087 sv_setpv(sv, pwent->pw_dir);
4088 PUSHs(sv = sv_mortalcopy(&sv_no));
4089 sv_setpv(sv, pwent->pw_shell);
4090#ifdef PWEXPIRE
4091 PUSHs(sv = sv_mortalcopy(&sv_no));
1e422769 4092 sv_setiv(sv, (IV)pwent->pw_expire);
a0d0e21e
LW		 4093#endif
4094 }
4095 RETURN;
4096#else
4097 DIE(no_func, "getpwent");
4098#endif
4099}
4100
4101PP(pp_spwent)
4102{
4103 dSP;
5aabfad6 4104#if defined(HAS_PASSWD) && !defined(CYGWIN32)
a0d0e21e
LW		 4105 setpwent();
4106 RETPUSHYES;
4107#else
4108 DIE(no_func, "setpwent");
4109#endif
4110}
4111
4112PP(pp_epwent)
4113{
4114 dSP;
4115#ifdef HAS_PASSWD
4116 endpwent();
4117 RETPUSHYES;
4118#else
4119 DIE(no_func, "endpwent");
4120#endif
4121}
4122
4123PP(pp_ggrnam)
4124{
4125#ifdef HAS_GROUP
4126 return pp_ggrent(ARGS);
4127#else
4128 DIE(no_func, "getgrnam");
4129#endif
4130}
4131
4132PP(pp_ggrgid)
4133{
4134#ifdef HAS_GROUP
4135 return pp_ggrent(ARGS);
4136#else
4137 DIE(no_func, "getgrgid");
4138#endif
4139}
4140
4141PP(pp_ggrent)
4142{
4143 dSP;
4144#ifdef HAS_GROUP
4145 I32 which = op->op_type;
4146 register char **elem;
4147 register SV *sv;
4148 struct group *grent;
4149
4150 if (which == OP_GGRNAM)
4151 grent = (struct group *)getgrnam(POPp);
4152 else if (which == OP_GGRGID)
4153 grent = (struct group *)getgrgid(POPi);
4154 else
4155 grent = (struct group *)getgrent();
4156
4157 EXTEND(SP, 4);
4158 if (GIMME != G_ARRAY) {
4159 PUSHs(sv = sv_newmortal());
4160 if (grent) {
4161 if (which == OP_GGRNAM)
1e422769 4162 sv_setiv(sv, (IV)grent->gr_gid);
a0d0e21e
LW		 4163 else
4164 sv_setpv(sv, grent->gr_name);
4165 }
4166 RETURN;
4167 }
4168
4169 if (grent) {
4170 PUSHs(sv = sv_mortalcopy(&sv_no));
4171 sv_setpv(sv, grent->gr_name);
4172 PUSHs(sv = sv_mortalcopy(&sv_no));
4173 sv_setpv(sv, grent->gr_passwd);
4174 PUSHs(sv = sv_mortalcopy(&sv_no));
1e422769 4175 sv_setiv(sv, (IV)grent->gr_gid);
a0d0e21e 4176 PUSHs(sv = sv_mortalcopy(&sv_no));
c90c0ff4 4177 for (elem = grent->gr_mem; elem && *elem; elem++) {
a0d0e21e
LW		 4178 sv_catpv(sv, *elem);
4179 if (elem[1])
4180 sv_catpvn(sv, " ", 1);
4181 }
4182 }
4183
4184 RETURN;
4185#else
4186 DIE(no_func, "getgrent");
4187#endif
4188}
4189
4190PP(pp_sgrent)
4191{
4192 dSP;
4193#ifdef HAS_GROUP
4194 setgrent();
4195 RETPUSHYES;
4196#else
4197 DIE(no_func, "setgrent");
4198#endif
4199}
4200
4201PP(pp_egrent)
4202{
4203 dSP;
4204#ifdef HAS_GROUP
4205 endgrent();
4206 RETPUSHYES;
4207#else
4208 DIE(no_func, "endgrent");
4209#endif
4210}
4211
4212PP(pp_getlogin)
4213{
4214 dSP; dTARGET;
4215#ifdef HAS_GETLOGIN
4216 char *tmps;
4217 EXTEND(SP, 1);
4218 if (!(tmps = getlogin()))
4219 RETPUSHUNDEF;
4220 PUSHp(tmps, strlen(tmps));
4221 RETURN;
4222#else
4223 DIE(no_func, "getlogin");
4224#endif
4225}
4226
4227/* Miscellaneous. */
4228
4229PP(pp_syscall)
4230{
4231#ifdef HAS_SYSCALL
4232 dSP; dMARK; dORIGMARK; dTARGET;
4233 register I32 items = SP - MARK;
4234 unsigned long a[20];
4235 register I32 i = 0;
4236 I32 retval = -1;
748a9306 4237 MAGIC *mg;
a0d0e21e
LW		 4238
4239 if (tainting) {
4240 while (++MARK <= SP) {
bbce6d69 4241 if (SvTAINTED(*MARK)) {
4242 TAINT;
4243 break;
4244 }
a0d0e21e
LW		 4245 }
4246 MARK = ORIGMARK;
4247 TAINT_PROPER("syscall");
4248 }
4249
4250 /* This probably won't work on machines where sizeof(long) != sizeof(int)
4251 * or where sizeof(long) != sizeof(char*). But such machines will
4252 * not likely have syscall implemented either, so who cares?
4253 */
4254 while (++MARK <= SP) {
4255 if (SvNIOK(*MARK) || !i)
4256 a[i++] = SvIV(*MARK);
748a9306
LW		 4257 else if (*MARK == &sv_undef)
4258 a[i++] = 0;
4259 else
4260 a[i++] = (unsigned long)SvPV_force(*MARK, na);
a0d0e21e
LW		 4261 if (i > 15)
4262 break;
4263 }
4264 switch (items) {
4265 default:
4266 DIE("Too many args to syscall");
4267 case 0:
4268 DIE("Too few args to syscall");
4269 case 1:
4270 retval = syscall(a[0]);
4271 break;
4272 case 2:
4273 retval = syscall(a[0],a[1]);
4274 break;
4275 case 3:
4276 retval = syscall(a[0],a[1],a[2]);
4277 break;
4278 case 4:
4279 retval = syscall(a[0],a[1],a[2],a[3]);
4280 break;
4281 case 5:
4282 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
4283 break;
4284 case 6:
4285 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
4286 break;
4287 case 7:
4288 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
4289 break;
4290 case 8:
4291 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
4292 break;
4293#ifdef atarist
4294 case 9:
4295 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
4296 break;
4297 case 10:
4298 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
4299 break;
4300 case 11:
4301 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
4302 a[10]);
4303 break;
4304 case 12:
4305 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
4306 a[10],a[11]);
4307 break;
4308 case 13:
4309 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
4310 a[10],a[11],a[12]);
4311 break;
4312 case 14:
4313 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
4314 a[10],a[11],a[12],a[13]);
4315 break;
4316#endif /* atarist */
4317 }
4318 SP = ORIGMARK;
4319 PUSHi(retval);
4320 RETURN;
4321#else
4322 DIE(no_func, "syscall");
4323#endif
4324}
4325
ff68c719 4326#ifdef FCNTL_EMULATE_FLOCK
4327
4328/* XXX Emulate flock() with fcntl().
4329 What's really needed is a good file locking module.
4330*/
4331
4332static int
4333fcntl_emulate_flock(fd, operation)
4334int fd;
4335int operation;
4336{
4337 struct flock flock;
4338
4339 switch (operation & ~LOCK_NB) {
4340 case LOCK_SH:
4341 flock.l_type = F_RDLCK;
4342 break;
4343 case LOCK_EX:
4344 flock.l_type = F_WRLCK;
4345 break;
4346 case LOCK_UN:
4347 flock.l_type = F_UNLCK;
4348 break;
4349 default:
4350 errno = EINVAL;
4351 return -1;
4352 }
4353 flock.l_whence = SEEK_SET;
4354 flock.l_start = flock.l_len = 0L;
4355
4356 return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
4357}
4358
4359#endif /* FCNTL_EMULATE_FLOCK */
4360
4361#ifdef LOCKF_EMULATE_FLOCK
16d20bd9
AD		 4362
4363/* XXX Emulate flock() with lockf(). This is just to increase
4364 portability of scripts. The calls are not completely
4365 interchangeable. What's really needed is a good file
4366 locking module.
4367*/
4368
76c32331 4369/* The lockf() constants might have been defined in <unistd.h>.
4370 Unfortunately, <unistd.h> causes troubles on some mixed
4371 (BSD/POSIX) systems, such as SunOS 4.1.3.
16d20bd9
AD		 4372
4373 Further, the lockf() constants aren't POSIX, so they might not be
4374 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
4375 just stick in the SVID values and be done with it. Sigh.
4376*/
4377
4378# ifndef F_ULOCK
4379# define F_ULOCK 0 /* Unlock a previously locked region */
4380# endif
4381# ifndef F_LOCK
4382# define F_LOCK 1 /* Lock a region for exclusive use */
4383# endif
4384# ifndef F_TLOCK
4385# define F_TLOCK 2 /* Test and lock a region for exclusive use */
4386# endif
4387# ifndef F_TEST
4388# define F_TEST 3 /* Test a region for other processes locks */
4389# endif
4390
55497cff 4391static int
16d20bd9
AD		 4392lockf_emulate_flock (fd, operation)
4393int fd;
4394int operation;
4395{
4396 int i;
84902520
TB		 4397 int save_errno;
4398 Off_t pos;
4399
4400 /* flock locks entire file so for lockf we need to do the same */
4401 save_errno = errno;
4402 pos = lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
4403 if (pos > 0) /* is seekable and needs to be repositioned */
08b714dd
HF		 4404 if (lseek(fd, (Off_t)0, SEEK_SET) < 0)
4405 pos = -1; /* seek failed, so don't seek back afterwards */
84902520
TB		 4406 errno = save_errno;
4407
16d20bd9
AD		 4408 switch (operation) {
4409
4410 /* LOCK_SH - get a shared lock */
4411 case LOCK_SH:
4412 /* LOCK_EX - get an exclusive lock */
4413 case LOCK_EX:
4414 i = lockf (fd, F_LOCK, 0);
4415 break;
4416
4417 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
4418 case LOCK_SH|LOCK_NB:
4419 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
4420 case LOCK_EX|LOCK_NB:
4421 i = lockf (fd, F_TLOCK, 0);
4422 if (i == -1)
4423 if ((errno == EAGAIN) || (errno == EACCES))
4424 errno = EWOULDBLOCK;
4425 break;
4426
ff68c719 4427 /* LOCK_UN - unlock (non-blocking is a no-op) */
16d20bd9 4428 case LOCK_UN:
ff68c719 4429 case LOCK_UN|LOCK_NB:
16d20bd9
AD		 4430 i = lockf (fd, F_ULOCK, 0);
4431 break;
4432
4433 /* Default - can't decipher operation */
4434 default:
4435 i = -1;
4436 errno = EINVAL;
4437 break;
4438 }
84902520
TB		 4439
4440 if (pos > 0) /* need to restore position of the handle */
08b714dd 4441 lseek(fd, pos, SEEK_SET); /* ignore error here */
84902520 4442
16d20bd9
AD		 4443 return (i);
4444}
ff68c719 4445
4446#endif /* LOCKF_EMULATE_FLOCK */
Unnamed repository; edit this file 'description' to name the repository.