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