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