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