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