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
big Configure update from Jarkko: sync metaconfig units; d_statblks fix
[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
210#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_ACCESS)
211/* The Hard Way. */
212static int emulate_eaccess (const char* path, int mode) {
213 Uid_t ruid = getuid();
214 Uid_t euid = geteuid();
215 Gid_t rgid = getgid();
216 Gid_t egid = getegid();
217 int res;
218
219 MUTEX_LOCK(&PL_cred_mutex);
220#if !defined(HAS_SETREUID) && !defined(HAS_SETRESUID)
221 croak("effective uid access is not implemented");
222#else
223#ifdef HAS_SETREUID
224 if (setreuid(euid, ruid))
225#else
226#ifdef HAS_SETRESUID
227 if (setresuid(euid, ruid, (Uid_t)-1))
228#endif
229#endif
230 croak("entering effective uid access failed");
231#endif
232
233#if !defined(HAS_SETREGID) && !defined(HAS_SETRESGID)
234 croak("effective gid access is not implemented");
235#else
236#ifdef HAS_SETREGID
237 if (setregid(egid, rgid))
238#else
239#ifdef HAS_SETRESGID
240 if (setresgid(egid, rgid, (Gid_t)-1))
241#endif
242#endif
243 croak("entering effective gid access failed");
244#endif
245
246 res = access(path, mode);
247
248#ifdef HAS_SETREUID
249 if (setreuid(ruid, euid))
250#else
251#ifdef HAS_SETRESUID
252 if (setresuid(ruid, euid, (Uid_t)-1))
253#endif
254#endif
255 croak("leaving effective uid access failed");
256
257#ifdef HAS_SETREGID
258 if (setregid(rgid, egid))
259#else
260#ifdef HAS_SETRESGID
261 if (setresgid(rgid, egid, (Gid_t)-1))
262#endif
263#endif
264 croak("leaving effective gid access failed");
265 MUTEX_UNLOCK(&PL_cred_mutex);
266
267 return res;
268}
269# define PERL_EFF_ACCESS_R_OK(p) (emulate_eaccess((p), R_OK))
270# define PERL_EFF_ACCESS_W_OK(p) (emulate_eaccess((p), W_OK))
271# define PERL_EFF_ACCESS_X_OK(p) (emulate_eaccess((p), X_OK))
272#endif
273
274#if !defined(PERL_EFF_ACCESS_R_OK)
275static int emulate_eaccess (const char* path, int mode) {
276 croak("effective uid access is not implemented");
277 /*NOTREACHED*/
278 return -1;
279}
280#endif
281
46fc3d4c 282#ifndef MAXPATHLEN
283# ifdef PATH_MAX
284# define MAXPATHLEN PATH_MAX
285# else
286# define MAXPATHLEN 1024
287# endif
288#endif
55497cff 289
8903cb82 290#define ZBTLEN 10
291static char zero_but_true[ZBTLEN + 1] = "0 but true";
292
a0d0e21e
LW		 293PP(pp_backtick)
294{
4e35701f 295 djSP; dTARGET;
760ac839 296 PerlIO *fp;
a0d0e21e 297 char *tmps = POPp;
54310121 298 I32 gimme = GIMME_V;
299
a0d0e21e 300 TAINT_PROPER("``");
6ad3d225 301 fp = PerlProc_popen(tmps, "r");
a0d0e21e 302 if (fp) {
54310121 303 if (gimme == G_VOID) {
96827780
MB		 304 char tmpbuf[256];
305 while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0)
54310121 306 /*SUPPRESS 530*/
307 ;
308 }
309 else if (gimme == G_SCALAR) {
aa689395 310 sv_setpv(TARG, ""); /* note that this preserves previous buffer */
a0d0e21e
LW		 311 while (sv_gets(TARG, fp, SvCUR(TARG)) != Nullch)
312 /*SUPPRESS 530*/
313 ;
314 XPUSHs(TARG);
aa689395 315 SvTAINTED_on(TARG);
a0d0e21e
LW		 316 }
317 else {
318 SV *sv;
319
320 for (;;) {
8d6dde3e 321 sv = NEWSV(56, 79);
a0d0e21e
LW		 322 if (sv_gets(sv, fp, 0) == Nullch) {
323 SvREFCNT_dec(sv);
324 break;
325 }
326 XPUSHs(sv_2mortal(sv));
327 if (SvLEN(sv) - SvCUR(sv) > 20) {
328 SvLEN_set(sv, SvCUR(sv)+1);
329 Renew(SvPVX(sv), SvLEN(sv), char);
330 }
aa689395 331 SvTAINTED_on(sv);
a0d0e21e
LW		 332 }
333 }
6ad3d225 334 STATUS_NATIVE_SET(PerlProc_pclose(fp));
aa689395 335 TAINT; /* "I believe that this is not gratuitous!" */
a0d0e21e
LW		 336 }
337 else {
f86702cc 338 STATUS_NATIVE_SET(-1);
54310121 339 if (gimme == G_SCALAR)
a0d0e21e
LW		 340 RETPUSHUNDEF;
341 }
342
343 RETURN;
344}
345
346PP(pp_glob)
347{
348 OP *result;
349 ENTER;
a0d0e21e 350
c90c0ff4 351#ifndef VMS
3280af22 352 if (PL_tainting) {
7bac28a0 353 /*
354 * The external globbing program may use things we can't control,
355 * so for security reasons we must assume the worst.
356 */
357 TAINT;
358 taint_proper(no_security, "glob");
359 }
c90c0ff4 360#endif /* !VMS */
7bac28a0 361
3280af22
NIS		 362 SAVESPTR(PL_last_in_gv); /* We don't want this to be permanent. */
363 PL_last_in_gv = (GV*)*PL_stack_sp--;
a0d0e21e 364
3280af22
NIS		 365 SAVESPTR(PL_rs); /* This is not permanent, either. */
366 PL_rs = sv_2mortal(newSVpv("", 1));
c07a80fd 367#ifndef DOSISH
368#ifndef CSH
6b88bc9c 369 *SvPVX(PL_rs) = '\n';
a0d0e21e 370#endif /* !CSH */
55497cff 371#endif /* !DOSISH */
c07a80fd 372
a0d0e21e
LW		 373 result = do_readline();
374 LEAVE;
375 return result;
376}
377
15e52e56 378#if 0 /* XXX never used! */
a0d0e21e
LW		 379PP(pp_indread)
380{
6b88bc9c 381 PL_last_in_gv = gv_fetchpv(SvPVx(GvSV((GV*)(*PL_stack_sp--)), PL_na), TRUE,SVt_PVIO);
a0d0e21e
LW		 382 return do_readline();
383}
15e52e56 384#endif
a0d0e21e
LW		 385
386PP(pp_rcatline)
387{
3280af22 388 PL_last_in_gv = cGVOP->op_gv;
a0d0e21e
LW		 389 return do_readline();
390}
391
392PP(pp_warn)
393{
4e35701f 394 djSP; dMARK;
a0d0e21e
LW		 395 char *tmps;
396 if (SP - MARK != 1) {
397 dTARGET;
3280af22
NIS		 398 do_join(TARG, &PL_sv_no, MARK, SP);
399 tmps = SvPV(TARG, PL_na);
a0d0e21e
LW		 400 SP = MARK + 1;
401 }
402 else {
3280af22 403 tmps = SvPV(TOPs, PL_na);
a0d0e21e
LW		 404 }
405 if (!tmps || !*tmps) {
4e6ea2c3
GS		 406 SV *error = ERRSV;
407 (void)SvUPGRADE(error, SVt_PV);
408 if (SvPOK(error) && SvCUR(error))
409 sv_catpv(error, "\t...caught");
3280af22 410 tmps = SvPV(error, PL_na);
a0d0e21e
LW		 411 }
412 if (!tmps || !*tmps)
413 tmps = "Warning: something's wrong";
414 warn("%s", tmps);
415 RETSETYES;
416}
417
418PP(pp_die)
419{
4e35701f 420 djSP; dMARK;
a0d0e21e 421 char *tmps;
4e6ea2c3
GS		 422 SV *tmpsv = Nullsv;
423 char *pat = "%s";
a0d0e21e
LW		 424 if (SP - MARK != 1) {
425 dTARGET;
3280af22
NIS		 426 do_join(TARG, &PL_sv_no, MARK, SP);
427 tmps = SvPV(TARG, PL_na);
a0d0e21e
LW		 428 SP = MARK + 1;
429 }
430 else {
4e6ea2c3 431 tmpsv = TOPs;
3280af22 432 tmps = SvROK(tmpsv) ? Nullch : SvPV(tmpsv, PL_na);
a0d0e21e
LW		 433 }
434 if (!tmps || !*tmps) {
4e6ea2c3
GS		 435 SV *error = ERRSV;
436 (void)SvUPGRADE(error, SVt_PV);
437 if(tmpsv ? SvROK(tmpsv) : SvROK(error)) {
438 if(tmpsv)
439 SvSetSV(error,tmpsv);
05423cc9
GS		 440 else if(sv_isobject(error)) {
441 HV *stash = SvSTASH(SvRV(error));
442 GV *gv = gv_fetchmethod(stash, "PROPAGATE");
443 if (gv) {
3280af22
NIS		 444 SV *file = sv_2mortal(newSVsv(GvSV(PL_curcop->cop_filegv)));
445 SV *line = sv_2mortal(newSViv(PL_curcop->cop_line));
05423cc9
GS		 446 EXTEND(SP, 3);
447 PUSHMARK(SP);
448 PUSHs(error);
449 PUSHs(file);
450 PUSHs(line);
451 PUTBACK;
452 perl_call_sv((SV*)GvCV(gv),
453 G_SCALAR|G_EVAL|G_KEEPERR);
3280af22 454 sv_setsv(error,*PL_stack_sp--);
05423cc9
GS		 455 }
456 }
4e6ea2c3
GS		 457 pat = Nullch;
458 }
459 else {
460 if (SvPOK(error) && SvCUR(error))
461 sv_catpv(error, "\t...propagated");
3280af22 462 tmps = SvPV(error, PL_na);
4e6ea2c3 463 }
a0d0e21e
LW		 464 }
465 if (!tmps || !*tmps)
466 tmps = "Died";
4e6ea2c3 467 DIE(pat, tmps);
a0d0e21e
LW		 468}
469
470/* I/O. */
471
472PP(pp_open)
473{
4e35701f 474 djSP; dTARGET;
a0d0e21e
LW		 475 GV *gv;
476 SV *sv;
477 char *tmps;
478 STRLEN len;
479
480 if (MAXARG > 1)
481 sv = POPs;
5f05dabc 482 if (!isGV(TOPs))
4633a7c4 483 DIE(no_usym, "filehandle");
5f05dabc 484 if (MAXARG <= 1)
485 sv = GvSV(TOPs);
a0d0e21e 486 gv = (GV*)POPs;
5f05dabc 487 if (!isGV(gv))
488 DIE(no_usym, "filehandle");
36477c24 489 if (GvIOp(gv))
490 IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
a0d0e21e 491 tmps = SvPV(sv, len);
9d116dd7 492 if (do_open(gv, tmps, len, FALSE, O_RDONLY, 0, Nullfp))
3280af22
NIS		 493 PUSHi( (I32)PL_forkprocess );
494 else if (PL_forkprocess == 0) /* we are a new child */
a0d0e21e
LW		 495 PUSHi(0);
496 else
497 RETPUSHUNDEF;
498 RETURN;
499}
500
501PP(pp_close)
502{
4e35701f 503 djSP;
a0d0e21e 504 GV *gv;
1d603a67 505 MAGIC *mg;
a0d0e21e
LW		 506
507 if (MAXARG == 0)
3280af22 508 gv = PL_defoutgv;
a0d0e21e
LW		 509 else
510 gv = (GV*)POPs;
1d603a67
GB		 511
512 if (SvRMAGICAL(gv) && (mg = mg_find((SV*)gv, 'q'))) {
513 PUSHMARK(SP);
514 XPUSHs(mg->mg_obj);
515 PUTBACK;
516 ENTER;
517 perl_call_method("CLOSE", G_SCALAR);
518 LEAVE;
519 SPAGAIN;
520 RETURN;
521 }
a0d0e21e 522 EXTEND(SP, 1);
54310121 523 PUSHs(boolSV(do_close(gv, TRUE)));
a0d0e21e
LW		 524 RETURN;
525}
526
527PP(pp_pipe_op)
528{
4e35701f 529 djSP;
a0d0e21e
LW		 530#ifdef HAS_PIPE
531 GV *rgv;
532 GV *wgv;
533 register IO *rstio;
534 register IO *wstio;
535 int fd[2];
536
537 wgv = (GV*)POPs;
538 rgv = (GV*)POPs;
539
540 if (!rgv || !wgv)
541 goto badexit;
542
4633a7c4
LW		 543 if (SvTYPE(rgv) != SVt_PVGV || SvTYPE(wgv) != SVt_PVGV)
544 DIE(no_usym, "filehandle");
a0d0e21e
LW		 545 rstio = GvIOn(rgv);
546 wstio = GvIOn(wgv);
547
548 if (IoIFP(rstio))
549 do_close(rgv, FALSE);
550 if (IoIFP(wstio))
551 do_close(wgv, FALSE);
552
6ad3d225 553 if (PerlProc_pipe(fd) < 0)
a0d0e21e
LW		 554 goto badexit;
555
760ac839
LW		 556 IoIFP(rstio) = PerlIO_fdopen(fd[0], "r");
557 IoOFP(wstio) = PerlIO_fdopen(fd[1], "w");
a0d0e21e
LW		 558 IoIFP(wstio) = IoOFP(wstio);
559 IoTYPE(rstio) = '<';
560 IoTYPE(wstio) = '>';
561
562 if (!IoIFP(rstio) || !IoOFP(wstio)) {
760ac839 563 if (IoIFP(rstio)) PerlIO_close(IoIFP(rstio));
6ad3d225 564 else PerlLIO_close(fd[0]);
760ac839 565 if (IoOFP(wstio)) PerlIO_close(IoOFP(wstio));
6ad3d225 566 else PerlLIO_close(fd[1]);
a0d0e21e
LW		 567 goto badexit;
568 }
569
570 RETPUSHYES;
571
572badexit:
573 RETPUSHUNDEF;
574#else
575 DIE(no_func, "pipe");
576#endif
577}
578
579PP(pp_fileno)
580{
4e35701f 581 djSP; dTARGET;
a0d0e21e
LW		 582 GV *gv;
583 IO *io;
760ac839 584 PerlIO *fp;
a0d0e21e
LW		 585 if (MAXARG < 1)
586 RETPUSHUNDEF;
587 gv = (GV*)POPs;
588 if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io)))
589 RETPUSHUNDEF;
760ac839 590 PUSHi(PerlIO_fileno(fp));
a0d0e21e
LW		 591 RETURN;
592}
593
594PP(pp_umask)
595{
4e35701f 596 djSP; dTARGET;
a0d0e21e
LW		 597 int anum;
598
599#ifdef HAS_UMASK
600 if (MAXARG < 1) {
6ad3d225
GS		 601 anum = PerlLIO_umask(0);
602 (void)PerlLIO_umask(anum);
a0d0e21e
LW		 603 }
604 else
6ad3d225 605 anum = PerlLIO_umask(POPi);
a0d0e21e
LW		 606 TAINT_PROPER("umask");
607 XPUSHi(anum);
608#else
eec2d3df
GS		 609 /* Only DIE if trying to restrict permissions on `user' (self).
610 * Otherwise it's harmless and more useful to just return undef
611 * since 'group' and 'other' concepts probably don't exist here. */
612 if (MAXARG >= 1 && (POPi & 0700))
613 DIE("umask not implemented");
6b88bc9c 614 XPUSHs(&PL_sv_undef);
a0d0e21e
LW		 615#endif
616 RETURN;
617}
618
619PP(pp_binmode)
620{
4e35701f 621 djSP;
a0d0e21e
LW		 622 GV *gv;
623 IO *io;
760ac839 624 PerlIO *fp;
a0d0e21e
LW		 625
626 if (MAXARG < 1)
627 RETPUSHUNDEF;
628
629 gv = (GV*)POPs;
630
631 EXTEND(SP, 1);
632 if (!(io = GvIO(gv)) || !(fp = IoIFP(io)))
55497cff 633 RETPUSHUNDEF;
a0d0e21e 634
491527d0 635 if (do_binmode(fp,IoTYPE(io),TRUE))
a0d0e21e
LW		 636 RETPUSHYES;
637 else
638 RETPUSHUNDEF;
a0d0e21e
LW		 639}
640
b8e3bfaf 641
a0d0e21e
LW		 642PP(pp_tie)
643{
4e35701f 644 djSP;
e336de0d 645 dMARK;
a0d0e21e
LW		 646 SV *varsv;
647 HV* stash;
648 GV *gv;
a0d0e21e 649 SV *sv;
3280af22 650 I32 markoff = MARK - PL_stack_base;
a0d0e21e 651 char *methname;
6b05c17a 652 int how = 'P';
e336de0d 653 U32 items;
a0d0e21e 654
e336de0d 655 varsv = *++MARK;
6b05c17a
NIS		 656 switch(SvTYPE(varsv)) {
657 case SVt_PVHV:
658 methname = "TIEHASH";
659 break;
660 case SVt_PVAV:
661 methname = "TIEARRAY";
662 break;
663 case SVt_PVGV:
664 methname = "TIEHANDLE";
665 how = 'q';
666 break;
667 default:
668 methname = "TIESCALAR";
669 how = 'q';
670 break;
671 }
e336de0d
GS		 672 items = SP - MARK++;
673 if (sv_isobject(*MARK)) {
6b05c17a 674 ENTER;
e788e7d3 675 PUSHSTACKi(PERLSI_MAGIC);
e336de0d
GS		 676 PUSHMARK(SP);
677 EXTEND(SP,items);
678 while (items--)
679 PUSHs(*MARK++);
680 PUTBACK;
6b05c17a
NIS		 681 perl_call_method(methname, G_SCALAR);
682 }
683 else {
684 /* Not clear why we don't call perl_call_method here too.
685 * perhaps to get different error message ?
686 */
e336de0d 687 stash = gv_stashsv(*MARK, FALSE);
6b05c17a
NIS		 688 if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
689 DIE("Can't locate object method \"%s\" via package \"%s\"",
3280af22 690 methname, SvPV(*MARK,PL_na));
6b05c17a
NIS		 691 }
692 ENTER;
e788e7d3 693 PUSHSTACKi(PERLSI_MAGIC);
e336de0d
GS		 694 PUSHMARK(SP);
695 EXTEND(SP,items);
696 while (items--)
697 PUSHs(*MARK++);
698 PUTBACK;
6b05c17a
NIS		 699 perl_call_sv((SV*)GvCV(gv), G_SCALAR);
700 }
a0d0e21e
LW		 701 SPAGAIN;
702
703 sv = TOPs;
d3acc0f7 704 POPSTACK;
a0d0e21e 705 if (sv_isobject(sv)) {
6b05c17a
NIS		 706 sv_unmagic(varsv, how);
707 sv_magic(varsv, sv, how, Nullch, 0);
a0d0e21e
LW		 708 }
709 LEAVE;
3280af22 710 SP = PL_stack_base + markoff;
a0d0e21e
LW		 711 PUSHs(sv);
712 RETURN;
713}
714
715PP(pp_untie)
716{
4e35701f 717 djSP;
cbdc8872 718 SV * sv ;
d2719217
GS		 719
720 sv = POPs;
55497cff 721
599cee73 722 if (ckWARN(WARN_UNTIE)) {
cbdc8872 723 MAGIC * mg ;
724 if (SvMAGICAL(sv)) {
725 if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
726 mg = mg_find(sv, 'P') ;
727 else
728 mg = mg_find(sv, 'q') ;
729
730 if (mg && SvREFCNT(SvRV(mg->mg_obj)) > 1)
599cee73
PM		 731 warner(WARN_UNTIE,
732 "untie attempted while %lu inner references still exist",
733 (unsigned long)SvREFCNT(SvRV(mg->mg_obj)) - 1 ) ;
cbdc8872 734 }
735 }
736
737 if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
738 sv_unmagic(sv, 'P');
a0d0e21e 739 else
cbdc8872 740 sv_unmagic(sv, 'q');
55497cff 741 RETPUSHYES;
a0d0e21e
LW		 742}
743
c07a80fd 744PP(pp_tied)
745{
4e35701f 746 djSP;
c07a80fd 747 SV * sv ;
748 MAGIC * mg ;
749
750 sv = POPs;
751 if (SvMAGICAL(sv)) {
752 if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
753 mg = mg_find(sv, 'P') ;
754 else
755 mg = mg_find(sv, 'q') ;
756
757 if (mg) {
758 PUSHs(sv_2mortal(newSVsv(mg->mg_obj))) ;
759 RETURN ;
760 }
761 }
c07a80fd 762 RETPUSHUNDEF;
763}
764
a0d0e21e
LW		 765PP(pp_dbmopen)
766{
4e35701f 767 djSP;
a0d0e21e
LW		 768 HV *hv;
769 dPOPPOPssrl;
770 HV* stash;
771 GV *gv;
a0d0e21e
LW		 772 SV *sv;
773
774 hv = (HV*)POPs;
775
3280af22 776 sv = sv_mortalcopy(&PL_sv_no);
a0d0e21e
LW		 777 sv_setpv(sv, "AnyDBM_File");
778 stash = gv_stashsv(sv, FALSE);
8ebc5c01 779 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
a0d0e21e 780 PUTBACK;
4633a7c4 781 perl_require_pv("AnyDBM_File.pm");
a0d0e21e 782 SPAGAIN;
8ebc5c01 783 if (!(gv = gv_fetchmethod(stash, "TIEHASH")))
a0d0e21e
LW		 784 DIE("No dbm on this machine");
785 }
786
57d3b86d 787 ENTER;
924508f0 788 PUSHMARK(SP);
6b05c17a 789
924508f0 790 EXTEND(SP, 5);
a0d0e21e
LW		 791 PUSHs(sv);
792 PUSHs(left);
793 if (SvIV(right))
794 PUSHs(sv_2mortal(newSViv(O_RDWR|O_CREAT)));
795 else
796 PUSHs(sv_2mortal(newSViv(O_RDWR)));
797 PUSHs(right);
57d3b86d 798 PUTBACK;
38a03e6e 799 perl_call_sv((SV*)GvCV(gv), G_SCALAR);
a0d0e21e
LW		 800 SPAGAIN;
801
802 if (!sv_isobject(TOPs)) {
924508f0
GS		 803 SP--;
804 PUSHMARK(SP);
a0d0e21e
LW		 805 PUSHs(sv);
806 PUSHs(left);
807 PUSHs(sv_2mortal(newSViv(O_RDONLY)));
808 PUSHs(right);
a0d0e21e 809 PUTBACK;
38a03e6e 810 perl_call_sv((SV*)GvCV(gv), G_SCALAR);
a0d0e21e
LW		 811 SPAGAIN;
812 }
813
6b05c17a
NIS		 814 if (sv_isobject(TOPs)) {
815 sv_unmagic((SV *) hv, 'P');
a0d0e21e 816 sv_magic((SV*)hv, TOPs, 'P', Nullch, 0);
6b05c17a 817 }
a0d0e21e
LW		 818 LEAVE;
819 RETURN;
820}
821
822PP(pp_dbmclose)
823{
824 return pp_untie(ARGS);
825}
826
827PP(pp_sselect)
828{
4e35701f 829 djSP; dTARGET;
a0d0e21e
LW		 830#ifdef HAS_SELECT
831 register I32 i;
832 register I32 j;
833 register char *s;
834 register SV *sv;
835 double value;
836 I32 maxlen = 0;
837 I32 nfound;
838 struct timeval timebuf;
839 struct timeval *tbuf = &timebuf;
840 I32 growsize;
841 char *fd_sets[4];
842#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
843 I32 masksize;
844 I32 offset;
845 I32 k;
846
847# if BYTEORDER & 0xf0000
848# define ORDERBYTE (0x88888888 - BYTEORDER)
849# else
850# define ORDERBYTE (0x4444 - BYTEORDER)
851# endif
852
853#endif
854
855 SP -= 4;
856 for (i = 1; i <= 3; i++) {
857 if (!SvPOK(SP[i]))
858 continue;
859 j = SvCUR(SP[i]);
860 if (maxlen < j)
861 maxlen = j;
862 }
863
5ff3f7a4 864/* little endians can use vecs directly */
a0d0e21e 865#if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
5ff3f7a4
GS		 866# if SELECT_MIN_BITS > 1
867 growsize = SELECT_MIN_BITS / 8;
868# else
4633a7c4 869 growsize = sizeof(fd_set);
5ff3f7a4
GS		 870# endif
871# else
872# ifdef NFDBITS
a0d0e21e 873
5ff3f7a4
GS		 874# ifndef NBBY
875# define NBBY 8
876# endif
a0d0e21e
LW		 877
878 masksize = NFDBITS / NBBY;
5ff3f7a4 879# else
a0d0e21e 880 masksize = sizeof(long); /* documented int, everyone seems to use long */
5ff3f7a4 881# endif
a0d0e21e
LW		 882 growsize = maxlen + (masksize - (maxlen % masksize));
883 Zero(&fd_sets[0], 4, char*);
884#endif
885
886 sv = SP[4];
887 if (SvOK(sv)) {
888 value = SvNV(sv);
889 if (value < 0.0)
890 value = 0.0;
891 timebuf.tv_sec = (long)value;
892 value -= (double)timebuf.tv_sec;
893 timebuf.tv_usec = (long)(value * 1000000.0);
894 }
895 else
896 tbuf = Null(struct timeval*);
897
898 for (i = 1; i <= 3; i++) {
899 sv = SP[i];
900 if (!SvOK(sv)) {
901 fd_sets[i] = 0;
902 continue;
903 }
904 else if (!SvPOK(sv))
3280af22 905 SvPV_force(sv,PL_na); /* force string conversion */
a0d0e21e
LW		 906 j = SvLEN(sv);
907 if (j < growsize) {
908 Sv_Grow(sv, growsize);
a0d0e21e 909 }
c07a80fd 910 j = SvCUR(sv);
911 s = SvPVX(sv) + j;
912 while (++j <= growsize) {
913 *s++ = '\0';
914 }
915
a0d0e21e
LW		 916#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
917 s = SvPVX(sv);
918 New(403, fd_sets[i], growsize, char);
919 for (offset = 0; offset < growsize; offset += masksize) {
920 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
921 fd_sets[i][j+offset] = s[(k % masksize) + offset];
922 }
923#else
924 fd_sets[i] = SvPVX(sv);
925#endif
926 }
927
6ad3d225 928 nfound = PerlSock_select(
a0d0e21e
LW		 929 maxlen * 8,
930 (Select_fd_set_t) fd_sets[1],
931 (Select_fd_set_t) fd_sets[2],
932 (Select_fd_set_t) fd_sets[3],
933 tbuf);
934 for (i = 1; i <= 3; i++) {
935 if (fd_sets[i]) {
936 sv = SP[i];
937#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
938 s = SvPVX(sv);
939 for (offset = 0; offset < growsize; offset += masksize) {
940 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
941 s[(k % masksize) + offset] = fd_sets[i][j+offset];
942 }
943 Safefree(fd_sets[i]);
944#endif
945 SvSETMAGIC(sv);
946 }
947 }
948
949 PUSHi(nfound);
950 if (GIMME == G_ARRAY && tbuf) {
951 value = (double)(timebuf.tv_sec) +
952 (double)(timebuf.tv_usec) / 1000000.0;
3280af22 953 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 954 sv_setnv(sv, value);
955 }
956 RETURN;
957#else
958 DIE("select not implemented");
959#endif
960}
961
4633a7c4 962void
8ac85365 963setdefout(GV *gv)
4633a7c4 964{
11343788 965 dTHR;
4633a7c4
LW		 966 if (gv)
967 (void)SvREFCNT_inc(gv);
3280af22
NIS		 968 if (PL_defoutgv)
969 SvREFCNT_dec(PL_defoutgv);
970 PL_defoutgv = gv;
4633a7c4
LW		 971}
972
a0d0e21e
LW		 973PP(pp_select)
974{
4e35701f 975 djSP; dTARGET;
4633a7c4
LW		 976 GV *newdefout, *egv;
977 HV *hv;
978
533c011a 979 newdefout = (PL_op->op_private > 0) ? ((GV *) POPs) : (GV *) NULL;
4633a7c4 980
3280af22 981 egv = GvEGV(PL_defoutgv);
4633a7c4 982 if (!egv)
3280af22 983 egv = PL_defoutgv;
4633a7c4
LW		 984 hv = GvSTASH(egv);
985 if (! hv)
3280af22 986 XPUSHs(&PL_sv_undef);
4633a7c4 987 else {
cbdc8872 988 GV **gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
f86702cc 989 if (gvp && *gvp == egv) {
3280af22 990 gv_efullname3(TARG, PL_defoutgv, Nullch);
f86702cc 991 XPUSHTARG;
992 }
993 else {
994 XPUSHs(sv_2mortal(newRV((SV*)egv)));
995 }
4633a7c4
LW		 996 }
997
998 if (newdefout) {
999 if (!GvIO(newdefout))
1000 gv_IOadd(newdefout);
1001 setdefout(newdefout);
1002 }
1003
a0d0e21e
LW		 1004 RETURN;
1005}
1006
1007PP(pp_getc)
1008{
4e35701f 1009 djSP; dTARGET;
a0d0e21e 1010 GV *gv;
2ae324a7 1011 MAGIC *mg;
a0d0e21e
LW		 1012
1013 if (MAXARG <= 0)
3280af22 1014 gv = PL_stdingv;
a0d0e21e
LW		 1015 else
1016 gv = (GV*)POPs;
1017 if (!gv)
3280af22 1018 gv = PL_argvgv;
2ae324a7 1019
3049007d 1020 if (SvRMAGICAL(gv) && (mg = mg_find((SV*)gv, 'q'))) {
54310121 1021 I32 gimme = GIMME_V;
2ae324a7 1022 PUSHMARK(SP);
1023 XPUSHs(mg->mg_obj);
1024 PUTBACK;
1025 ENTER;
54310121 1026 perl_call_method("GETC", gimme);
2ae324a7 1027 LEAVE;
1028 SPAGAIN;
54310121 1029 if (gimme == G_SCALAR)
1030 SvSetMagicSV_nosteal(TARG, TOPs);
2ae324a7 1031 RETURN;
1032 }
9bc64814 1033 if (!gv || do_eof(gv)) /* make sure we have fp with something */
a0d0e21e 1034 RETPUSHUNDEF;
bbce6d69 1035 TAINT;
a0d0e21e 1036 sv_setpv(TARG, " ");
9bc64814 1037 *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
a0d0e21e
LW		 1038 PUSHTARG;
1039 RETURN;
1040}
1041
1042PP(pp_read)
1043{
1044 return pp_sysread(ARGS);
1045}
1046
76e3520e 1047STATIC OP *
8ac85365 1048doform(CV *cv, GV *gv, OP *retop)
a0d0e21e 1049{
11343788 1050 dTHR;
c09156bb 1051 register PERL_CONTEXT *cx;
54310121 1052 I32 gimme = GIMME_V;
a0d0e21e
LW		 1053 AV* padlist = CvPADLIST(cv);
1054 SV** svp = AvARRAY(padlist);
1055
1056 ENTER;
1057 SAVETMPS;
1058
1059 push_return(retop);
3280af22 1060 PUSHBLOCK(cx, CXt_SUB, PL_stack_sp);
a0d0e21e 1061 PUSHFORMAT(cx);
3280af22
NIS		 1062 SAVESPTR(PL_curpad);
1063 PL_curpad = AvARRAY((AV*)svp[1]);
a0d0e21e 1064
4633a7c4 1065 setdefout(gv); /* locally select filehandle so $% et al work */
a0d0e21e
LW		 1066 return CvSTART(cv);
1067}
1068
1069PP(pp_enterwrite)
1070{
4e35701f 1071 djSP;
a0d0e21e
LW		 1072 register GV *gv;
1073 register IO *io;
1074 GV *fgv;
1075 CV *cv;
1076
1077 if (MAXARG == 0)
3280af22 1078 gv = PL_defoutgv;
a0d0e21e
LW		 1079 else {
1080 gv = (GV*)POPs;
1081 if (!gv)
3280af22 1082 gv = PL_defoutgv;
a0d0e21e
LW		 1083 }
1084 EXTEND(SP, 1);
1085 io = GvIO(gv);
1086 if (!io) {
1087 RETPUSHNO;
1088 }
1089 if (IoFMT_GV(io))
1090 fgv = IoFMT_GV(io);
1091 else
1092 fgv = gv;
1093
1094 cv = GvFORM(fgv);
a0d0e21e
LW		 1095 if (!cv) {
1096 if (fgv) {
748a9306 1097 SV *tmpsv = sv_newmortal();
aac0dd9a 1098 gv_efullname3(tmpsv, fgv, Nullch);
748a9306 1099 DIE("Undefined format \"%s\" called",SvPVX(tmpsv));
a0d0e21e
LW		 1100 }
1101 DIE("Not a format reference");
1102 }
44a8e56a 1103 if (CvCLONE(cv))
1104 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
a0d0e21e 1105
44a8e56a 1106 IoFLAGS(io) &= ~IOf_DIDTOP;
533c011a 1107 return doform(cv,gv,PL_op->op_next);
a0d0e21e
LW		 1108}
1109
1110PP(pp_leavewrite)
1111{
4e35701f 1112 djSP;
a0d0e21e
LW		 1113 GV *gv = cxstack[cxstack_ix].blk_sub.gv;
1114 register IO *io = GvIOp(gv);
760ac839
LW		 1115 PerlIO *ofp = IoOFP(io);
1116 PerlIO *fp;
a0d0e21e
LW		 1117 SV **newsp;
1118 I32 gimme;
c09156bb 1119 register PERL_CONTEXT *cx;
a0d0e21e 1120
760ac839 1121 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
3280af22
NIS		 1122 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1123 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1124 PL_formtarget != PL_toptarget)
a0d0e21e 1125 {
4633a7c4
LW		 1126 GV *fgv;
1127 CV *cv;
a0d0e21e
LW		 1128 if (!IoTOP_GV(io)) {
1129 GV *topgv;
46fc3d4c 1130 SV *topname;
a0d0e21e
LW		 1131
1132 if (!IoTOP_NAME(io)) {
1133 if (!IoFMT_NAME(io))
1134 IoFMT_NAME(io) = savepv(GvNAME(gv));
46fc3d4c 1135 topname = sv_2mortal(newSVpvf("%s_TOP", IoFMT_NAME(io)));
1136 topgv = gv_fetchpv(SvPVX(topname), FALSE, SVt_PVFM);
748a9306 1137 if ((topgv && GvFORM(topgv)) ||
a0d0e21e 1138 !gv_fetchpv("top",FALSE,SVt_PVFM))
46fc3d4c 1139 IoTOP_NAME(io) = savepv(SvPVX(topname));
a0d0e21e
LW		 1140 else
1141 IoTOP_NAME(io) = savepv("top");
1142 }
1143 topgv = gv_fetchpv(IoTOP_NAME(io),FALSE, SVt_PVFM);
1144 if (!topgv || !GvFORM(topgv)) {
1145 IoLINES_LEFT(io) = 100000000;
1146 goto forget_top;
1147 }
1148 IoTOP_GV(io) = topgv;
1149 }
748a9306
LW		 1150 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1151 I32 lines = IoLINES_LEFT(io);
3280af22 1152 char *s = SvPVX(PL_formtarget);
8e07c86e
AD		 1153 if (lines <= 0) /* Yow, header didn't even fit!!! */
1154 goto forget_top;
748a9306
LW		 1155 while (lines-- > 0) {
1156 s = strchr(s, '\n');
1157 if (!s)
1158 break;
1159 s++;
1160 }
1161 if (s) {
3280af22
NIS		 1162 PerlIO_write(ofp, SvPVX(PL_formtarget), s - SvPVX(PL_formtarget));
1163 sv_chop(PL_formtarget, s);
1164 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
748a9306
LW		 1165 }
1166 }
a0d0e21e 1167 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
3280af22 1168 PerlIO_write(ofp, SvPVX(PL_formfeed), SvCUR(PL_formfeed));
a0d0e21e
LW		 1169 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1170 IoPAGE(io)++;
3280af22 1171 PL_formtarget = PL_toptarget;
748a9306 1172 IoFLAGS(io) |= IOf_DIDTOP;
4633a7c4
LW		 1173 fgv = IoTOP_GV(io);
1174 if (!fgv)
1175 DIE("bad top format reference");
1176 cv = GvFORM(fgv);
1177 if (!cv) {
1178 SV *tmpsv = sv_newmortal();
aac0dd9a 1179 gv_efullname3(tmpsv, fgv, Nullch);
4633a7c4
LW		 1180 DIE("Undefined top format \"%s\" called",SvPVX(tmpsv));
1181 }
44a8e56a 1182 if (CvCLONE(cv))
1183 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
533c011a 1184 return doform(cv,gv,PL_op);
a0d0e21e
LW		 1185 }
1186
1187 forget_top:
3280af22 1188 POPBLOCK(cx,PL_curpm);
a0d0e21e
LW		 1189 POPFORMAT(cx);
1190 LEAVE;
1191
1192 fp = IoOFP(io);
1193 if (!fp) {
599cee73 1194 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
a0d0e21e 1195 if (IoIFP(io))
599cee73
PM		 1196 warner(WARN_IO, "Filehandle only opened for input");
1197 else if (ckWARN(WARN_CLOSED))
1198 warner(WARN_CLOSED, "Write on closed filehandle");
a0d0e21e 1199 }
3280af22 1200 PUSHs(&PL_sv_no);
a0d0e21e
LW		 1201 }
1202 else {
3280af22 1203 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
599cee73
PM		 1204 if (ckWARN(WARN_IO))
1205 warner(WARN_IO, "page overflow");
a0d0e21e 1206 }
3280af22 1207 if (!PerlIO_write(ofp, SvPVX(PL_formtarget), SvCUR(PL_formtarget)) ||
760ac839 1208 PerlIO_error(fp))
3280af22 1209 PUSHs(&PL_sv_no);
a0d0e21e 1210 else {
3280af22
NIS		 1211 FmLINES(PL_formtarget) = 0;
1212 SvCUR_set(PL_formtarget, 0);
1213 *SvEND(PL_formtarget) = '\0';
a0d0e21e 1214 if (IoFLAGS(io) & IOf_FLUSH)
760ac839 1215 (void)PerlIO_flush(fp);
3280af22 1216 PUSHs(&PL_sv_yes);
a0d0e21e
LW		 1217 }
1218 }
3280af22 1219 PL_formtarget = PL_bodytarget;
a0d0e21e
LW		 1220 PUTBACK;
1221 return pop_return();
1222}
1223
1224PP(pp_prtf)
1225{
4e35701f 1226 djSP; dMARK; dORIGMARK;
a0d0e21e
LW		 1227 GV *gv;
1228 IO *io;
760ac839 1229 PerlIO *fp;
26db47c4 1230 SV *sv;
46fc3d4c 1231 MAGIC *mg;
a0d0e21e 1232
533c011a 1233 if (PL_op->op_flags & OPf_STACKED)
a0d0e21e
LW		 1234 gv = (GV*)*++MARK;
1235 else
3280af22 1236 gv = PL_defoutgv;
46fc3d4c 1237
3049007d 1238 if (SvRMAGICAL(gv) && (mg = mg_find((SV*)gv, 'q'))) {
46fc3d4c 1239 if (MARK == ORIGMARK) {
4352c267 1240 MEXTEND(SP, 1);
46fc3d4c 1241 ++MARK;
1242 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1243 ++SP;
1244 }
1245 PUSHMARK(MARK - 1);
1246 *MARK = mg->mg_obj;
1247 PUTBACK;
1248 ENTER;
1249 perl_call_method("PRINTF", G_SCALAR);
1250 LEAVE;
1251 SPAGAIN;
1252 MARK = ORIGMARK + 1;
1253 *MARK = *SP;
1254 SP = MARK;
1255 RETURN;
1256 }
1257
26db47c4 1258 sv = NEWSV(0,0);
a0d0e21e 1259 if (!(io = GvIO(gv))) {
599cee73 1260 if (ckWARN(WARN_UNOPENED)) {
aac0dd9a 1261 gv_fullname3(sv, gv, Nullch);
599cee73 1262 warner(WARN_UNOPENED, "Filehandle %s never opened", SvPV(sv,PL_na));
748a9306
LW		 1263 }
1264 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW		 1265 goto just_say_no;
1266 }
1267 else if (!(fp = IoOFP(io))) {
599cee73 1268 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
aac0dd9a 1269 gv_fullname3(sv, gv, Nullch);
a0d0e21e 1270 if (IoIFP(io))
599cee73
PM		 1271 warner(WARN_IO, "Filehandle %s opened only for input",
1272 SvPV(sv,PL_na));
1273 else if (ckWARN(WARN_CLOSED))
1274 warner(WARN_CLOSED, "printf on closed filehandle %s",
1275 SvPV(sv,PL_na));
a0d0e21e 1276 }
748a9306 1277 SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
a0d0e21e
LW		 1278 goto just_say_no;
1279 }
1280 else {
36477c24 1281#ifdef USE_LOCALE_NUMERIC
533c011a 1282 if (PL_op->op_private & OPpLOCALE)
36477c24 1283 SET_NUMERIC_LOCAL();
bbce6d69 1284 else
36477c24 1285 SET_NUMERIC_STANDARD();
1286#endif
a0d0e21e
LW		 1287 do_sprintf(sv, SP - MARK, MARK + 1);
1288 if (!do_print(sv, fp))
1289 goto just_say_no;
1290
1291 if (IoFLAGS(io) & IOf_FLUSH)
760ac839 1292 if (PerlIO_flush(fp) == EOF)
a0d0e21e
LW		 1293 goto just_say_no;
1294 }
1295 SvREFCNT_dec(sv);
1296 SP = ORIGMARK;
3280af22 1297 PUSHs(&PL_sv_yes);
a0d0e21e
LW		 1298 RETURN;
1299
1300 just_say_no:
1301 SvREFCNT_dec(sv);
1302 SP = ORIGMARK;
3280af22 1303 PUSHs(&PL_sv_undef);
a0d0e21e
LW		 1304 RETURN;
1305}
1306
c07a80fd 1307PP(pp_sysopen)
1308{
4e35701f 1309 djSP;
c07a80fd 1310 GV *gv;
c07a80fd 1311 SV *sv;
1312 char *tmps;
1313 STRLEN len;
1314 int mode, perm;
1315
1316 if (MAXARG > 3)
1317 perm = POPi;
1318 else
1319 perm = 0666;
1320 mode = POPi;
1321 sv = POPs;
1322 gv = (GV *)POPs;
1323
1324 tmps = SvPV(sv, len);
1325 if (do_open(gv, tmps, len, TRUE, mode, perm, Nullfp)) {
1326 IoLINES(GvIOp(gv)) = 0;
3280af22 1327 PUSHs(&PL_sv_yes);
c07a80fd 1328 }
1329 else {
3280af22 1330 PUSHs(&PL_sv_undef);
c07a80fd 1331 }
1332 RETURN;
1333}
1334
a0d0e21e
LW		 1335PP(pp_sysread)
1336{
4e35701f 1337 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW		 1338 int offset;
1339 GV *gv;
1340 IO *io;
1341 char *buffer;
5b54f415 1342 SSize_t length;
1e422769 1343 Sock_size_t bufsize;
748a9306 1344 SV *bufsv;
a0d0e21e 1345 STRLEN blen;
2ae324a7 1346 MAGIC *mg;
a0d0e21e
LW		 1347
1348 gv = (GV*)*++MARK;
533c011a 1349 if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD) &&
3049007d 1350 SvRMAGICAL(gv) && (mg = mg_find((SV*)gv, 'q')))
137443ea 1351 {
2ae324a7 1352 SV *sv;
1353
1354 PUSHMARK(MARK-1);
1355 *MARK = mg->mg_obj;
1356 ENTER;
1357 perl_call_method("READ", G_SCALAR);
1358 LEAVE;
1359 SPAGAIN;
1360 sv = POPs;
1361 SP = ORIGMARK;
1362 PUSHs(sv);
1363 RETURN;
1364 }
1365
a0d0e21e
LW		 1366 if (!gv)
1367 goto say_undef;
748a9306 1368 bufsv = *++MARK;
ff68c719 1369 if (! SvOK(bufsv))
1370 sv_setpvn(bufsv, "", 0);
748a9306 1371 buffer = SvPV_force(bufsv, blen);
a0d0e21e
LW		 1372 length = SvIVx(*++MARK);
1373 if (length < 0)
1374 DIE("Negative length");
748a9306 1375 SETERRNO(0,0);
a0d0e21e
LW		 1376 if (MARK < SP)
1377 offset = SvIVx(*++MARK);
1378 else
1379 offset = 0;
1380 io = GvIO(gv);
1381 if (!io || !IoIFP(io))
1382 goto say_undef;
1383#ifdef HAS_SOCKET
533c011a 1384 if (PL_op->op_type == OP_RECV) {
46fc3d4c 1385 char namebuf[MAXPATHLEN];
eec2d3df 1386#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE)
490ab354
JH		 1387 bufsize = sizeof (struct sockaddr_in);
1388#else
46fc3d4c 1389 bufsize = sizeof namebuf;
490ab354 1390#endif
748a9306 1391 buffer = SvGROW(bufsv, length+1);
bbce6d69 1392 /* 'offset' means 'flags' here */
6ad3d225 1393 length = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
46fc3d4c 1394 (struct sockaddr *)namebuf, &bufsize);
a0d0e21e
LW		 1395 if (length < 0)
1396 RETPUSHUNDEF;
748a9306
LW		 1397 SvCUR_set(bufsv, length);
1398 *SvEND(bufsv) = '\0';
1399 (void)SvPOK_only(bufsv);
1400 SvSETMAGIC(bufsv);
aac0dd9a 1401 /* This should not be marked tainted if the fp is marked clean */
bbce6d69 1402 if (!(IoFLAGS(io) & IOf_UNTAINT))
1403 SvTAINTED_on(bufsv);
a0d0e21e 1404 SP = ORIGMARK;
46fc3d4c 1405 sv_setpvn(TARG, namebuf, bufsize);
a0d0e21e
LW		 1406 PUSHs(TARG);
1407 RETURN;
1408 }
1409#else
911d147d 1410 if (PL_op->op_type == OP_RECV)
a0d0e21e
LW		 1411 DIE(no_sock_func, "recv");
1412#endif
bbce6d69 1413 if (offset < 0) {
1414 if (-offset > blen)
1415 DIE("Offset outside string");
1416 offset += blen;
1417 }
cd52b7b2 1418 bufsize = SvCUR(bufsv);
748a9306 1419 buffer = SvGROW(bufsv, length+offset+1);
cd52b7b2 1420 if (offset > bufsize) { /* Zero any newly allocated space */
1421 Zero(buffer+bufsize, offset-bufsize, char);
1422 }
533c011a 1423 if (PL_op->op_type == OP_SYSREAD) {
6ad3d225 1424 length = PerlLIO_read(PerlIO_fileno(IoIFP(io)), buffer+offset, length);
a0d0e21e
LW		 1425 }
1426 else
1427#ifdef HAS_SOCKET__bad_code_maybe
1428 if (IoTYPE(io) == 's') {
46fc3d4c 1429 char namebuf[MAXPATHLEN];
490ab354
JH		 1430#if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
1431 bufsize = sizeof (struct sockaddr_in);
1432#else
46fc3d4c 1433 bufsize = sizeof namebuf;
490ab354 1434#endif
6ad3d225 1435 length = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer+offset, length, 0,
46fc3d4c 1436 (struct sockaddr *)namebuf, &bufsize);
a0d0e21e
LW		 1437 }
1438 else
1439#endif
3b02c43c 1440 {
760ac839 1441 length = PerlIO_read(IoIFP(io), buffer+offset, length);
3b02c43c 1442 /* fread() returns 0 on both error and EOF */
5c7a8c78 1443 if (length == 0 && PerlIO_error(IoIFP(io)))
3b02c43c
GS		 1444 length = -1;
1445 }
a0d0e21e
LW		 1446 if (length < 0)
1447 goto say_undef;
748a9306
LW		 1448 SvCUR_set(bufsv, length+offset);
1449 *SvEND(bufsv) = '\0';
1450 (void)SvPOK_only(bufsv);
1451 SvSETMAGIC(bufsv);
aac0dd9a 1452 /* This should not be marked tainted if the fp is marked clean */
bbce6d69 1453 if (!(IoFLAGS(io) & IOf_UNTAINT))
1454 SvTAINTED_on(bufsv);
a0d0e21e
LW		 1455 SP = ORIGMARK;
1456 PUSHi(length);
1457 RETURN;
1458
1459 say_undef:
1460 SP = ORIGMARK;
1461 RETPUSHUNDEF;
1462}
1463
1464PP(pp_syswrite)
1465{
1466 return pp_send(ARGS);
1467}
1468
1469PP(pp_send)
1470{
4e35701f 1471 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW		 1472 GV *gv;
1473 IO *io;
1474 int offset;
748a9306 1475 SV *bufsv;
a0d0e21e
LW		 1476 char *buffer;
1477 int length;
1478 STRLEN blen;
1d603a67 1479 MAGIC *mg;
a0d0e21e
LW		 1480
1481 gv = (GV*)*++MARK;
533c011a 1482 if (PL_op->op_type == OP_SYSWRITE &&
1d603a67
GB		 1483 SvRMAGICAL(gv) && (mg = mg_find((SV*)gv, 'q')))
1484 {
1485 SV *sv;
1486
1487 PUSHMARK(MARK-1);
1488 *MARK = mg->mg_obj;
1489 ENTER;
1490 perl_call_method("WRITE", G_SCALAR);
1491 LEAVE;
1492 SPAGAIN;
1493 sv = POPs;
1494 SP = ORIGMARK;
1495 PUSHs(sv);
1496 RETURN;
1497 }
a0d0e21e
LW		 1498 if (!gv)
1499 goto say_undef;
748a9306
LW		 1500 bufsv = *++MARK;
1501 buffer = SvPV(bufsv, blen);
a0d0e21e
LW		 1502 length = SvIVx(*++MARK);
1503 if (length < 0)
1504 DIE("Negative length");
748a9306 1505 SETERRNO(0,0);
a0d0e21e
LW		 1506 io = GvIO(gv);
1507 if (!io || !IoIFP(io)) {
1508 length = -1;
599cee73 1509 if (ckWARN(WARN_CLOSED)) {
533c011a 1510 if (PL_op->op_type == OP_SYSWRITE)
599cee73 1511 warner(WARN_CLOSED, "Syswrite on closed filehandle");
a0d0e21e 1512 else
599cee73 1513 warner(WARN_CLOSED, "Send on closed socket");
a0d0e21e
LW		 1514 }
1515 }
533c011a 1516 else if (PL_op->op_type == OP_SYSWRITE) {
bbce6d69 1517 if (MARK < SP) {
a0d0e21e 1518 offset = SvIVx(*++MARK);
bbce6d69 1519 if (offset < 0) {
1520 if (-offset > blen)
1521 DIE("Offset outside string");
1522 offset += blen;
fb73857a 1523 } else if (offset >= blen && blen > 0)
bbce6d69 1524 DIE("Offset outside string");
1525 } else
a0d0e21e
LW		 1526 offset = 0;
1527 if (length > blen - offset)
1528 length = blen - offset;
6ad3d225 1529 length = PerlLIO_write(PerlIO_fileno(IoIFP(io)), buffer+offset, length);
a0d0e21e
LW		 1530 }
1531#ifdef HAS_SOCKET
1532 else if (SP > MARK) {
1533 char *sockbuf;
1534 STRLEN mlen;
1535 sockbuf = SvPVx(*++MARK, mlen);
6ad3d225 1536 length = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen, length,
a0d0e21e
LW		 1537 (struct sockaddr *)sockbuf, mlen);
1538 }
1539 else
6ad3d225 1540 length = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, length);
490ab354 1541
a0d0e21e
LW		 1542#else
1543 else
1544 DIE(no_sock_func, "send");
1545#endif
1546 if (length < 0)
1547 goto say_undef;
1548 SP = ORIGMARK;
1549 PUSHi(length);
1550 RETURN;
1551
1552 say_undef:
1553 SP = ORIGMARK;
1554 RETPUSHUNDEF;
1555}
1556
1557PP(pp_recv)
1558{
1559 return pp_sysread(ARGS);
1560}
1561
1562PP(pp_eof)
1563{
4e35701f 1564 djSP;
a0d0e21e
LW		 1565 GV *gv;
1566
1567 if (MAXARG <= 0)
3280af22 1568 gv = PL_last_in_gv;
a0d0e21e 1569 else
3280af22 1570 gv = PL_last_in_gv = (GV*)POPs;
54310121 1571 PUSHs(boolSV(!gv || do_eof(gv)));
a0d0e21e
LW		 1572 RETURN;
1573}
1574
1575PP(pp_tell)
1576{
4e35701f 1577 djSP; dTARGET;
a0d0e21e
LW		 1578 GV *gv;
1579
1580 if (MAXARG <= 0)
3280af22 1581 gv = PL_last_in_gv;
a0d0e21e 1582 else
3280af22 1583 gv = PL_last_in_gv = (GV*)POPs;
a0d0e21e
LW		 1584 PUSHi( do_tell(gv) );
1585 RETURN;
1586}
1587
1588PP(pp_seek)
1589{
137443ea 1590 return pp_sysseek(ARGS);
1591}
1592
1593PP(pp_sysseek)
1594{
4e35701f 1595 djSP;
a0d0e21e
LW		 1596 GV *gv;
1597 int whence = POPi;
1598 long offset = POPl;
1599
3280af22 1600 gv = PL_last_in_gv = (GV*)POPs;
533c011a 1601 if (PL_op->op_type == OP_SEEK)
8903cb82 1602 PUSHs(boolSV(do_seek(gv, offset, whence)));
1603 else {
1604 long n = do_sysseek(gv, offset, whence);
3280af22 1605 PUSHs((n < 0) ? &PL_sv_undef
8903cb82 1606 : sv_2mortal(n ? newSViv((IV)n)
1607 : newSVpv(zero_but_true, ZBTLEN)));
1608 }
a0d0e21e
LW		 1609 RETURN;
1610}
1611
1612PP(pp_truncate)
1613{
4e35701f 1614 djSP;
a0d0e21e
LW		 1615 Off_t len = (Off_t)POPn;
1616 int result = 1;
1617 GV *tmpgv;
1618
748a9306 1619 SETERRNO(0,0);
5d94fbed 1620#if defined(HAS_TRUNCATE) || defined(HAS_CHSIZE) || defined(F_FREESP)
533c011a 1621 if (PL_op->op_flags & OPf_SPECIAL) {
1e422769 1622 tmpgv = gv_fetchpv(POPp, FALSE, SVt_PVIO);
cbdc8872 1623 do_ftruncate:
1e422769 1624 TAINT_PROPER("truncate");
a0d0e21e 1625 if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv)) ||
cbdc8872 1626#ifdef HAS_TRUNCATE
760ac839 1627 ftruncate(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
cbdc8872 1628#else
760ac839 1629 my_chsize(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
cbdc8872 1630#endif
a0d0e21e
LW		 1631 result = 0;
1632 }
1633 else {
cbdc8872 1634 SV *sv = POPs;
1e422769 1635 char *name;
1636
cbdc8872 1637 if (SvTYPE(sv) == SVt_PVGV) {
1638 tmpgv = (GV*)sv; /* *main::FRED for example */
1639 goto do_ftruncate;
1640 }
1641 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
1642 tmpgv = (GV*) SvRV(sv); /* \*main::FRED for example */
1643 goto do_ftruncate;
1644 }
1e422769 1645
3280af22 1646 name = SvPV(sv, PL_na);
1e422769 1647 TAINT_PROPER("truncate");
cbdc8872 1648#ifdef HAS_TRUNCATE
1e422769 1649 if (truncate(name, len) < 0)
a0d0e21e 1650 result = 0;
cbdc8872 1651#else
1652 {
1653 int tmpfd;
6ad3d225 1654 if ((tmpfd = PerlLIO_open(name, O_RDWR)) < 0)
bbce6d69 1655 result = 0;
cbdc8872 1656 else {
1657 if (my_chsize(tmpfd, len) < 0)
1658 result = 0;
6ad3d225 1659 PerlLIO_close(tmpfd);
cbdc8872 1660 }
a0d0e21e 1661 }
a0d0e21e 1662#endif
cbdc8872 1663 }
a0d0e21e
LW		 1664
1665 if (result)
1666 RETPUSHYES;
1667 if (!errno)
748a9306 1668 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW		 1669 RETPUSHUNDEF;
1670#else
1671 DIE("truncate not implemented");
1672#endif
1673}
1674
1675PP(pp_fcntl)
1676{
1677 return pp_ioctl(ARGS);
1678}
1679
1680PP(pp_ioctl)
1681{
4e35701f 1682 djSP; dTARGET;
748a9306 1683 SV *argsv = POPs;
a0d0e21e 1684 unsigned int func = U_I(POPn);
533c011a 1685 int optype = PL_op->op_type;
a0d0e21e 1686 char *s;
324aa91a 1687 IV retval;
a0d0e21e
LW		 1688 GV *gv = (GV*)POPs;
1689 IO *io = GvIOn(gv);
1690
748a9306
LW		 1691 if (!io || !argsv || !IoIFP(io)) {
1692 SETERRNO(EBADF,RMS$_IFI); /* well, sort of... */
a0d0e21e
LW		 1693 RETPUSHUNDEF;
1694 }
1695
748a9306 1696 if (SvPOK(argsv) || !SvNIOK(argsv)) {
a0d0e21e 1697 STRLEN len;
324aa91a 1698 STRLEN need;
748a9306 1699 s = SvPV_force(argsv, len);
324aa91a
HF		 1700 need = IOCPARM_LEN(func);
1701 if (len < need) {
1702 s = Sv_Grow(argsv, need + 1);
1703 SvCUR_set(argsv, need);
a0d0e21e
LW		 1704 }
1705
748a9306 1706 s[SvCUR(argsv)] = 17; /* a little sanity check here */
a0d0e21e
LW		 1707 }
1708 else {
748a9306 1709 retval = SvIV(argsv);
a0d0e21e 1710 s = (char*)retval; /* ouch */
a0d0e21e
LW		 1711 }
1712
1713 TAINT_PROPER(optype == OP_IOCTL ? "ioctl" : "fcntl");
1714
1715 if (optype == OP_IOCTL)
1716#ifdef HAS_IOCTL
76e3520e 1717 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
a0d0e21e
LW		 1718#else
1719 DIE("ioctl is not implemented");
1720#endif
1721 else
55497cff 1722#ifdef HAS_FCNTL
1723#if defined(OS2) && defined(__EMX__)
760ac839 1724 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
55497cff 1725#else
760ac839 1726 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
55497cff 1727#endif
1728#else
a0d0e21e 1729 DIE("fcntl is not implemented");
a0d0e21e
LW		 1730#endif
1731
748a9306
LW		 1732 if (SvPOK(argsv)) {
1733 if (s[SvCUR(argsv)] != 17)
a0d0e21e
LW		 1734 DIE("Possible memory corruption: %s overflowed 3rd argument",
1735 op_name[optype]);
748a9306
LW		 1736 s[SvCUR(argsv)] = 0; /* put our null back */
1737 SvSETMAGIC(argsv); /* Assume it has changed */
a0d0e21e
LW		 1738 }
1739
1740 if (retval == -1)
1741 RETPUSHUNDEF;
1742 if (retval != 0) {
1743 PUSHi(retval);
1744 }
1745 else {
8903cb82 1746 PUSHp(zero_but_true, ZBTLEN);
a0d0e21e
LW		 1747 }
1748 RETURN;
1749}
1750
1751PP(pp_flock)
1752{
4e35701f 1753 djSP; dTARGET;
a0d0e21e
LW		 1754 I32 value;
1755 int argtype;
1756 GV *gv;
760ac839 1757 PerlIO *fp;
16d20bd9 1758
ff68c719 1759#ifdef FLOCK
a0d0e21e
LW		 1760 argtype = POPi;
1761 if (MAXARG <= 0)
3280af22 1762 gv = PL_last_in_gv;
a0d0e21e
LW		 1763 else
1764 gv = (GV*)POPs;
1765 if (gv && GvIO(gv))
1766 fp = IoIFP(GvIOp(gv));
1767 else
1768 fp = Nullfp;
1769 if (fp) {
68dc0745 1770 (void)PerlIO_flush(fp);
76e3520e 1771 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
a0d0e21e
LW		 1772 }
1773 else
1774 value = 0;
1775 PUSHi(value);
1776 RETURN;
1777#else
a0d0e21e 1778 DIE(no_func, "flock()");
a0d0e21e
LW		 1779#endif
1780}
1781
1782/* Sockets. */
1783
1784PP(pp_socket)
1785{
4e35701f 1786 djSP;
a0d0e21e
LW		 1787#ifdef HAS_SOCKET
1788 GV *gv;
1789 register IO *io;
1790 int protocol = POPi;
1791 int type = POPi;
1792 int domain = POPi;
1793 int fd;
1794
1795 gv = (GV*)POPs;
1796
1797 if (!gv) {
748a9306 1798 SETERRNO(EBADF,LIB$_INVARG);
a0d0e21e
LW		 1799 RETPUSHUNDEF;
1800 }
1801
1802 io = GvIOn(gv);
1803 if (IoIFP(io))
1804 do_close(gv, FALSE);
1805
1806 TAINT_PROPER("socket");
6ad3d225 1807 fd = PerlSock_socket(domain, type, protocol);
a0d0e21e
LW		 1808 if (fd < 0)
1809 RETPUSHUNDEF;
760ac839
LW		 1810 IoIFP(io) = PerlIO_fdopen(fd, "r"); /* stdio gets confused about sockets */
1811 IoOFP(io) = PerlIO_fdopen(fd, "w");
a0d0e21e
LW		 1812 IoTYPE(io) = 's';
1813 if (!IoIFP(io) || !IoOFP(io)) {
760ac839
LW		 1814 if (IoIFP(io)) PerlIO_close(IoIFP(io));
1815 if (IoOFP(io)) PerlIO_close(IoOFP(io));
6ad3d225 1816 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
a0d0e21e
LW		 1817 RETPUSHUNDEF;
1818 }
1819
1820 RETPUSHYES;
1821#else
1822 DIE(no_sock_func, "socket");
1823#endif
1824}
1825
1826PP(pp_sockpair)
1827{
4e35701f 1828 djSP;
a0d0e21e
LW		 1829#ifdef HAS_SOCKETPAIR
1830 GV *gv1;
1831 GV *gv2;
1832 register IO *io1;
1833 register IO *io2;
1834 int protocol = POPi;
1835 int type = POPi;
1836 int domain = POPi;
1837 int fd[2];
1838
1839 gv2 = (GV*)POPs;
1840 gv1 = (GV*)POPs;
1841 if (!gv1 || !gv2)
1842 RETPUSHUNDEF;
1843
1844 io1 = GvIOn(gv1);
1845 io2 = GvIOn(gv2);
1846 if (IoIFP(io1))
1847 do_close(gv1, FALSE);
1848 if (IoIFP(io2))
1849 do_close(gv2, FALSE);
1850
1851 TAINT_PROPER("socketpair");
6ad3d225 1852 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
a0d0e21e 1853 RETPUSHUNDEF;
760ac839
LW		 1854 IoIFP(io1) = PerlIO_fdopen(fd[0], "r");
1855 IoOFP(io1) = PerlIO_fdopen(fd[0], "w");
a0d0e21e 1856 IoTYPE(io1) = 's';
760ac839
LW		 1857 IoIFP(io2) = PerlIO_fdopen(fd[1], "r");
1858 IoOFP(io2) = PerlIO_fdopen(fd[1], "w");
a0d0e21e
LW		 1859 IoTYPE(io2) = 's';
1860 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
760ac839
LW		 1861 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
1862 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
6ad3d225 1863 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
760ac839
LW		 1864 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
1865 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
6ad3d225 1866 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
a0d0e21e
LW		 1867 RETPUSHUNDEF;
1868 }
1869
1870 RETPUSHYES;
1871#else
1872 DIE(no_sock_func, "socketpair");
1873#endif
1874}
1875
1876PP(pp_bind)
1877{
4e35701f 1878 djSP;
a0d0e21e 1879#ifdef HAS_SOCKET
eec2d3df
GS		 1880#ifdef MPE /* Requires PRIV mode to bind() to ports < 1024 */
1881 extern GETPRIVMODE();
1882 extern GETUSERMODE();
1883#endif
748a9306 1884 SV *addrsv = POPs;
a0d0e21e
LW		 1885 char *addr;
1886 GV *gv = (GV*)POPs;
1887 register IO *io = GvIOn(gv);
1888 STRLEN len;
eec2d3df
GS		 1889 int bind_ok = 0;
1890#ifdef MPE
1891 int mpeprivmode = 0;
1892#endif
a0d0e21e
LW		 1893
1894 if (!io || !IoIFP(io))
1895 goto nuts;
1896
748a9306 1897 addr = SvPV(addrsv, len);
a0d0e21e 1898 TAINT_PROPER("bind");
eec2d3df
GS		 1899#ifdef MPE /* Deal with MPE bind() peculiarities */
1900 if (((struct sockaddr *)addr)->sa_family == AF_INET) {
1901 /* The address *MUST* stupidly be zero. */
1902 ((struct sockaddr_in *)addr)->sin_addr.s_addr = INADDR_ANY;
1903 /* PRIV mode is required to bind() to ports < 1024. */
1904 if (((struct sockaddr_in *)addr)->sin_port < 1024 &&
1905 ((struct sockaddr_in *)addr)->sin_port > 0) {
1906 GETPRIVMODE(); /* If this fails, we are aborted by MPE/iX. */
1907 mpeprivmode = 1;
1908 }
1909 }
1910#endif /* MPE */
1911 if (PerlSock_bind(PerlIO_fileno(IoIFP(io)),
1912 (struct sockaddr *)addr, len) >= 0)
1913 bind_ok = 1;
1914
1915#ifdef MPE /* Switch back to USER mode */
1916 if (mpeprivmode)
1917 GETUSERMODE();
1918#endif /* MPE */
1919
1920 if (bind_ok)
a0d0e21e
LW		 1921 RETPUSHYES;
1922 else
1923 RETPUSHUNDEF;
1924
1925nuts:
599cee73
PM		 1926 if (ckWARN(WARN_CLOSED))
1927 warner(WARN_CLOSED, "bind() on closed fd");
748a9306 1928 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 1929 RETPUSHUNDEF;
1930#else
1931 DIE(no_sock_func, "bind");
1932#endif
1933}
1934
1935PP(pp_connect)
1936{
4e35701f 1937 djSP;
a0d0e21e 1938#ifdef HAS_SOCKET
748a9306 1939 SV *addrsv = POPs;
a0d0e21e
LW		 1940 char *addr;
1941 GV *gv = (GV*)POPs;
1942 register IO *io = GvIOn(gv);
1943 STRLEN len;
1944
1945 if (!io || !IoIFP(io))
1946 goto nuts;
1947
748a9306 1948 addr = SvPV(addrsv, len);
a0d0e21e 1949 TAINT_PROPER("connect");
6ad3d225 1950 if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
a0d0e21e
LW		 1951 RETPUSHYES;
1952 else
1953 RETPUSHUNDEF;
1954
1955nuts:
599cee73
PM		 1956 if (ckWARN(WARN_CLOSED))
1957 warner(WARN_CLOSED, "connect() on closed fd");
748a9306 1958 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 1959 RETPUSHUNDEF;
1960#else
1961 DIE(no_sock_func, "connect");
1962#endif
1963}
1964
1965PP(pp_listen)
1966{
4e35701f 1967 djSP;
a0d0e21e
LW		 1968#ifdef HAS_SOCKET
1969 int backlog = POPi;
1970 GV *gv = (GV*)POPs;
1971 register IO *io = GvIOn(gv);
1972
1973 if (!io || !IoIFP(io))
1974 goto nuts;
1975
6ad3d225 1976 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
a0d0e21e
LW		 1977 RETPUSHYES;
1978 else
1979 RETPUSHUNDEF;
1980
1981nuts:
599cee73
PM		 1982 if (ckWARN(WARN_CLOSED))
1983 warner(WARN_CLOSED, "listen() on closed fd");
748a9306 1984 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 1985 RETPUSHUNDEF;
1986#else
1987 DIE(no_sock_func, "listen");
1988#endif
1989}
1990
1991PP(pp_accept)
1992{
4e35701f 1993 djSP; dTARGET;
a0d0e21e
LW		 1994#ifdef HAS_SOCKET
1995 GV *ngv;
1996 GV *ggv;
1997 register IO *nstio;
1998 register IO *gstio;
4633a7c4 1999 struct sockaddr saddr; /* use a struct to avoid alignment problems */
1e422769 2000 Sock_size_t len = sizeof saddr;
a0d0e21e
LW		 2001 int fd;
2002
2003 ggv = (GV*)POPs;
2004 ngv = (GV*)POPs;
2005
2006 if (!ngv)
2007 goto badexit;
2008 if (!ggv)
2009 goto nuts;
2010
2011 gstio = GvIO(ggv);
2012 if (!gstio || !IoIFP(gstio))
2013 goto nuts;
2014
2015 nstio = GvIOn(ngv);
2016 if (IoIFP(nstio))
2017 do_close(ngv, FALSE);
2018
6ad3d225 2019 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *)&saddr, &len);
a0d0e21e
LW		 2020 if (fd < 0)
2021 goto badexit;
760ac839
LW		 2022 IoIFP(nstio) = PerlIO_fdopen(fd, "r");
2023 IoOFP(nstio) = PerlIO_fdopen(fd, "w");
a0d0e21e
LW		 2024 IoTYPE(nstio) = 's';
2025 if (!IoIFP(nstio) || !IoOFP(nstio)) {
760ac839
LW		 2026 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2027 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
6ad3d225 2028 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
a0d0e21e
LW		 2029 goto badexit;
2030 }
2031
748a9306 2032 PUSHp((char *)&saddr, len);
a0d0e21e
LW		 2033 RETURN;
2034
2035nuts:
599cee73
PM		 2036 if (ckWARN(WARN_CLOSED))
2037 warner(WARN_CLOSED, "accept() on closed fd");
748a9306 2038 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2039
2040badexit:
2041 RETPUSHUNDEF;
2042
2043#else
2044 DIE(no_sock_func, "accept");
2045#endif
2046}
2047
2048PP(pp_shutdown)
2049{
4e35701f 2050 djSP; dTARGET;
a0d0e21e
LW		 2051#ifdef HAS_SOCKET
2052 int how = POPi;
2053 GV *gv = (GV*)POPs;
2054 register IO *io = GvIOn(gv);
2055
2056 if (!io || !IoIFP(io))
2057 goto nuts;
2058
6ad3d225 2059 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
a0d0e21e
LW		 2060 RETURN;
2061
2062nuts:
599cee73
PM		 2063 if (ckWARN(WARN_CLOSED))
2064 warner(WARN_CLOSED, "shutdown() on closed fd");
748a9306 2065 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2066 RETPUSHUNDEF;
2067#else
2068 DIE(no_sock_func, "shutdown");
2069#endif
2070}
2071
2072PP(pp_gsockopt)
2073{
2074#ifdef HAS_SOCKET
2075 return pp_ssockopt(ARGS);
2076#else
2077 DIE(no_sock_func, "getsockopt");
2078#endif
2079}
2080
2081PP(pp_ssockopt)
2082{
4e35701f 2083 djSP;
a0d0e21e 2084#ifdef HAS_SOCKET
533c011a 2085 int optype = PL_op->op_type;
a0d0e21e
LW		 2086 SV *sv;
2087 int fd;
2088 unsigned int optname;
2089 unsigned int lvl;
2090 GV *gv;
2091 register IO *io;
1e422769 2092 Sock_size_t len;
a0d0e21e
LW		 2093
2094 if (optype == OP_GSOCKOPT)
2095 sv = sv_2mortal(NEWSV(22, 257));
2096 else
2097 sv = POPs;
2098 optname = (unsigned int) POPi;
2099 lvl = (unsigned int) POPi;
2100
2101 gv = (GV*)POPs;
2102 io = GvIOn(gv);
2103 if (!io || !IoIFP(io))
2104 goto nuts;
2105
760ac839 2106 fd = PerlIO_fileno(IoIFP(io));
a0d0e21e
LW		 2107 switch (optype) {
2108 case OP_GSOCKOPT:
748a9306 2109 SvGROW(sv, 257);
a0d0e21e 2110 (void)SvPOK_only(sv);
748a9306
LW		 2111 SvCUR_set(sv,256);
2112 *SvEND(sv) ='\0';
1e422769 2113 len = SvCUR(sv);
6ad3d225 2114 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
a0d0e21e 2115 goto nuts2;
1e422769 2116 SvCUR_set(sv, len);
748a9306 2117 *SvEND(sv) ='\0';
a0d0e21e
LW		 2118 PUSHs(sv);
2119 break;
2120 case OP_SSOCKOPT: {
1e422769 2121 char *buf;
2122 int aint;
2123 if (SvPOKp(sv)) {
3280af22
NIS		 2124 buf = SvPV(sv, PL_na);
2125 len = PL_na;
1e422769 2126 }
56ee1660 2127 else {
a0d0e21e
LW		 2128 aint = (int)SvIV(sv);
2129 buf = (char*)&aint;
2130 len = sizeof(int);
2131 }
6ad3d225 2132 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
a0d0e21e 2133 goto nuts2;
3280af22 2134 PUSHs(&PL_sv_yes);
a0d0e21e
LW		 2135 }
2136 break;
2137 }
2138 RETURN;
2139
2140nuts:
599cee73
PM		 2141 if (ckWARN(WARN_CLOSED))
2142 warner(WARN_CLOSED, "[gs]etsockopt() on closed fd");
748a9306 2143 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2144nuts2:
2145 RETPUSHUNDEF;
2146
2147#else
2148 DIE(no_sock_func, "setsockopt");
2149#endif
2150}
2151
2152PP(pp_getsockname)
2153{
2154#ifdef HAS_SOCKET
2155 return pp_getpeername(ARGS);
2156#else
2157 DIE(no_sock_func, "getsockname");
2158#endif
2159}
2160
2161PP(pp_getpeername)
2162{
4e35701f 2163 djSP;
a0d0e21e 2164#ifdef HAS_SOCKET
533c011a 2165 int optype = PL_op->op_type;
a0d0e21e
LW		 2166 SV *sv;
2167 int fd;
2168 GV *gv = (GV*)POPs;
2169 register IO *io = GvIOn(gv);
1e422769 2170 Sock_size_t len;
a0d0e21e
LW		 2171
2172 if (!io || !IoIFP(io))
2173 goto nuts;
2174
2175 sv = sv_2mortal(NEWSV(22, 257));
748a9306 2176 (void)SvPOK_only(sv);
1e422769 2177 len = 256;
2178 SvCUR_set(sv, len);
748a9306 2179 *SvEND(sv) ='\0';
760ac839 2180 fd = PerlIO_fileno(IoIFP(io));
a0d0e21e
LW		 2181 switch (optype) {
2182 case OP_GETSOCKNAME:
6ad3d225 2183 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
a0d0e21e
LW		 2184 goto nuts2;
2185 break;
2186 case OP_GETPEERNAME:
6ad3d225 2187 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
a0d0e21e 2188 goto nuts2;
490ab354
JH		 2189#if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2190 {
2191 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";
2192 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2193 if (((struct sockaddr *)SvPVX(sv))->sa_family == AF_INET &&
2194 !memcmp((char *)SvPVX(sv) + sizeof(u_short), nowhere,
2195 sizeof(u_short) + sizeof(struct in_addr))) {
2196 goto nuts2;
2197 }
2198 }
2199#endif
a0d0e21e
LW		 2200 break;
2201 }
13826f2c
CS		 2202#ifdef BOGUS_GETNAME_RETURN
2203 /* Interactive Unix, getpeername() and getsockname()
2204 does not return valid namelen */
1e422769 2205 if (len == BOGUS_GETNAME_RETURN)
2206 len = sizeof(struct sockaddr);
13826f2c 2207#endif
1e422769 2208 SvCUR_set(sv, len);
748a9306 2209 *SvEND(sv) ='\0';
a0d0e21e
LW		 2210 PUSHs(sv);
2211 RETURN;
2212
2213nuts:
599cee73
PM		 2214 if (ckWARN(WARN_CLOSED))
2215 warner(WARN_CLOSED, "get{sock, peer}name() on closed fd");
748a9306 2216 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2217nuts2:
2218 RETPUSHUNDEF;
2219
2220#else
2221 DIE(no_sock_func, "getpeername");
2222#endif
2223}
2224
2225/* Stat calls. */
2226
2227PP(pp_lstat)
2228{
2229 return pp_stat(ARGS);
2230}
2231
2232PP(pp_stat)
2233{
4e35701f 2234 djSP;
a0d0e21e 2235 GV *tmpgv;
54310121 2236 I32 gimme;
a0d0e21e
LW		 2237 I32 max = 13;
2238
533c011a 2239 if (PL_op->op_flags & OPf_REF) {
a0d0e21e 2240 tmpgv = cGVOP->op_gv;
748a9306 2241 do_fstat:
3280af22
NIS		 2242 if (tmpgv != PL_defgv) {
2243 PL_laststype = OP_STAT;
2244 PL_statgv = tmpgv;
2245 sv_setpv(PL_statname, "");
2246 PL_laststatval = (GvIO(tmpgv) && IoIFP(GvIOp(tmpgv))
2247 ? PerlLIO_fstat(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), &PL_statcache) : -1);
a0d0e21e 2248 }
3280af22 2249 if (PL_laststatval < 0)
a0d0e21e
LW		 2250 max = 0;
2251 }
2252 else {
748a9306
LW		 2253 SV* sv = POPs;
2254 if (SvTYPE(sv) == SVt_PVGV) {
2255 tmpgv = (GV*)sv;
2256 goto do_fstat;
2257 }
2258 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2259 tmpgv = (GV*)SvRV(sv);
2260 goto do_fstat;
2261 }
3280af22
NIS		 2262 sv_setpv(PL_statname, SvPV(sv,PL_na));
2263 PL_statgv = Nullgv;
a0d0e21e 2264#ifdef HAS_LSTAT
533c011a
NIS		 2265 PL_laststype = PL_op->op_type;
2266 if (PL_op->op_type == OP_LSTAT)
3280af22 2267 PL_laststatval = PerlLIO_lstat(SvPV(PL_statname, PL_na), &PL_statcache);
a0d0e21e
LW		 2268 else
2269#endif
3280af22
NIS		 2270 PL_laststatval = PerlLIO_stat(SvPV(PL_statname, PL_na), &PL_statcache);
2271 if (PL_laststatval < 0) {
599cee73
PM		 2272 if (ckWARN(WARN_NEWLINE) && strchr(SvPV(PL_statname, PL_na), '\n'))
2273 warner(WARN_NEWLINE, warn_nl, "stat");
a0d0e21e
LW		 2274 max = 0;
2275 }
2276 }
2277
54310121 2278 gimme = GIMME_V;
2279 if (gimme != G_ARRAY) {
2280 if (gimme != G_VOID)
2281 XPUSHs(boolSV(max));
2282 RETURN;
a0d0e21e
LW		 2283 }
2284 if (max) {
36477c24 2285 EXTEND(SP, max);
2286 EXTEND_MORTAL(max);
3280af22
NIS		 2287 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_dev)));
2288 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_ino)));
2289 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_mode)));
2290 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_nlink)));
2291 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_uid)));
2292 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_gid)));
cbdc8872 2293#ifdef USE_STAT_RDEV
3280af22 2294 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_rdev)));
cbdc8872 2295#else
2296 PUSHs(sv_2mortal(newSVpv("", 0)));
2297#endif
3280af22 2298 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_size)));
cbdc8872 2299#ifdef BIG_TIME
6b88bc9c
GS		 2300 PUSHs(sv_2mortal(newSVnv((U32)PL_statcache.st_atime)));
2301 PUSHs(sv_2mortal(newSVnv((U32)PL_statcache.st_mtime)));
2302 PUSHs(sv_2mortal(newSVnv((U32)PL_statcache.st_ctime)));
cbdc8872 2303#else
3280af22
NIS		 2304 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_atime)));
2305 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_mtime)));
2306 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_ctime)));
cbdc8872 2307#endif
a0d0e21e 2308#ifdef USE_STAT_BLOCKS
3280af22
NIS		 2309 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_blksize)));
2310 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_blocks)));
a0d0e21e
LW		 2311#else
2312 PUSHs(sv_2mortal(newSVpv("", 0)));
2313 PUSHs(sv_2mortal(newSVpv("", 0)));
2314#endif
2315 }
2316 RETURN;
2317}
2318
2319PP(pp_ftrread)
2320{
5ff3f7a4 2321 I32 result;
4e35701f 2322 djSP;
5ff3f7a4
GS		 2323#if defined(HAS_ACCESS) && defined(R_OK)
2324 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2325 result = access(TOPp, R_OK);
2326 if (result == 0)
2327 RETPUSHYES;
2328 if (result < 0)
2329 RETPUSHUNDEF;
2330 RETPUSHNO;
2331 } else
2332 result = my_stat(ARGS);
2333#else
2334 result = my_stat(ARGS);
2335#endif
a0d0e21e
LW		 2336 if (result < 0)
2337 RETPUSHUNDEF;
3280af22 2338 if (cando(S_IRUSR, 0, &PL_statcache))
a0d0e21e
LW		 2339 RETPUSHYES;
2340 RETPUSHNO;
2341}
2342
2343PP(pp_ftrwrite)
2344{
5ff3f7a4 2345 I32 result;
4e35701f 2346 djSP;
5ff3f7a4
GS		 2347#if defined(HAS_ACCESS) && defined(W_OK)
2348 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2349 result = access(TOPp, W_OK);
2350 if (result == 0)
2351 RETPUSHYES;
2352 if (result < 0)
2353 RETPUSHUNDEF;
2354 RETPUSHNO;
2355 } else
2356 result = my_stat(ARGS);
2357#else
2358 result = my_stat(ARGS);
2359#endif
a0d0e21e
LW		 2360 if (result < 0)
2361 RETPUSHUNDEF;
3280af22 2362 if (cando(S_IWUSR, 0, &PL_statcache))
a0d0e21e
LW		 2363 RETPUSHYES;
2364 RETPUSHNO;
2365}
2366
2367PP(pp_ftrexec)
2368{
5ff3f7a4 2369 I32 result;
4e35701f 2370 djSP;
5ff3f7a4
GS		 2371#if defined(HAS_ACCESS) && defined(X_OK)
2372 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2373 result = access(TOPp, X_OK);
2374 if (result == 0)
2375 RETPUSHYES;
2376 if (result < 0)
2377 RETPUSHUNDEF;
2378 RETPUSHNO;
2379 } else
2380 result = my_stat(ARGS);
2381#else
2382 result = my_stat(ARGS);
2383#endif
a0d0e21e
LW		 2384 if (result < 0)
2385 RETPUSHUNDEF;
3280af22 2386 if (cando(S_IXUSR, 0, &PL_statcache))
a0d0e21e
LW		 2387 RETPUSHYES;
2388 RETPUSHNO;
2389}
2390
2391PP(pp_fteread)
2392{
5ff3f7a4 2393 I32 result;
4e35701f 2394 djSP;
5ff3f7a4
GS		 2395#ifdef PERL_EFF_ACCESS_R_OK
2396 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2397 result = PERL_EFF_ACCESS_R_OK(TOPp);
2398 if (result == 0)
2399 RETPUSHYES;
2400 if (result < 0)
2401 RETPUSHUNDEF;
2402 RETPUSHNO;
2403 } else
2404 result = my_stat(ARGS);
2405#else
2406 result = my_stat(ARGS);
2407#endif
a0d0e21e
LW		 2408 if (result < 0)
2409 RETPUSHUNDEF;
3280af22 2410 if (cando(S_IRUSR, 1, &PL_statcache))
a0d0e21e
LW		 2411 RETPUSHYES;
2412 RETPUSHNO;
2413}
2414
2415PP(pp_ftewrite)
2416{
5ff3f7a4 2417 I32 result;
4e35701f 2418 djSP;
5ff3f7a4
GS		 2419#ifdef PERL_EFF_ACCESS_W_OK
2420 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2421 result = PERL_EFF_ACCESS_W_OK(TOPp);
2422 if (result == 0)
2423 RETPUSHYES;
2424 if (result < 0)
2425 RETPUSHUNDEF;
2426 RETPUSHNO;
2427 } else
2428 result = my_stat(ARGS);
2429#else
2430 result = my_stat(ARGS);
2431#endif
a0d0e21e
LW		 2432 if (result < 0)
2433 RETPUSHUNDEF;
3280af22 2434 if (cando(S_IWUSR, 1, &PL_statcache))
a0d0e21e
LW		 2435 RETPUSHYES;
2436 RETPUSHNO;
2437}
2438
2439PP(pp_fteexec)
2440{
5ff3f7a4 2441 I32 result;
4e35701f 2442 djSP;
5ff3f7a4
GS		 2443#ifdef PERL_EFF_ACCESS_X_OK
2444 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2445 result = PERL_EFF_ACCESS_X_OK(TOPp);
2446 if (result == 0)
2447 RETPUSHYES;
2448 if (result < 0)
2449 RETPUSHUNDEF;
2450 RETPUSHNO;
2451 } else
2452 result = my_stat(ARGS);
2453#else
2454 result = my_stat(ARGS);
2455#endif
a0d0e21e
LW		 2456 if (result < 0)
2457 RETPUSHUNDEF;
3280af22 2458 if (cando(S_IXUSR, 1, &PL_statcache))
a0d0e21e
LW		 2459 RETPUSHYES;
2460 RETPUSHNO;
2461}
2462
2463PP(pp_ftis)
2464{
2465 I32 result = my_stat(ARGS);
4e35701f 2466 djSP;
a0d0e21e
LW		 2467 if (result < 0)
2468 RETPUSHUNDEF;
2469 RETPUSHYES;
2470}
2471
2472PP(pp_fteowned)
2473{
2474 return pp_ftrowned(ARGS);
2475}
2476
2477PP(pp_ftrowned)
2478{
2479 I32 result = my_stat(ARGS);
4e35701f 2480 djSP;
a0d0e21e
LW		 2481 if (result < 0)
2482 RETPUSHUNDEF;
533c011a 2483 if (PL_statcache.st_uid == (PL_op->op_type == OP_FTEOWNED ? PL_euid : PL_uid) )
a0d0e21e
LW		 2484 RETPUSHYES;
2485 RETPUSHNO;
2486}
2487
2488PP(pp_ftzero)
2489{
2490 I32 result = my_stat(ARGS);
4e35701f 2491 djSP;
a0d0e21e
LW		 2492 if (result < 0)
2493 RETPUSHUNDEF;
3280af22 2494 if (!PL_statcache.st_size)
a0d0e21e
LW		 2495 RETPUSHYES;
2496 RETPUSHNO;
2497}
2498
2499PP(pp_ftsize)
2500{
2501 I32 result = my_stat(ARGS);
4e35701f 2502 djSP; dTARGET;
a0d0e21e
LW		 2503 if (result < 0)
2504 RETPUSHUNDEF;
3280af22 2505 PUSHi(PL_statcache.st_size);
a0d0e21e
LW		 2506 RETURN;
2507}
2508
2509PP(pp_ftmtime)
2510{
2511 I32 result = my_stat(ARGS);
4e35701f 2512 djSP; dTARGET;
a0d0e21e
LW		 2513 if (result < 0)
2514 RETPUSHUNDEF;
3280af22 2515 PUSHn( ((I32)PL_basetime - (I32)PL_statcache.st_mtime) / 86400.0 );
a0d0e21e
LW		 2516 RETURN;
2517}
2518
2519PP(pp_ftatime)
2520{
2521 I32 result = my_stat(ARGS);
4e35701f 2522 djSP; dTARGET;
a0d0e21e
LW		 2523 if (result < 0)
2524 RETPUSHUNDEF;
3280af22 2525 PUSHn( ((I32)PL_basetime - (I32)PL_statcache.st_atime) / 86400.0 );
a0d0e21e
LW		 2526 RETURN;
2527}
2528
2529PP(pp_ftctime)
2530{
2531 I32 result = my_stat(ARGS);
4e35701f 2532 djSP; dTARGET;
a0d0e21e
LW		 2533 if (result < 0)
2534 RETPUSHUNDEF;
3280af22 2535 PUSHn( ((I32)PL_basetime - (I32)PL_statcache.st_ctime) / 86400.0 );
a0d0e21e
LW		 2536 RETURN;
2537}
2538
2539PP(pp_ftsock)
2540{
2541 I32 result = my_stat(ARGS);
4e35701f 2542 djSP;
a0d0e21e
LW		 2543 if (result < 0)
2544 RETPUSHUNDEF;
3280af22 2545 if (S_ISSOCK(PL_statcache.st_mode))
a0d0e21e
LW		 2546 RETPUSHYES;
2547 RETPUSHNO;
2548}
2549
2550PP(pp_ftchr)
2551{
2552 I32 result = my_stat(ARGS);
4e35701f 2553 djSP;
a0d0e21e
LW		 2554 if (result < 0)
2555 RETPUSHUNDEF;
3280af22 2556 if (S_ISCHR(PL_statcache.st_mode))
a0d0e21e
LW		 2557 RETPUSHYES;
2558 RETPUSHNO;
2559}
2560
2561PP(pp_ftblk)
2562{
2563 I32 result = my_stat(ARGS);
4e35701f 2564 djSP;
a0d0e21e
LW		 2565 if (result < 0)
2566 RETPUSHUNDEF;
3280af22 2567 if (S_ISBLK(PL_statcache.st_mode))
a0d0e21e
LW		 2568 RETPUSHYES;
2569 RETPUSHNO;
2570}
2571
2572PP(pp_ftfile)
2573{
2574 I32 result = my_stat(ARGS);
4e35701f 2575 djSP;
a0d0e21e
LW		 2576 if (result < 0)
2577 RETPUSHUNDEF;
3280af22 2578 if (S_ISREG(PL_statcache.st_mode))
a0d0e21e
LW		 2579 RETPUSHYES;
2580 RETPUSHNO;
2581}
2582
2583PP(pp_ftdir)
2584{
2585 I32 result = my_stat(ARGS);
4e35701f 2586 djSP;
a0d0e21e
LW		 2587 if (result < 0)
2588 RETPUSHUNDEF;
3280af22 2589 if (S_ISDIR(PL_statcache.st_mode))
a0d0e21e
LW		 2590 RETPUSHYES;
2591 RETPUSHNO;
2592}
2593
2594PP(pp_ftpipe)
2595{
2596 I32 result = my_stat(ARGS);
4e35701f 2597 djSP;
a0d0e21e
LW		 2598 if (result < 0)
2599 RETPUSHUNDEF;
3280af22 2600 if (S_ISFIFO(PL_statcache.st_mode))
a0d0e21e
LW		 2601 RETPUSHYES;
2602 RETPUSHNO;
2603}
2604
2605PP(pp_ftlink)
2606{
2607 I32 result = my_lstat(ARGS);
4e35701f 2608 djSP;
a0d0e21e
LW		 2609 if (result < 0)
2610 RETPUSHUNDEF;
3280af22 2611 if (S_ISLNK(PL_statcache.st_mode))
a0d0e21e
LW		 2612 RETPUSHYES;
2613 RETPUSHNO;
2614}
2615
2616PP(pp_ftsuid)
2617{
4e35701f 2618 djSP;
a0d0e21e
LW		 2619#ifdef S_ISUID
2620 I32 result = my_stat(ARGS);
2621 SPAGAIN;
2622 if (result < 0)
2623 RETPUSHUNDEF;
3280af22 2624 if (PL_statcache.st_mode & S_ISUID)
a0d0e21e
LW		 2625 RETPUSHYES;
2626#endif
2627 RETPUSHNO;
2628}
2629
2630PP(pp_ftsgid)
2631{
4e35701f 2632 djSP;
a0d0e21e
LW		 2633#ifdef S_ISGID
2634 I32 result = my_stat(ARGS);
2635 SPAGAIN;
2636 if (result < 0)
2637 RETPUSHUNDEF;
3280af22 2638 if (PL_statcache.st_mode & S_ISGID)
a0d0e21e
LW		 2639 RETPUSHYES;
2640#endif
2641 RETPUSHNO;
2642}
2643
2644PP(pp_ftsvtx)
2645{
4e35701f 2646 djSP;
a0d0e21e
LW		 2647#ifdef S_ISVTX
2648 I32 result = my_stat(ARGS);
2649 SPAGAIN;
2650 if (result < 0)
2651 RETPUSHUNDEF;
3280af22 2652 if (PL_statcache.st_mode & S_ISVTX)
a0d0e21e
LW		 2653 RETPUSHYES;
2654#endif
2655 RETPUSHNO;
2656}
2657
2658PP(pp_fttty)
2659{
4e35701f 2660 djSP;
a0d0e21e
LW		 2661 int fd;
2662 GV *gv;
fb73857a 2663 char *tmps = Nullch;
2664
533c011a 2665 if (PL_op->op_flags & OPf_REF)
a0d0e21e 2666 gv = cGVOP->op_gv;
fb73857a 2667 else if (isGV(TOPs))
2668 gv = (GV*)POPs;
2669 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
2670 gv = (GV*)SvRV(POPs);
a0d0e21e
LW		 2671 else
2672 gv = gv_fetchpv(tmps = POPp, FALSE, SVt_PVIO);
fb73857a 2673
a0d0e21e 2674 if (GvIO(gv) && IoIFP(GvIOp(gv)))
760ac839 2675 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
fb73857a 2676 else if (tmps && isDIGIT(*tmps))
a0d0e21e
LW		 2677 fd = atoi(tmps);
2678 else
2679 RETPUSHUNDEF;
6ad3d225 2680 if (PerlLIO_isatty(fd))
a0d0e21e
LW		 2681 RETPUSHYES;
2682 RETPUSHNO;
2683}
2684
16d20bd9
AD		 2685#if defined(atarist) /* this will work with atariST. Configure will
2686 make guesses for other systems. */
2687# define FILE_base(f) ((f)->_base)
2688# define FILE_ptr(f) ((f)->_ptr)
2689# define FILE_cnt(f) ((f)->_cnt)
2690# define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
a0d0e21e
LW		 2691#endif
2692
2693PP(pp_fttext)
2694{
4e35701f 2695 djSP;
a0d0e21e
LW		 2696 I32 i;
2697 I32 len;
2698 I32 odd = 0;
2699 STDCHAR tbuf[512];
2700 register STDCHAR *s;
2701 register IO *io;
5f05dabc 2702 register SV *sv;
2703 GV *gv;
a0d0e21e 2704
533c011a 2705 if (PL_op->op_flags & OPf_REF)
5f05dabc 2706 gv = cGVOP->op_gv;
2707 else if (isGV(TOPs))
2708 gv = (GV*)POPs;
2709 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
2710 gv = (GV*)SvRV(POPs);
2711 else
2712 gv = Nullgv;
2713
2714 if (gv) {
a0d0e21e 2715 EXTEND(SP, 1);
3280af22
NIS		 2716 if (gv == PL_defgv) {
2717 if (PL_statgv)
2718 io = GvIO(PL_statgv);
a0d0e21e 2719 else {
3280af22 2720 sv = PL_statname;
a0d0e21e
LW		 2721 goto really_filename;
2722 }
2723 }
2724 else {
3280af22
NIS		 2725 PL_statgv = gv;
2726 PL_laststatval = -1;
2727 sv_setpv(PL_statname, "");
2728 io = GvIO(PL_statgv);
a0d0e21e
LW		 2729 }
2730 if (io && IoIFP(io)) {
5f05dabc 2731 if (! PerlIO_has_base(IoIFP(io)))
2732 DIE("-T and -B not implemented on filehandles");
3280af22
NIS		 2733 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
2734 if (PL_laststatval < 0)
5f05dabc 2735 RETPUSHUNDEF;
3280af22 2736 if (S_ISDIR(PL_statcache.st_mode)) /* handle NFS glitch */
533c011a 2737 if (PL_op->op_type == OP_FTTEXT)
a0d0e21e
LW		 2738 RETPUSHNO;
2739 else
2740 RETPUSHYES;
760ac839
LW		 2741 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
2742 i = PerlIO_getc(IoIFP(io));
a0d0e21e 2743 if (i != EOF)
760ac839 2744 (void)PerlIO_ungetc(IoIFP(io),i);
a0d0e21e 2745 }
760ac839 2746 if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
a0d0e21e 2747 RETPUSHYES;
760ac839
LW		 2748 len = PerlIO_get_bufsiz(IoIFP(io));
2749 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
2750 /* sfio can have large buffers - limit to 512 */
2751 if (len > 512)
2752 len = 512;
a0d0e21e
LW		 2753 }
2754 else {
599cee73
PM		 2755 if (ckWARN(WARN_UNOPENED))
2756 warner(WARN_UNOPENED, "Test on unopened file <%s>",
a0d0e21e 2757 GvENAME(cGVOP->op_gv));
748a9306 2758 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW		 2759 RETPUSHUNDEF;
2760 }
2761 }
2762 else {
2763 sv = POPs;
5f05dabc 2764 really_filename:
3280af22
NIS		 2765 PL_statgv = Nullgv;
2766 PL_laststatval = -1;
2767 sv_setpv(PL_statname, SvPV(sv, PL_na));
a0d0e21e 2768#ifdef HAS_OPEN3
3280af22 2769 i = PerlLIO_open3(SvPV(sv, PL_na), O_RDONLY, 0);
a0d0e21e 2770#else
b28d0864 2771 i = PerlLIO_open(SvPV(sv, PL_na), 0);
a0d0e21e
LW		 2772#endif
2773 if (i < 0) {
599cee73
PM		 2774 if (ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, PL_na), '\n'))
2775 warner(WARN_NEWLINE, warn_nl, "open");
a0d0e21e
LW		 2776 RETPUSHUNDEF;
2777 }
3280af22
NIS		 2778 PL_laststatval = PerlLIO_fstat(i, &PL_statcache);
2779 if (PL_laststatval < 0)
5f05dabc 2780 RETPUSHUNDEF;
6ad3d225
GS		 2781 len = PerlLIO_read(i, tbuf, 512);
2782 (void)PerlLIO_close(i);
a0d0e21e 2783 if (len <= 0) {
533c011a 2784 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
a0d0e21e
LW		 2785 RETPUSHNO; /* special case NFS directories */
2786 RETPUSHYES; /* null file is anything */
2787 }
2788 s = tbuf;
2789 }
2790
2791 /* now scan s to look for textiness */
4633a7c4 2792 /* XXX ASCII dependent code */
a0d0e21e
LW		 2793
2794 for (i = 0; i < len; i++, s++) {
2795 if (!*s) { /* null never allowed in text */
2796 odd += len;
2797 break;
2798 }
9d116dd7
JH		 2799#ifdef EBCDIC
2800 else if (!(isPRINT(*s) || isSPACE(*s)))
2801 odd++;
2802#else
a0d0e21e
LW		 2803 else if (*s & 128)
2804 odd++;
2805 else if (*s < 32 &&
2806 *s != '\n' && *s != '\r' && *s != '\b' &&
2807 *s != '\t' && *s != '\f' && *s != 27)
2808 odd++;
9d116dd7 2809#endif
a0d0e21e
LW		 2810 }
2811
533c011a 2812 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
a0d0e21e
LW		 2813 RETPUSHNO;
2814 else
2815 RETPUSHYES;
2816}
2817
2818PP(pp_ftbinary)
2819{
2820 return pp_fttext(ARGS);
2821}
2822
2823/* File calls. */
2824
2825PP(pp_chdir)
2826{
4e35701f 2827 djSP; dTARGET;
a0d0e21e
LW		 2828 char *tmps;
2829 SV **svp;
2830
2831 if (MAXARG < 1)
2832 tmps = Nullch;
2833 else
2834 tmps = POPp;
2835 if (!tmps || !*tmps) {
3280af22 2836 svp = hv_fetch(GvHVn(PL_envgv), "HOME", 4, FALSE);
a0d0e21e 2837 if (svp)
3280af22 2838 tmps = SvPV(*svp, PL_na);
a0d0e21e
LW		 2839 }
2840 if (!tmps || !*tmps) {
3280af22 2841 svp = hv_fetch(GvHVn(PL_envgv), "LOGDIR", 6, FALSE);
a0d0e21e 2842 if (svp)
3280af22 2843 tmps = SvPV(*svp, PL_na);
a0d0e21e 2844 }
491527d0
GS		 2845#ifdef VMS
2846 if (!tmps || !*tmps) {
6b88bc9c 2847 svp = hv_fetch(GvHVn(PL_envgv), "SYS$LOGIN", 9, FALSE);
491527d0 2848 if (svp)
b28d0864 2849 tmps = SvPV(*svp, PL_na);
491527d0
GS		 2850 }
2851#endif
a0d0e21e 2852 TAINT_PROPER("chdir");
6ad3d225 2853 PUSHi( PerlDir_chdir(tmps) >= 0 );
748a9306
LW		 2854#ifdef VMS
2855 /* Clear the DEFAULT element of ENV so we'll get the new value
2856 * in the future. */
6b88bc9c 2857 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
748a9306 2858#endif
a0d0e21e
LW		 2859 RETURN;
2860}
2861
2862PP(pp_chown)
2863{
4e35701f 2864 djSP; dMARK; dTARGET;
a0d0e21e
LW		 2865 I32 value;
2866#ifdef HAS_CHOWN
533c011a 2867 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 2868 SP = MARK;
2869 PUSHi(value);
2870 RETURN;
2871#else
2872 DIE(no_func, "Unsupported function chown");
2873#endif
2874}
2875
2876PP(pp_chroot)
2877{
4e35701f 2878 djSP; dTARGET;
a0d0e21e
LW		 2879 char *tmps;
2880#ifdef HAS_CHROOT
2881 tmps = POPp;
2882 TAINT_PROPER("chroot");
2883 PUSHi( chroot(tmps) >= 0 );
2884 RETURN;
2885#else
2886 DIE(no_func, "chroot");
2887#endif
2888}
2889
2890PP(pp_unlink)
2891{
4e35701f 2892 djSP; dMARK; dTARGET;
a0d0e21e 2893 I32 value;
533c011a 2894 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 2895 SP = MARK;
2896 PUSHi(value);
2897 RETURN;
2898}
2899
2900PP(pp_chmod)
2901{
4e35701f 2902 djSP; dMARK; dTARGET;
a0d0e21e 2903 I32 value;
533c011a 2904 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 2905 SP = MARK;
2906 PUSHi(value);
2907 RETURN;
2908}
2909
2910PP(pp_utime)
2911{
4e35701f 2912 djSP; dMARK; dTARGET;
a0d0e21e 2913 I32 value;
533c011a 2914 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 2915 SP = MARK;
2916 PUSHi(value);
2917 RETURN;
2918}
2919
2920PP(pp_rename)
2921{
4e35701f 2922 djSP; dTARGET;
a0d0e21e
LW		 2923 int anum;
2924
2925 char *tmps2 = POPp;
3280af22 2926 char *tmps = SvPV(TOPs, PL_na);
a0d0e21e
LW		 2927 TAINT_PROPER("rename");
2928#ifdef HAS_RENAME
baed7233 2929 anum = PerlLIO_rename(tmps, tmps2);
a0d0e21e 2930#else
6b88bc9c 2931 if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
ed969818
W		 2932 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
2933 anum = 1;
2934 else {
3654eb6c 2935 if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
ed969818
W		 2936 (void)UNLINK(tmps2);
2937 if (!(anum = link(tmps, tmps2)))
2938 anum = UNLINK(tmps);
2939 }
a0d0e21e
LW		 2940 }
2941#endif
2942 SETi( anum >= 0 );
2943 RETURN;
2944}
2945
2946PP(pp_link)
2947{
4e35701f 2948 djSP; dTARGET;
a0d0e21e
LW		 2949#ifdef HAS_LINK
2950 char *tmps2 = POPp;
3280af22 2951 char *tmps = SvPV(TOPs, PL_na);
a0d0e21e
LW		 2952 TAINT_PROPER("link");
2953 SETi( link(tmps, tmps2) >= 0 );
2954#else
2955 DIE(no_func, "Unsupported function link");
2956#endif
2957 RETURN;
2958}
2959
2960PP(pp_symlink)
2961{
4e35701f 2962 djSP; dTARGET;
a0d0e21e
LW		 2963#ifdef HAS_SYMLINK
2964 char *tmps2 = POPp;
3280af22 2965 char *tmps = SvPV(TOPs, PL_na);
a0d0e21e
LW		 2966 TAINT_PROPER("symlink");
2967 SETi( symlink(tmps, tmps2) >= 0 );
2968 RETURN;
2969#else
2970 DIE(no_func, "symlink");
2971#endif
2972}
2973
2974PP(pp_readlink)
2975{
4e35701f 2976 djSP; dTARGET;
a0d0e21e
LW		 2977#ifdef HAS_SYMLINK
2978 char *tmps;
46fc3d4c 2979 char buf[MAXPATHLEN];
a0d0e21e 2980 int len;
46fc3d4c 2981
fb73857a 2982#ifndef INCOMPLETE_TAINTS
2983 TAINT;
2984#endif
a0d0e21e
LW		 2985 tmps = POPp;
2986 len = readlink(tmps, buf, sizeof buf);
2987 EXTEND(SP, 1);
2988 if (len < 0)
2989 RETPUSHUNDEF;
2990 PUSHp(buf, len);
2991 RETURN;
2992#else
2993 EXTEND(SP, 1);
2994 RETSETUNDEF; /* just pretend it's a normal file */
2995#endif
2996}
2997
2998#if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
2999static int
3000dooneliner(cmd, filename)
3001char *cmd;
3002char *filename;
3003{
1e422769 3004 char *save_filename = filename;
3005 char *cmdline;
3006 char *s;
760ac839 3007 PerlIO *myfp;
1e422769 3008 int anum = 1;
a0d0e21e 3009
1e422769 3010 New(666, cmdline, strlen(cmd) + (strlen(filename) * 2) + 10, char);
3011 strcpy(cmdline, cmd);
3012 strcat(cmdline, " ");
3013 for (s = cmdline + strlen(cmdline); *filename; ) {
a0d0e21e
LW		 3014 *s++ = '\\';
3015 *s++ = *filename++;
3016 }
3017 strcpy(s, " 2>&1");
6ad3d225 3018 myfp = PerlProc_popen(cmdline, "r");
1e422769 3019 Safefree(cmdline);
3020
a0d0e21e 3021 if (myfp) {
1e422769 3022 SV *tmpsv = sv_newmortal();
6b88bc9c 3023 /* Need to save/restore 'PL_rs' ?? */
760ac839 3024 s = sv_gets(tmpsv, myfp, 0);
6ad3d225 3025 (void)PerlProc_pclose(myfp);
a0d0e21e 3026 if (s != Nullch) {
1e422769 3027 int e;
3028 for (e = 1;
a0d0e21e 3029#ifdef HAS_SYS_ERRLIST
1e422769 3030 e <= sys_nerr
3031#endif
3032 ; e++)
3033 {
3034 /* you don't see this */
3035 char *errmsg =
3036#ifdef HAS_SYS_ERRLIST
3037 sys_errlist[e]
a0d0e21e 3038#else
1e422769 3039 strerror(e)
a0d0e21e 3040#endif
1e422769 3041 ;
3042 if (!errmsg)
3043 break;
3044 if (instr(s, errmsg)) {
3045 SETERRNO(e,0);
3046 return 0;
3047 }
a0d0e21e 3048 }
748a9306 3049 SETERRNO(0,0);
a0d0e21e
LW		 3050#ifndef EACCES
3051#define EACCES EPERM
3052#endif
1e422769 3053 if (instr(s, "cannot make"))
748a9306 3054 SETERRNO(EEXIST,RMS$_FEX);
1e422769 3055 else if (instr(s, "existing file"))
748a9306 3056 SETERRNO(EEXIST,RMS$_FEX);
1e422769 3057 else if (instr(s, "ile exists"))
748a9306 3058 SETERRNO(EEXIST,RMS$_FEX);
1e422769 3059 else if (instr(s, "non-exist"))
748a9306 3060 SETERRNO(ENOENT,RMS$_FNF);
1e422769 3061 else if (instr(s, "does not exist"))
748a9306 3062 SETERRNO(ENOENT,RMS$_FNF);
1e422769 3063 else if (instr(s, "not empty"))
748a9306 3064 SETERRNO(EBUSY,SS$_DEVOFFLINE);
1e422769 3065 else if (instr(s, "cannot access"))
748a9306 3066 SETERRNO(EACCES,RMS$_PRV);
a0d0e21e 3067 else
748a9306 3068 SETERRNO(EPERM,RMS$_PRV);
a0d0e21e
LW		 3069 return 0;
3070 }
3071 else { /* some mkdirs return no failure indication */
6b88bc9c 3072 anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
911d147d 3073 if (PL_op->op_type == OP_RMDIR)
a0d0e21e
LW		 3074 anum = !anum;
3075 if (anum)
748a9306 3076 SETERRNO(0,0);
a0d0e21e 3077 else
748a9306 3078 SETERRNO(EACCES,RMS$_PRV); /* a guess */
a0d0e21e
LW		 3079 }
3080 return anum;
3081 }
3082 else
3083 return 0;
3084}
3085#endif
3086
3087PP(pp_mkdir)
3088{
4e35701f 3089 djSP; dTARGET;
a0d0e21e
LW		 3090 int mode = POPi;
3091#ifndef HAS_MKDIR
3092 int oldumask;
3093#endif
3280af22 3094 char *tmps = SvPV(TOPs, PL_na);
a0d0e21e
LW		 3095
3096 TAINT_PROPER("mkdir");
3097#ifdef HAS_MKDIR
6ad3d225 3098 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
a0d0e21e
LW		 3099#else
3100 SETi( dooneliner("mkdir", tmps) );
6ad3d225
GS		 3101 oldumask = PerlLIO_umask(0);
3102 PerlLIO_umask(oldumask);
3103 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
a0d0e21e
LW		 3104#endif
3105 RETURN;
3106}
3107
3108PP(pp_rmdir)
3109{
4e35701f 3110 djSP; dTARGET;
a0d0e21e
LW		 3111 char *tmps;
3112
3113 tmps = POPp;
3114 TAINT_PROPER("rmdir");
3115#ifdef HAS_RMDIR
6ad3d225 3116 XPUSHi( PerlDir_rmdir(tmps) >= 0 );
a0d0e21e
LW		 3117#else
3118 XPUSHi( dooneliner("rmdir", tmps) );
3119#endif
3120 RETURN;
3121}
3122
3123/* Directory calls. */
3124
3125PP(pp_open_dir)
3126{
4e35701f 3127 djSP;
a0d0e21e
LW		 3128#if defined(Direntry_t) && defined(HAS_READDIR)
3129 char *dirname = POPp;
3130 GV *gv = (GV*)POPs;
3131 register IO *io = GvIOn(gv);
3132
3133 if (!io)
3134 goto nope;
3135
3136 if (IoDIRP(io))
6ad3d225
GS		 3137 PerlDir_close(IoDIRP(io));
3138 if (!(IoDIRP(io) = PerlDir_open(dirname)))
a0d0e21e
LW		 3139 goto nope;
3140
3141 RETPUSHYES;
3142nope:
3143 if (!errno)
748a9306 3144 SETERRNO(EBADF,RMS$_DIR);
a0d0e21e
LW		 3145 RETPUSHUNDEF;
3146#else
3147 DIE(no_dir_func, "opendir");
3148#endif
3149}
3150
3151PP(pp_readdir)
3152{
4e35701f 3153 djSP;
a0d0e21e
LW		 3154#if defined(Direntry_t) && defined(HAS_READDIR)
3155#ifndef I_DIRENT
3156 Direntry_t *readdir _((DIR *));
3157#endif
3158 register Direntry_t *dp;
3159 GV *gv = (GV*)POPs;
3160 register IO *io = GvIOn(gv);
fb73857a 3161 SV *sv;
a0d0e21e
LW		 3162
3163 if (!io || !IoDIRP(io))
3164 goto nope;
3165
3166 if (GIMME == G_ARRAY) {
3167 /*SUPPRESS 560*/
6ad3d225 3168 while (dp = (Direntry_t *)PerlDir_read(IoDIRP(io))) {
a0d0e21e 3169#ifdef DIRNAMLEN
fb73857a 3170 sv = newSVpv(dp->d_name, dp->d_namlen);
a0d0e21e 3171#else
fb73857a 3172 sv = newSVpv(dp->d_name, 0);
3173#endif
3174#ifndef INCOMPLETE_TAINTS
3175 SvTAINTED_on(sv);
a0d0e21e 3176#endif
fb73857a 3177 XPUSHs(sv_2mortal(sv));
a0d0e21e
LW		 3178 }
3179 }
3180 else {
6ad3d225 3181 if (!(dp = (Direntry_t *)PerlDir_read(IoDIRP(io))))
a0d0e21e
LW		 3182 goto nope;
3183#ifdef DIRNAMLEN
fb73857a 3184 sv = newSVpv(dp->d_name, dp->d_namlen);
a0d0e21e 3185#else
fb73857a 3186 sv = newSVpv(dp->d_name, 0);
a0d0e21e 3187#endif
fb73857a 3188#ifndef INCOMPLETE_TAINTS
3189 SvTAINTED_on(sv);
3190#endif
3191 XPUSHs(sv_2mortal(sv));
a0d0e21e
LW		 3192 }
3193 RETURN;
3194
3195nope:
3196 if (!errno)
748a9306 3197 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 3198 if (GIMME == G_ARRAY)
3199 RETURN;
3200 else
3201 RETPUSHUNDEF;
3202#else
3203 DIE(no_dir_func, "readdir");
3204#endif
3205}
3206
3207PP(pp_telldir)
3208{
4e35701f 3209 djSP; dTARGET;
a0d0e21e 3210#if defined(HAS_TELLDIR) || defined(telldir)
dfe9444c 3211# ifdef NEED_TELLDIR_PROTO /* XXX does _anyone_ need this? --AD 2/20/1998 */
a0d0e21e 3212 long telldir _((DIR *));
dfe9444c 3213# endif
a0d0e21e
LW		 3214 GV *gv = (GV*)POPs;
3215 register IO *io = GvIOn(gv);
3216
3217 if (!io || !IoDIRP(io))
3218 goto nope;
3219
6ad3d225 3220 PUSHi( PerlDir_tell(IoDIRP(io)) );
a0d0e21e
LW		 3221 RETURN;
3222nope:
3223 if (!errno)
748a9306 3224 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 3225 RETPUSHUNDEF;
3226#else
3227 DIE(no_dir_func, "telldir");
3228#endif
3229}
3230
3231PP(pp_seekdir)
3232{
4e35701f 3233 djSP;
a0d0e21e
LW		 3234#if defined(HAS_SEEKDIR) || defined(seekdir)
3235 long along = POPl;
3236 GV *gv = (GV*)POPs;
3237 register IO *io = GvIOn(gv);
3238
3239 if (!io || !IoDIRP(io))
3240 goto nope;
3241
6ad3d225 3242 (void)PerlDir_seek(IoDIRP(io), along);
a0d0e21e
LW		 3243
3244 RETPUSHYES;
3245nope:
3246 if (!errno)
748a9306 3247 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 3248 RETPUSHUNDEF;
3249#else
3250 DIE(no_dir_func, "seekdir");
3251#endif
3252}
3253
3254PP(pp_rewinddir)
3255{
4e35701f 3256 djSP;
a0d0e21e
LW		 3257#if defined(HAS_REWINDDIR) || defined(rewinddir)
3258 GV *gv = (GV*)POPs;
3259 register IO *io = GvIOn(gv);
3260
3261 if (!io || !IoDIRP(io))
3262 goto nope;
3263
6ad3d225 3264 (void)PerlDir_rewind(IoDIRP(io));
a0d0e21e
LW		 3265 RETPUSHYES;
3266nope:
3267 if (!errno)
748a9306 3268 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 3269 RETPUSHUNDEF;
3270#else
3271 DIE(no_dir_func, "rewinddir");
3272#endif
3273}
3274
3275PP(pp_closedir)
3276{
4e35701f 3277 djSP;
a0d0e21e
LW		 3278#if defined(Direntry_t) && defined(HAS_READDIR)
3279 GV *gv = (GV*)POPs;
3280 register IO *io = GvIOn(gv);
3281
3282 if (!io || !IoDIRP(io))
3283 goto nope;
3284
3285#ifdef VOID_CLOSEDIR
6ad3d225 3286 PerlDir_close(IoDIRP(io));
a0d0e21e 3287#else
6ad3d225 3288 if (PerlDir_close(IoDIRP(io)) < 0) {
748a9306 3289 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
a0d0e21e 3290 goto nope;
748a9306 3291 }
a0d0e21e
LW		 3292#endif
3293 IoDIRP(io) = 0;
3294
3295 RETPUSHYES;
3296nope:
3297 if (!errno)
748a9306 3298 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW		 3299 RETPUSHUNDEF;
3300#else
3301 DIE(no_dir_func, "closedir");
3302#endif
3303}
3304
3305/* Process control. */
3306
3307PP(pp_fork)
3308{
44a8e56a 3309#ifdef HAS_FORK
4e35701f 3310 djSP; dTARGET;
a0d0e21e
LW		 3311 int childpid;
3312 GV *tmpgv;
3313
3314 EXTEND(SP, 1);
a0d0e21e
LW		 3315 childpid = fork();
3316 if (childpid < 0)
3317 RETSETUNDEF;
3318 if (!childpid) {
3319 /*SUPPRESS 560*/
3320 if (tmpgv = gv_fetchpv("$", TRUE, SVt_PV))
1e422769 3321 sv_setiv(GvSV(tmpgv), (IV)getpid());
3280af22 3322 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
a0d0e21e
LW		 3323 }
3324 PUSHi(childpid);
3325 RETURN;
3326#else
3327 DIE(no_func, "Unsupported function fork");
3328#endif
3329}
3330
3331PP(pp_wait)
3332{
2d7a9237 3333#if !defined(DOSISH) || defined(OS2) || defined(WIN32)
4e35701f 3334 djSP; dTARGET;
a0d0e21e
LW		 3335 int childpid;
3336 int argflags;
a0d0e21e 3337
44a8e56a 3338 childpid = wait4pid(-1, &argflags, 0);
f86702cc 3339 STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
44a8e56a 3340 XPUSHi(childpid);
a0d0e21e
LW		 3341 RETURN;
3342#else
3343 DIE(no_func, "Unsupported function wait");
3344#endif
3345}
3346
3347PP(pp_waitpid)
3348{
2d7a9237 3349#if !defined(DOSISH) || defined(OS2) || defined(WIN32)
4e35701f 3350 djSP; dTARGET;
a0d0e21e
LW		 3351 int childpid;
3352 int optype;
3353 int argflags;
a0d0e21e 3354
a0d0e21e
LW		 3355 optype = POPi;
3356 childpid = TOPi;
3357 childpid = wait4pid(childpid, &argflags, optype);
f86702cc 3358 STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
44a8e56a 3359 SETi(childpid);
a0d0e21e
LW		 3360 RETURN;
3361#else
2d7a9237 3362 DIE(no_func, "Unsupported function waitpid");
a0d0e21e
LW		 3363#endif
3364}
3365
3366PP(pp_system)
3367{
4e35701f 3368 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW		 3369 I32 value;
3370 int childpid;
3371 int result;
3372 int status;
ff68c719 3373 Sigsave_t ihand,qhand; /* place to save signals during system() */
a0d0e21e 3374
a0d0e21e 3375 if (SP - MARK == 1) {
3280af22
NIS		 3376 if (PL_tainting) {
3377 char *junk = SvPV(TOPs, PL_na);
a0d0e21e
LW		 3378 TAINT_ENV();
3379 TAINT_PROPER("system");
3380 }
3381 }
1e422769 3382#if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2)
a0d0e21e
LW		 3383 while ((childpid = vfork()) == -1) {
3384 if (errno != EAGAIN) {
3385 value = -1;
3386 SP = ORIGMARK;
3387 PUSHi(value);
3388 RETURN;
3389 }
3390 sleep(5);
3391 }
3392 if (childpid > 0) {
ff68c719 3393 rsignal_save(SIGINT, SIG_IGN, &ihand);
3394 rsignal_save(SIGQUIT, SIG_IGN, &qhand);
748a9306
LW		 3395 do {
3396 result = wait4pid(childpid, &status, 0);
3397 } while (result == -1 && errno == EINTR);
ff68c719 3398 (void)rsignal_restore(SIGINT, &ihand);
3399 (void)rsignal_restore(SIGQUIT, &qhand);
91e9c03f 3400 STATUS_NATIVE_SET(result == -1 ? -1 : status);
a0d0e21e
LW		 3401 do_execfree(); /* free any memory child malloced on vfork */
3402 SP = ORIGMARK;
ff0cee69 3403 PUSHi(STATUS_CURRENT);
a0d0e21e
LW		 3404 RETURN;
3405 }
533c011a 3406 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e
LW		 3407 SV *really = *++MARK;
3408 value = (I32)do_aexec(really, MARK, SP);
3409 }
3410 else if (SP - MARK != 1)
3411 value = (I32)do_aexec(Nullsv, MARK, SP);
3412 else {
3280af22 3413 value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), PL_na));
a0d0e21e 3414 }
6ad3d225 3415 PerlProc__exit(-1);
c3293030 3416#else /* ! FORK or VMS or OS/2 */
911d147d 3417 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e 3418 SV *really = *++MARK;
4e35701f 3419 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
a0d0e21e
LW		 3420 }
3421 else if (SP - MARK != 1)
4e35701f 3422 value = (I32)do_aspawn(Nullsv, (void **)MARK, (void **)SP);
a0d0e21e 3423 else {
b28d0864 3424 value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), PL_na));
a0d0e21e 3425 }
f86702cc 3426 STATUS_NATIVE_SET(value);
a0d0e21e
LW		 3427 do_execfree();
3428 SP = ORIGMARK;
ff0cee69 3429 PUSHi(STATUS_CURRENT);
a0d0e21e
LW		 3430#endif /* !FORK or VMS */
3431 RETURN;
3432}
3433
3434PP(pp_exec)
3435{
4e35701f 3436 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW		 3437 I32 value;
3438
533c011a 3439 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e
LW		 3440 SV *really = *++MARK;
3441 value = (I32)do_aexec(really, MARK, SP);
3442 }
3443 else if (SP - MARK != 1)
3444#ifdef VMS
3445 value = (I32)vms_do_aexec(Nullsv, MARK, SP);
3446#else
3447 value = (I32)do_aexec(Nullsv, MARK, SP);
3448#endif
3449 else {
3280af22
NIS		 3450 if (PL_tainting) {
3451 char *junk = SvPV(*SP, PL_na);
a0d0e21e
LW		 3452 TAINT_ENV();
3453 TAINT_PROPER("exec");
3454 }
3455#ifdef VMS
b28d0864 3456 value = (I32)vms_do_exec(SvPVx(sv_mortalcopy(*SP), PL_na));
a0d0e21e 3457#else
3280af22 3458 value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), PL_na));
a0d0e21e
LW		 3459#endif
3460 }
3461 SP = ORIGMARK;
3462 PUSHi(value);
3463 RETURN;
3464}
3465
3466PP(pp_kill)
3467{
4e35701f 3468 djSP; dMARK; dTARGET;
a0d0e21e
LW		 3469 I32 value;
3470#ifdef HAS_KILL
533c011a 3471 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 3472 SP = MARK;
3473 PUSHi(value);
3474 RETURN;
3475#else
3476 DIE(no_func, "Unsupported function kill");
3477#endif
3478}
3479
3480PP(pp_getppid)
3481{
3482#ifdef HAS_GETPPID
4e35701f 3483 djSP; dTARGET;
a0d0e21e
LW		 3484 XPUSHi( getppid() );
3485 RETURN;
3486#else
3487 DIE(no_func, "getppid");
3488#endif
3489}
3490
3491PP(pp_getpgrp)
3492{
3493#ifdef HAS_GETPGRP
4e35701f 3494 djSP; dTARGET;
a0d0e21e
LW		 3495 int pid;
3496 I32 value;
3497
3498 if (MAXARG < 1)
3499 pid = 0;
3500 else
3501 pid = SvIVx(POPs);
c3293030
IZ		 3502#ifdef BSD_GETPGRP
3503 value = (I32)BSD_GETPGRP(pid);
a0d0e21e 3504#else
aa689395 3505 if (pid != 0 && pid != getpid())
a0d0e21e
LW		 3506 DIE("POSIX getpgrp can't take an argument");
3507 value = (I32)getpgrp();
3508#endif
3509 XPUSHi(value);
3510 RETURN;
3511#else
3512 DIE(no_func, "getpgrp()");
3513#endif
3514}
3515
3516PP(pp_setpgrp)
3517{
3518#ifdef HAS_SETPGRP
4e35701f 3519 djSP; dTARGET;
a0d0e21e
LW		 3520 int pgrp;
3521 int pid;
3522 if (MAXARG < 2) {
3523 pgrp = 0;
3524 pid = 0;
3525 }
3526 else {
3527 pgrp = POPi;
3528 pid = TOPi;
3529 }
3530
3531 TAINT_PROPER("setpgrp");
c3293030
IZ		 3532#ifdef BSD_SETPGRP
3533 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
a0d0e21e 3534#else
c90c0ff4 3535 if ((pgrp != 0 && pgrp != getpid()) || (pid != 0 && pid != getpid()))
a0d0e21e 3536 DIE("POSIX setpgrp can't take an argument");
a0d0e21e
LW		 3537 SETi( setpgrp() >= 0 );
3538#endif /* USE_BSDPGRP */
3539 RETURN;
3540#else
3541 DIE(no_func, "setpgrp()");
3542#endif
3543}
3544
3545PP(pp_getpriority)
3546{
4e35701f 3547 djSP; dTARGET;
a0d0e21e
LW		 3548 int which;
3549 int who;
3550#ifdef HAS_GETPRIORITY
3551 who = POPi;
3552 which = TOPi;
3553 SETi( getpriority(which, who) );
3554 RETURN;
3555#else
3556 DIE(no_func, "getpriority()");
3557#endif
3558}
3559
3560PP(pp_setpriority)
3561{
4e35701f 3562 djSP; dTARGET;
a0d0e21e
LW		 3563 int which;
3564 int who;
3565 int niceval;
3566#ifdef HAS_SETPRIORITY
3567 niceval = POPi;
3568 who = POPi;
3569 which = TOPi;
3570 TAINT_PROPER("setpriority");
3571 SETi( setpriority(which, who, niceval) >= 0 );
3572 RETURN;
3573#else
3574 DIE(no_func, "setpriority()");
3575#endif
3576}
3577
3578/* Time calls. */
3579
3580PP(pp_time)
3581{
4e35701f 3582 djSP; dTARGET;
cbdc8872 3583#ifdef BIG_TIME
3584 XPUSHn( time(Null(Time_t*)) );
3585#else
a0d0e21e 3586 XPUSHi( time(Null(Time_t*)) );
cbdc8872 3587#endif
a0d0e21e
LW		 3588 RETURN;
3589}
3590
cd52b7b2 3591/* XXX The POSIX name is CLK_TCK; it is to be preferred
3592 to HZ. Probably. For now, assume that if the system
3593 defines HZ, it does so correctly. (Will this break
3594 on VMS?)
3595 Probably we ought to use _sysconf(_SC_CLK_TCK), if
3596 it's supported. --AD 9/96.
3597*/
3598
a0d0e21e 3599#ifndef HZ
cd52b7b2 3600# ifdef CLK_TCK
3601# define HZ CLK_TCK
3602# else
3603# define HZ 60
3604# endif
a0d0e21e
LW		 3605#endif
3606
3607PP(pp_tms)
3608{
4e35701f 3609 djSP;
a0d0e21e 3610
55497cff 3611#ifndef HAS_TIMES
a0d0e21e
LW		 3612 DIE("times not implemented");
3613#else
3614 EXTEND(SP, 4);
3615
3616#ifndef VMS
3280af22 3617 (void)PerlProc_times(&PL_timesbuf);
a0d0e21e 3618#else
6b88bc9c 3619 (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */
76e3520e
GS		 3620 /* struct tms, though same data */
3621 /* is returned. */
a0d0e21e
LW		 3622#endif
3623
3280af22 3624 PUSHs(sv_2mortal(newSVnv(((double)PL_timesbuf.tms_utime)/HZ)));
a0d0e21e 3625 if (GIMME == G_ARRAY) {
3280af22
NIS		 3626 PUSHs(sv_2mortal(newSVnv(((double)PL_timesbuf.tms_stime)/HZ)));
3627 PUSHs(sv_2mortal(newSVnv(((double)PL_timesbuf.tms_cutime)/HZ)));
3628 PUSHs(sv_2mortal(newSVnv(((double)PL_timesbuf.tms_cstime)/HZ)));
a0d0e21e
LW		 3629 }
3630 RETURN;
55497cff 3631#endif /* HAS_TIMES */
a0d0e21e
LW		 3632}
3633
3634PP(pp_localtime)
3635{
3636 return pp_gmtime(ARGS);
3637}
3638
3639PP(pp_gmtime)
3640{
4e35701f 3641 djSP;
a0d0e21e
LW		 3642 Time_t when;
3643 struct tm *tmbuf;
3644 static char *dayname[] = {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
3645 static char *monname[] = {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
3646 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
3647
3648 if (MAXARG < 1)
3649 (void)time(&when);
3650 else
cbdc8872 3651#ifdef BIG_TIME
3652 when = (Time_t)SvNVx(POPs);
3653#else
a0d0e21e 3654 when = (Time_t)SvIVx(POPs);
cbdc8872 3655#endif
a0d0e21e 3656
533c011a 3657 if (PL_op->op_type == OP_LOCALTIME)
a0d0e21e
LW		 3658 tmbuf = localtime(&when);
3659 else
3660 tmbuf = gmtime(&when);
3661
3662 EXTEND(SP, 9);
bbce6d69 3663 EXTEND_MORTAL(9);
a0d0e21e
LW		 3664 if (GIMME != G_ARRAY) {
3665 dTARGET;
46fc3d4c 3666 SV *tsv;
a0d0e21e
LW		 3667 if (!tmbuf)
3668 RETPUSHUNDEF;
46fc3d4c 3669 tsv = newSVpvf("%s %s %2d %02d:%02d:%02d %d",
3670 dayname[tmbuf->tm_wday],
3671 monname[tmbuf->tm_mon],
3672 tmbuf->tm_mday,
3673 tmbuf->tm_hour,
3674 tmbuf->tm_min,
3675 tmbuf->tm_sec,
3676 tmbuf->tm_year + 1900);
3677 PUSHs(sv_2mortal(tsv));
a0d0e21e
LW		 3678 }
3679 else if (tmbuf) {
3680 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_sec)));
3681 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_min)));
3682 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_hour)));
3683 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_mday)));
3684 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_mon)));
3685 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_year)));
3686 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_wday)));
3687 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_yday)));
3688 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_isdst)));
3689 }
3690 RETURN;
3691}
3692
3693PP(pp_alarm)
3694{
4e35701f 3695 djSP; dTARGET;
a0d0e21e
LW		 3696 int anum;
3697#ifdef HAS_ALARM
3698 anum = POPi;
3699 anum = alarm((unsigned int)anum);
3700 EXTEND(SP, 1);
3701 if (anum < 0)
3702 RETPUSHUNDEF;
3703 PUSHi((I32)anum);
3704 RETURN;
3705#else
3706 DIE(no_func, "Unsupported function alarm");
a0d0e21e
LW		 3707#endif
3708}
3709
3710PP(pp_sleep)
3711{
4e35701f 3712 djSP; dTARGET;
a0d0e21e
LW		 3713 I32 duration;
3714 Time_t lasttime;
3715 Time_t when;
3716
3717 (void)time(&lasttime);
3718 if (MAXARG < 1)
76e3520e 3719 PerlProc_pause();
a0d0e21e
LW		 3720 else {
3721 duration = POPi;
76e3520e 3722 PerlProc_sleep((unsigned int)duration);
a0d0e21e
LW		 3723 }
3724 (void)time(&when);
3725 XPUSHi(when - lasttime);
3726 RETURN;
3727}
3728
3729/* Shared memory. */
3730
3731PP(pp_shmget)
3732{
3733 return pp_semget(ARGS);
3734}
3735
3736PP(pp_shmctl)
3737{
3738 return pp_semctl(ARGS);
3739}
3740
3741PP(pp_shmread)
3742{
3743 return pp_shmwrite(ARGS);
3744}
3745
3746PP(pp_shmwrite)
3747{
3748#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 3749 djSP; dMARK; dTARGET;
533c011a 3750 I32 value = (I32)(do_shmio(PL_op->op_type, MARK, SP) >= 0);
a0d0e21e
LW		 3751 SP = MARK;
3752 PUSHi(value);
3753 RETURN;
3754#else
748a9306 3755 return pp_semget(ARGS);
a0d0e21e
LW		 3756#endif
3757}
3758
3759/* Message passing. */
3760
3761PP(pp_msgget)
3762{
3763 return pp_semget(ARGS);
3764}
3765
3766PP(pp_msgctl)
3767{
3768 return pp_semctl(ARGS);
3769}
3770
3771PP(pp_msgsnd)
3772{
3773#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 3774 djSP; dMARK; dTARGET;
a0d0e21e
LW		 3775 I32 value = (I32)(do_msgsnd(MARK, SP) >= 0);
3776 SP = MARK;
3777 PUSHi(value);
3778 RETURN;
3779#else
748a9306 3780 return pp_semget(ARGS);
a0d0e21e
LW		 3781#endif
3782}
3783
3784PP(pp_msgrcv)
3785{
3786#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 3787 djSP; dMARK; dTARGET;
a0d0e21e
LW		 3788 I32 value = (I32)(do_msgrcv(MARK, SP) >= 0);
3789 SP = MARK;
3790 PUSHi(value);
3791 RETURN;
3792#else
748a9306 3793 return pp_semget(ARGS);
a0d0e21e
LW		 3794#endif