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