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