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