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