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