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