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