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