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