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