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