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