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