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