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