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