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