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
Fix email address for Kragen Sitaker <kragen@pobox.com>.
[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
25342a55 2056#if Off_t_size > IVSIZE
8c99d73e
GS		 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
c214f4ad
WB		 2181#ifndef HAS_FCNTL
2182 DIE(aTHX_ "fcntl is not implemented");
2183#else
55497cff 2184#if defined(OS2) && defined(__EMX__)
760ac839 2185 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
55497cff 2186#else
760ac839 2187 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
301e8125 2188#endif
a0d0e21e 2189
748a9306
LW		 2190 if (SvPOK(argsv)) {
2191 if (s[SvCUR(argsv)] != 17)
cea2e8a9 2192 DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
53e06cf0 2193 OP_NAME(PL_op));
748a9306
LW		 2194 s[SvCUR(argsv)] = 0; /* put our null back */
2195 SvSETMAGIC(argsv); /* Assume it has changed */
a0d0e21e
LW		 2196 }
2197
2198 if (retval == -1)
2199 RETPUSHUNDEF;
2200 if (retval != 0) {
2201 PUSHi(retval);
2202 }
2203 else {
8903cb82 2204 PUSHp(zero_but_true, ZBTLEN);
a0d0e21e 2205 }
4808266b 2206#endif
c214f4ad 2207 RETURN;
a0d0e21e
LW		 2208}
2209
2210PP(pp_flock)
2211{
9cad6237 2212#ifdef FLOCK
39644a26 2213 dSP; dTARGET;
a0d0e21e
LW		 2214 I32 value;
2215 int argtype;
2216 GV *gv;
bc37a18f 2217 IO *io = NULL;
760ac839 2218 PerlIO *fp;
16d20bd9 2219
a0d0e21e 2220 argtype = POPi;
32da55ab 2221 if (MAXARG == 0)
3280af22 2222 gv = PL_last_in_gv;
a0d0e21e
LW		 2223 else
2224 gv = (GV*)POPs;
bc37a18f
RG		 2225 if (gv && (io = GvIO(gv)))
2226 fp = IoIFP(io);
2227 else {
a0d0e21e 2228 fp = Nullfp;
bc37a18f
RG		 2229 io = NULL;
2230 }
a0d0e21e 2231 if (fp) {
68dc0745 2232 (void)PerlIO_flush(fp);
76e3520e 2233 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
a0d0e21e 2234 }
cb50131a 2235 else {
bc37a18f
RG		 2236 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2237 report_evil_fh(gv, io, PL_op->op_type);
a0d0e21e 2238 value = 0;
91487cfc 2239 SETERRNO(EBADF,RMS$_IFI);
cb50131a 2240 }
a0d0e21e
LW		 2241 PUSHi(value);
2242 RETURN;
2243#else
cea2e8a9 2244 DIE(aTHX_ PL_no_func, "flock()");
a0d0e21e
LW		 2245#endif
2246}
2247
2248/* Sockets. */
2249
2250PP(pp_socket)
2251{
a0d0e21e 2252#ifdef HAS_SOCKET
9cad6237 2253 dSP;
a0d0e21e
LW		 2254 GV *gv;
2255 register IO *io;
2256 int protocol = POPi;
2257 int type = POPi;
2258 int domain = POPi;
2259 int fd;
2260
2261 gv = (GV*)POPs;
c289d2f7 2262 io = gv ? GvIOn(gv) : NULL;
a0d0e21e 2263
c289d2f7
JH		 2264 if (!gv || !io) {
2265 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2266 report_evil_fh(gv, io, PL_op->op_type);
2267 if (IoIFP(io))
2268 do_close(gv, FALSE);
91487cfc 2269 SETERRNO(EBADF,LIB$_INVARG);
a0d0e21e
LW		 2270 RETPUSHUNDEF;
2271 }
2272
57171420
BS		 2273 if (IoIFP(io))
2274 do_close(gv, FALSE);
2275
a0d0e21e 2276 TAINT_PROPER("socket");
6ad3d225 2277 fd = PerlSock_socket(domain, type, protocol);
a0d0e21e
LW		 2278 if (fd < 0)
2279 RETPUSHUNDEF;
760ac839
LW		 2280 IoIFP(io) = PerlIO_fdopen(fd, "r"); /* stdio gets confused about sockets */
2281 IoOFP(io) = PerlIO_fdopen(fd, "w");
50952442 2282 IoTYPE(io) = IoTYPE_SOCKET;
a0d0e21e 2283 if (!IoIFP(io) || !IoOFP(io)) {
760ac839
LW		 2284 if (IoIFP(io)) PerlIO_close(IoIFP(io));
2285 if (IoOFP(io)) PerlIO_close(IoOFP(io));
6ad3d225 2286 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
a0d0e21e
LW		 2287 RETPUSHUNDEF;
2288 }
8d2a6795
GS		 2289#if defined(HAS_FCNTL) && defined(F_SETFD)
2290 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2291#endif
a0d0e21e 2292
d5ff79b3
OF		 2293#ifdef EPOC
2294 setbuf( IoIFP(io), NULL); /* EPOC gets confused about sockets */
2295#endif
2296
a0d0e21e
LW		 2297 RETPUSHYES;
2298#else
cea2e8a9 2299 DIE(aTHX_ PL_no_sock_func, "socket");
a0d0e21e
LW		 2300#endif
2301}
2302
2303PP(pp_sockpair)
2304{
c95c94b1 2305#if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
76ffd3b9 2306 dSP;
a0d0e21e
LW		 2307 GV *gv1;
2308 GV *gv2;
2309 register IO *io1;
2310 register IO *io2;
2311 int protocol = POPi;
2312 int type = POPi;
2313 int domain = POPi;
2314 int fd[2];
2315
2316 gv2 = (GV*)POPs;
2317 gv1 = (GV*)POPs;
c289d2f7
JH		 2318 io1 = gv1 ? GvIOn(gv1) : NULL;
2319 io2 = gv2 ? GvIOn(gv2) : NULL;
2320 if (!gv1 || !gv2 || !io1 || !io2) {
2321 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
2322 if (!gv1 || !io1)
2323 report_evil_fh(gv1, io1, PL_op->op_type);
2324 if (!gv2 || !io2)
2325 report_evil_fh(gv1, io2, PL_op->op_type);
2326 }
2327 if (IoIFP(io1))
2328 do_close(gv1, FALSE);
2329 if (IoIFP(io2))
2330 do_close(gv2, FALSE);
a0d0e21e 2331 RETPUSHUNDEF;
c289d2f7 2332 }
a0d0e21e 2333
dc0d0a5f
JH		 2334 if (IoIFP(io1))
2335 do_close(gv1, FALSE);
2336 if (IoIFP(io2))
2337 do_close(gv2, FALSE);
57171420 2338
a0d0e21e 2339 TAINT_PROPER("socketpair");
6ad3d225 2340 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
a0d0e21e 2341 RETPUSHUNDEF;
760ac839
LW		 2342 IoIFP(io1) = PerlIO_fdopen(fd[0], "r");
2343 IoOFP(io1) = PerlIO_fdopen(fd[0], "w");
50952442 2344 IoTYPE(io1) = IoTYPE_SOCKET;
760ac839
LW		 2345 IoIFP(io2) = PerlIO_fdopen(fd[1], "r");
2346 IoOFP(io2) = PerlIO_fdopen(fd[1], "w");
50952442 2347 IoTYPE(io2) = IoTYPE_SOCKET;
a0d0e21e 2348 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
760ac839
LW		 2349 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2350 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
6ad3d225 2351 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
760ac839
LW		 2352 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2353 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
6ad3d225 2354 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
a0d0e21e
LW		 2355 RETPUSHUNDEF;
2356 }
8d2a6795
GS		 2357#if defined(HAS_FCNTL) && defined(F_SETFD)
2358 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
2359 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
2360#endif
a0d0e21e
LW		 2361
2362 RETPUSHYES;
2363#else
cea2e8a9 2364 DIE(aTHX_ PL_no_sock_func, "socketpair");
a0d0e21e
LW		 2365#endif
2366}
2367
2368PP(pp_bind)
2369{
a0d0e21e 2370#ifdef HAS_SOCKET
9cad6237 2371 dSP;
eec2d3df 2372#ifdef MPE /* Requires PRIV mode to bind() to ports < 1024 */
82b3da69
JH		 2373 extern void GETPRIVMODE();
2374 extern void GETUSERMODE();
eec2d3df 2375#endif
748a9306 2376 SV *addrsv = POPs;
a0d0e21e
LW		 2377 char *addr;
2378 GV *gv = (GV*)POPs;
2379 register IO *io = GvIOn(gv);
2380 STRLEN len;
eec2d3df
GS		 2381 int bind_ok = 0;
2382#ifdef MPE
2383 int mpeprivmode = 0;
2384#endif
a0d0e21e
LW		 2385
2386 if (!io || !IoIFP(io))
2387 goto nuts;
2388
748a9306 2389 addr = SvPV(addrsv, len);
a0d0e21e 2390 TAINT_PROPER("bind");
eec2d3df
GS		 2391#ifdef MPE /* Deal with MPE bind() peculiarities */
2392 if (((struct sockaddr *)addr)->sa_family == AF_INET) {
2393 /* The address *MUST* stupidly be zero. */
2394 ((struct sockaddr_in *)addr)->sin_addr.s_addr = INADDR_ANY;
2395 /* PRIV mode is required to bind() to ports < 1024. */
2396 if (((struct sockaddr_in *)addr)->sin_port < 1024 &&
2397 ((struct sockaddr_in *)addr)->sin_port > 0) {
2398 GETPRIVMODE(); /* If this fails, we are aborted by MPE/iX. */
2399 mpeprivmode = 1;
2400 }
2401 }
2402#endif /* MPE */
2403 if (PerlSock_bind(PerlIO_fileno(IoIFP(io)),
2404 (struct sockaddr *)addr, len) >= 0)
2405 bind_ok = 1;
2406
2407#ifdef MPE /* Switch back to USER mode */
2408 if (mpeprivmode)
2409 GETUSERMODE();
2410#endif /* MPE */
2411
2412 if (bind_ok)
a0d0e21e
LW		 2413 RETPUSHYES;
2414 else
2415 RETPUSHUNDEF;
2416
2417nuts:
599cee73 2418 if (ckWARN(WARN_CLOSED))
bc37a18f 2419 report_evil_fh(gv, io, PL_op->op_type);
91487cfc 2420 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2421 RETPUSHUNDEF;
2422#else
cea2e8a9 2423 DIE(aTHX_ PL_no_sock_func, "bind");
a0d0e21e
LW		 2424#endif
2425}
2426
2427PP(pp_connect)
2428{
a0d0e21e 2429#ifdef HAS_SOCKET
9cad6237 2430 dSP;
748a9306 2431 SV *addrsv = POPs;
a0d0e21e
LW		 2432 char *addr;
2433 GV *gv = (GV*)POPs;
2434 register IO *io = GvIOn(gv);
2435 STRLEN len;
2436
2437 if (!io || !IoIFP(io))
2438 goto nuts;
2439
748a9306 2440 addr = SvPV(addrsv, len);
a0d0e21e 2441 TAINT_PROPER("connect");
6ad3d225 2442 if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
a0d0e21e
LW		 2443 RETPUSHYES;
2444 else
2445 RETPUSHUNDEF;
2446
2447nuts:
599cee73 2448 if (ckWARN(WARN_CLOSED))
bc37a18f 2449 report_evil_fh(gv, io, PL_op->op_type);
91487cfc 2450 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2451 RETPUSHUNDEF;
2452#else
cea2e8a9 2453 DIE(aTHX_ PL_no_sock_func, "connect");
a0d0e21e
LW		 2454#endif
2455}
2456
2457PP(pp_listen)
2458{
a0d0e21e 2459#ifdef HAS_SOCKET
9cad6237 2460 dSP;
a0d0e21e
LW		 2461 int backlog = POPi;
2462 GV *gv = (GV*)POPs;
c289d2f7 2463 register IO *io = gv ? GvIOn(gv) : NULL;
a0d0e21e 2464
c289d2f7 2465 if (!gv || !io || !IoIFP(io))
a0d0e21e
LW		 2466 goto nuts;
2467
6ad3d225 2468 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
a0d0e21e
LW		 2469 RETPUSHYES;
2470 else
2471 RETPUSHUNDEF;
2472
2473nuts:
599cee73 2474 if (ckWARN(WARN_CLOSED))
bc37a18f 2475 report_evil_fh(gv, io, PL_op->op_type);
91487cfc 2476 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2477 RETPUSHUNDEF;
2478#else
cea2e8a9 2479 DIE(aTHX_ PL_no_sock_func, "listen");
a0d0e21e
LW		 2480#endif
2481}
2482
2483PP(pp_accept)
2484{
a0d0e21e 2485#ifdef HAS_SOCKET
9cad6237 2486 dSP; dTARGET;
a0d0e21e
LW		 2487 GV *ngv;
2488 GV *ggv;
2489 register IO *nstio;
2490 register IO *gstio;
4633a7c4 2491 struct sockaddr saddr; /* use a struct to avoid alignment problems */
1e422769 2492 Sock_size_t len = sizeof saddr;
a0d0e21e 2493 int fd;
72f496dc 2494 int fd2;
a0d0e21e
LW		 2495
2496 ggv = (GV*)POPs;
2497 ngv = (GV*)POPs;
2498
2499 if (!ngv)
2500 goto badexit;
2501 if (!ggv)
2502 goto nuts;
2503
2504 gstio = GvIO(ggv);
2505 if (!gstio || !IoIFP(gstio))
2506 goto nuts;
2507
2508 nstio = GvIOn(ngv);
6ad3d225 2509 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *)&saddr, &len);
a0d0e21e
LW		 2510 if (fd < 0)
2511 goto badexit;
a70048fb
AB		 2512 if (IoIFP(nstio))
2513 do_close(ngv, FALSE);
760ac839 2514 IoIFP(nstio) = PerlIO_fdopen(fd, "r");
72f496dc
NIS		 2515 /* FIXME: we dup(fd) here so that refcounting of fd's does not inhibit
2516 fclose of IoOFP's FILE * - and hence leak memory.
2517 Special treatment of _this_ case of IoIFP != IoOFP seems wrong.
2518 */
2519 IoOFP(nstio) = PerlIO_fdopen(fd2 = PerlLIO_dup(fd), "w");
50952442 2520 IoTYPE(nstio) = IoTYPE_SOCKET;
a0d0e21e 2521 if (!IoIFP(nstio) || !IoOFP(nstio)) {
760ac839
LW		 2522 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2523 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
6ad3d225 2524 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
a0d0e21e
LW		 2525 goto badexit;
2526 }
8d2a6795
GS		 2527#if defined(HAS_FCNTL) && defined(F_SETFD)
2528 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
72f496dc 2529 fcntl(fd2, F_SETFD, fd2 > PL_maxsysfd); /* ensure close-on-exec */
8d2a6795 2530#endif
a0d0e21e 2531
ed79a026 2532#ifdef EPOC
a9f1f6b0
OF		 2533 len = sizeof saddr; /* EPOC somehow truncates info */
2534 setbuf( IoIFP(nstio), NULL); /* EPOC gets confused about sockets */
ed79a026
OF		 2535#endif
2536
748a9306 2537 PUSHp((char *)&saddr, len);
a0d0e21e
LW		 2538 RETURN;
2539
2540nuts:
599cee73 2541 if (ckWARN(WARN_CLOSED))
bc37a18f 2542 report_evil_fh(ggv, ggv ? GvIO(ggv) : 0, PL_op->op_type);
91487cfc 2543 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2544
2545badexit:
2546 RETPUSHUNDEF;
2547
2548#else
cea2e8a9 2549 DIE(aTHX_ PL_no_sock_func, "accept");
a0d0e21e
LW		 2550#endif
2551}
2552
2553PP(pp_shutdown)
2554{
a0d0e21e 2555#ifdef HAS_SOCKET
9cad6237 2556 dSP; dTARGET;
a0d0e21e
LW		 2557 int how = POPi;
2558 GV *gv = (GV*)POPs;
2559 register IO *io = GvIOn(gv);
2560
2561 if (!io || !IoIFP(io))
2562 goto nuts;
2563
6ad3d225 2564 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
a0d0e21e
LW		 2565 RETURN;
2566
2567nuts:
599cee73 2568 if (ckWARN(WARN_CLOSED))
bc37a18f 2569 report_evil_fh(gv, io, PL_op->op_type);
91487cfc 2570 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2571 RETPUSHUNDEF;
2572#else
cea2e8a9 2573 DIE(aTHX_ PL_no_sock_func, "shutdown");
a0d0e21e
LW		 2574#endif
2575}
2576
2577PP(pp_gsockopt)
2578{
2579#ifdef HAS_SOCKET
cea2e8a9 2580 return pp_ssockopt();
a0d0e21e 2581#else
cea2e8a9 2582 DIE(aTHX_ PL_no_sock_func, "getsockopt");
a0d0e21e
LW		 2583#endif
2584}
2585
2586PP(pp_ssockopt)
2587{
a0d0e21e 2588#ifdef HAS_SOCKET
9cad6237 2589 dSP;
533c011a 2590 int optype = PL_op->op_type;
a0d0e21e
LW		 2591 SV *sv;
2592 int fd;
2593 unsigned int optname;
2594 unsigned int lvl;
2595 GV *gv;
2596 register IO *io;
1e422769 2597 Sock_size_t len;
a0d0e21e
LW		 2598
2599 if (optype == OP_GSOCKOPT)
2600 sv = sv_2mortal(NEWSV(22, 257));
2601 else
2602 sv = POPs;
2603 optname = (unsigned int) POPi;
2604 lvl = (unsigned int) POPi;
2605
2606 gv = (GV*)POPs;
2607 io = GvIOn(gv);
2608 if (!io || !IoIFP(io))
2609 goto nuts;
2610
760ac839 2611 fd = PerlIO_fileno(IoIFP(io));
a0d0e21e
LW		 2612 switch (optype) {
2613 case OP_GSOCKOPT:
748a9306 2614 SvGROW(sv, 257);
a0d0e21e 2615 (void)SvPOK_only(sv);
748a9306
LW		 2616 SvCUR_set(sv,256);
2617 *SvEND(sv) ='\0';
1e422769 2618 len = SvCUR(sv);
6ad3d225 2619 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
a0d0e21e 2620 goto nuts2;
1e422769 2621 SvCUR_set(sv, len);
748a9306 2622 *SvEND(sv) ='\0';
a0d0e21e
LW		 2623 PUSHs(sv);
2624 break;
2625 case OP_SSOCKOPT: {
1e422769 2626 char *buf;
2627 int aint;
2628 if (SvPOKp(sv)) {
2d8e6c8d
GS		 2629 STRLEN l;
2630 buf = SvPV(sv, l);
2631 len = l;
1e422769 2632 }
56ee1660 2633 else {
a0d0e21e
LW		 2634 aint = (int)SvIV(sv);
2635 buf = (char*)&aint;
2636 len = sizeof(int);
2637 }
6ad3d225 2638 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
a0d0e21e 2639 goto nuts2;
3280af22 2640 PUSHs(&PL_sv_yes);
a0d0e21e
LW		 2641 }
2642 break;
2643 }
2644 RETURN;
2645
2646nuts:
599cee73 2647 if (ckWARN(WARN_CLOSED))
bc37a18f 2648 report_evil_fh(gv, io, optype);
91487cfc 2649 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2650nuts2:
2651 RETPUSHUNDEF;
2652
2653#else
cea2e8a9 2654 DIE(aTHX_ PL_no_sock_func, "setsockopt");
a0d0e21e
LW		 2655#endif
2656}
2657
2658PP(pp_getsockname)
2659{
2660#ifdef HAS_SOCKET
cea2e8a9 2661 return pp_getpeername();
a0d0e21e 2662#else
cea2e8a9 2663 DIE(aTHX_ PL_no_sock_func, "getsockname");
a0d0e21e
LW		 2664#endif
2665}
2666
2667PP(pp_getpeername)
2668{
a0d0e21e 2669#ifdef HAS_SOCKET
9cad6237 2670 dSP;
533c011a 2671 int optype = PL_op->op_type;
a0d0e21e
LW		 2672 SV *sv;
2673 int fd;
2674 GV *gv = (GV*)POPs;
2675 register IO *io = GvIOn(gv);
1e422769 2676 Sock_size_t len;
a0d0e21e
LW		 2677
2678 if (!io || !IoIFP(io))
2679 goto nuts;
2680
2681 sv = sv_2mortal(NEWSV(22, 257));
748a9306 2682 (void)SvPOK_only(sv);
1e422769 2683 len = 256;
2684 SvCUR_set(sv, len);
748a9306 2685 *SvEND(sv) ='\0';
760ac839 2686 fd = PerlIO_fileno(IoIFP(io));
a0d0e21e
LW		 2687 switch (optype) {
2688 case OP_GETSOCKNAME:
6ad3d225 2689 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
a0d0e21e
LW		 2690 goto nuts2;
2691 break;
2692 case OP_GETPEERNAME:
6ad3d225 2693 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
a0d0e21e 2694 goto nuts2;
490ab354
JH		 2695#if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2696 {
2697 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";
2698 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2699 if (((struct sockaddr *)SvPVX(sv))->sa_family == AF_INET &&
2700 !memcmp((char *)SvPVX(sv) + sizeof(u_short), nowhere,
2701 sizeof(u_short) + sizeof(struct in_addr))) {
301e8125 2702 goto nuts2;
490ab354
JH		 2703 }
2704 }
2705#endif
a0d0e21e
LW		 2706 break;
2707 }
13826f2c
CS		 2708#ifdef BOGUS_GETNAME_RETURN
2709 /* Interactive Unix, getpeername() and getsockname()
2710 does not return valid namelen */
1e422769 2711 if (len == BOGUS_GETNAME_RETURN)
2712 len = sizeof(struct sockaddr);
13826f2c 2713#endif
1e422769 2714 SvCUR_set(sv, len);
748a9306 2715 *SvEND(sv) ='\0';
a0d0e21e
LW		 2716 PUSHs(sv);
2717 RETURN;
2718
2719nuts:
599cee73 2720 if (ckWARN(WARN_CLOSED))
bc37a18f 2721 report_evil_fh(gv, io, optype);
91487cfc 2722 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2723nuts2:
2724 RETPUSHUNDEF;
2725
2726#else
cea2e8a9 2727 DIE(aTHX_ PL_no_sock_func, "getpeername");
a0d0e21e
LW		 2728#endif
2729}
2730
2731/* Stat calls. */
2732
2733PP(pp_lstat)
2734{
cea2e8a9 2735 return pp_stat();
a0d0e21e
LW		 2736}
2737
2738PP(pp_stat)
2739{
39644a26 2740 dSP;
2dd78f96 2741 GV *gv;
54310121 2742 I32 gimme;
a0d0e21e 2743 I32 max = 13;
2d8e6c8d 2744 STRLEN n_a;
a0d0e21e 2745
533c011a 2746 if (PL_op->op_flags & OPf_REF) {
2dd78f96 2747 gv = cGVOP_gv;
8a4e5b40 2748 if (PL_op->op_type == OP_LSTAT) {
5d3e98de
RGS		 2749 if (gv != PL_defgv) {
2750 if (ckWARN(WARN_IO))
9014280d 2751 Perl_warner(aTHX_ packWARN(WARN_IO),
5d3e98de
RGS		 2752 "lstat() on filehandle %s", GvENAME(gv));
2753 } else if (PL_laststype != OP_LSTAT)
8a4e5b40 2754 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
8a4e5b40
DD		 2755 }
2756
748a9306 2757 do_fstat:
2dd78f96 2758 if (gv != PL_defgv) {
3280af22 2759 PL_laststype = OP_STAT;
2dd78f96 2760 PL_statgv = gv;
3280af22 2761 sv_setpv(PL_statname, "");
2dd78f96
JH		 2762 PL_laststatval = (GvIO(gv) && IoIFP(GvIOp(gv))
2763 ? PerlLIO_fstat(PerlIO_fileno(IoIFP(GvIOn(gv))), &PL_statcache) : -1);
a0d0e21e 2764 }
9ddeeac9 2765 if (PL_laststatval < 0) {
2dd78f96
JH		 2766 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2767 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
a0d0e21e 2768 max = 0;
9ddeeac9 2769 }
a0d0e21e
LW		 2770 }
2771 else {
748a9306
LW		 2772 SV* sv = POPs;
2773 if (SvTYPE(sv) == SVt_PVGV) {
2dd78f96 2774 gv = (GV*)sv;
748a9306
LW		 2775 goto do_fstat;
2776 }
2777 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2dd78f96 2778 gv = (GV*)SvRV(sv);
5d3e98de 2779 if (PL_op->op_type == OP_LSTAT && ckWARN(WARN_IO))
9014280d 2780 Perl_warner(aTHX_ packWARN(WARN_IO),
5d3e98de 2781 "lstat() on filehandle %s", GvENAME(gv));
748a9306
LW		 2782 goto do_fstat;
2783 }
2d8e6c8d 2784 sv_setpv(PL_statname, SvPV(sv,n_a));
3280af22 2785 PL_statgv = Nullgv;
a0d0e21e 2786#ifdef HAS_LSTAT
533c011a
NIS		 2787 PL_laststype = PL_op->op_type;
2788 if (PL_op->op_type == OP_LSTAT)
2d8e6c8d 2789 PL_laststatval = PerlLIO_lstat(SvPV(PL_statname, n_a), &PL_statcache);
a0d0e21e
LW		 2790 else
2791#endif
2d8e6c8d 2792 PL_laststatval = PerlLIO_stat(SvPV(PL_statname, n_a), &PL_statcache);
3280af22 2793 if (PL_laststatval < 0) {
2d8e6c8d 2794 if (ckWARN(WARN_NEWLINE) && strchr(SvPV(PL_statname, n_a), '\n'))
9014280d 2795 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
a0d0e21e
LW		 2796 max = 0;
2797 }
2798 }
2799
54310121 2800 gimme = GIMME_V;
2801 if (gimme != G_ARRAY) {
2802 if (gimme != G_VOID)
2803 XPUSHs(boolSV(max));
2804 RETURN;
a0d0e21e
LW		 2805 }
2806 if (max) {
36477c24 2807 EXTEND(SP, max);
2808 EXTEND_MORTAL(max);
1ff81528
PL		 2809 PUSHs(sv_2mortal(newSViv(PL_statcache.st_dev)));
2810 PUSHs(sv_2mortal(newSViv(PL_statcache.st_ino)));
b448e4fe
JH		 2811 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_mode)));
2812 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_nlink)));
146174a9
CB		 2813#if Uid_t_size > IVSIZE
2814 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_uid)));
2815#else
23dcd6c8 2816# if Uid_t_sign <= 0
1ff81528 2817 PUSHs(sv_2mortal(newSViv(PL_statcache.st_uid)));
23dcd6c8
JH		 2818# else
2819 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_uid)));
2820# endif
146174a9 2821#endif
301e8125 2822#if Gid_t_size > IVSIZE
146174a9
CB		 2823 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_gid)));
2824#else
23dcd6c8 2825# if Gid_t_sign <= 0
1ff81528 2826 PUSHs(sv_2mortal(newSViv(PL_statcache.st_gid)));
23dcd6c8
JH		 2827# else
2828 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_gid)));
2829# endif
146174a9 2830#endif
cbdc8872 2831#ifdef USE_STAT_RDEV
1ff81528 2832 PUSHs(sv_2mortal(newSViv(PL_statcache.st_rdev)));
cbdc8872 2833#else
79cb57f6 2834 PUSHs(sv_2mortal(newSVpvn("", 0)));
cbdc8872 2835#endif
146174a9
CB		 2836#if Off_t_size > IVSIZE
2837 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_size)));
2838#else
1ff81528 2839 PUSHs(sv_2mortal(newSViv(PL_statcache.st_size)));
146174a9 2840#endif
cbdc8872 2841#ifdef BIG_TIME
172ae379
JH		 2842 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_atime)));
2843 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_mtime)));
2844 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_ctime)));
cbdc8872 2845#else
1ff81528
PL		 2846 PUSHs(sv_2mortal(newSViv(PL_statcache.st_atime)));
2847 PUSHs(sv_2mortal(newSViv(PL_statcache.st_mtime)));
2848 PUSHs(sv_2mortal(newSViv(PL_statcache.st_ctime)));
cbdc8872 2849#endif
a0d0e21e 2850#ifdef USE_STAT_BLOCKS
b448e4fe
JH		 2851 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blksize)));
2852 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blocks)));
a0d0e21e 2853#else
79cb57f6
GS		 2854 PUSHs(sv_2mortal(newSVpvn("", 0)));
2855 PUSHs(sv_2mortal(newSVpvn("", 0)));
a0d0e21e
LW		 2856#endif
2857 }
2858 RETURN;
2859}
2860
2861PP(pp_ftrread)
2862{
9cad6237 2863 I32 result;
2a3ff820 2864 dSP;
5ff3f7a4 2865#if defined(HAS_ACCESS) && defined(R_OK)
2d8e6c8d 2866 STRLEN n_a;
5ff3f7a4 2867 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2868 result = access(TOPpx, R_OK);
5ff3f7a4
GS		 2869 if (result == 0)
2870 RETPUSHYES;
2871 if (result < 0)
2872 RETPUSHUNDEF;
2873 RETPUSHNO;
22865c03
GS		 2874 }
2875 else
cea2e8a9 2876 result = my_stat();
5ff3f7a4 2877#else
cea2e8a9 2878 result = my_stat();
5ff3f7a4 2879#endif
22865c03 2880 SPAGAIN;
a0d0e21e
LW		 2881 if (result < 0)
2882 RETPUSHUNDEF;
3280af22 2883 if (cando(S_IRUSR, 0, &PL_statcache))
a0d0e21e
LW		 2884 RETPUSHYES;
2885 RETPUSHNO;
2886}
2887
2888PP(pp_ftrwrite)
2889{
9cad6237 2890 I32 result;
2a3ff820 2891 dSP;
5ff3f7a4 2892#if defined(HAS_ACCESS) && defined(W_OK)
2d8e6c8d 2893 STRLEN n_a;
5ff3f7a4 2894 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2895 result = access(TOPpx, W_OK);
5ff3f7a4
GS		 2896 if (result == 0)
2897 RETPUSHYES;
2898 if (result < 0)
2899 RETPUSHUNDEF;
2900 RETPUSHNO;
22865c03
GS		 2901 }
2902 else
cea2e8a9 2903 result = my_stat();
5ff3f7a4 2904#else
cea2e8a9 2905 result = my_stat();
5ff3f7a4 2906#endif
22865c03 2907 SPAGAIN;
a0d0e21e
LW		 2908 if (result < 0)
2909 RETPUSHUNDEF;
3280af22 2910 if (cando(S_IWUSR, 0, &PL_statcache))
a0d0e21e
LW		 2911 RETPUSHYES;
2912 RETPUSHNO;
2913}
2914
2915PP(pp_ftrexec)
2916{
9cad6237 2917 I32 result;
2a3ff820 2918 dSP;
5ff3f7a4 2919#if defined(HAS_ACCESS) && defined(X_OK)
2d8e6c8d 2920 STRLEN n_a;
5ff3f7a4 2921 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2922 result = access(TOPpx, X_OK);
5ff3f7a4
GS		 2923 if (result == 0)
2924 RETPUSHYES;
2925 if (result < 0)
2926 RETPUSHUNDEF;
2927 RETPUSHNO;
22865c03
GS		 2928 }
2929 else
cea2e8a9 2930 result = my_stat();
5ff3f7a4 2931#else
cea2e8a9 2932 result = my_stat();
5ff3f7a4 2933#endif
22865c03 2934 SPAGAIN;
a0d0e21e
LW		 2935 if (result < 0)
2936 RETPUSHUNDEF;
3280af22 2937 if (cando(S_IXUSR, 0, &PL_statcache))
a0d0e21e
LW		 2938 RETPUSHYES;
2939 RETPUSHNO;
2940}
2941
2942PP(pp_fteread)
2943{
9cad6237 2944 I32 result;
2a3ff820 2945 dSP;
5ff3f7a4 2946#ifdef PERL_EFF_ACCESS_R_OK
2d8e6c8d 2947 STRLEN n_a;
5ff3f7a4 2948 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2949 result = PERL_EFF_ACCESS_R_OK(TOPpx);
5ff3f7a4
GS		 2950 if (result == 0)
2951 RETPUSHYES;
2952 if (result < 0)
2953 RETPUSHUNDEF;
2954 RETPUSHNO;
22865c03
GS		 2955 }
2956 else
cea2e8a9 2957 result = my_stat();
5ff3f7a4 2958#else
cea2e8a9 2959 result = my_stat();
5ff3f7a4 2960#endif
22865c03 2961 SPAGAIN;
a0d0e21e
LW		 2962 if (result < 0)
2963 RETPUSHUNDEF;
3280af22 2964 if (cando(S_IRUSR, 1, &PL_statcache))
a0d0e21e
LW		 2965 RETPUSHYES;
2966 RETPUSHNO;
2967}
2968
2969PP(pp_ftewrite)
2970{
9cad6237 2971 I32 result;
2a3ff820 2972 dSP;
5ff3f7a4 2973#ifdef PERL_EFF_ACCESS_W_OK
2d8e6c8d 2974 STRLEN n_a;
5ff3f7a4 2975 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2976 result = PERL_EFF_ACCESS_W_OK(TOPpx);
5ff3f7a4
GS		 2977 if (result == 0)
2978 RETPUSHYES;
2979 if (result < 0)
2980 RETPUSHUNDEF;
2981 RETPUSHNO;
22865c03
GS		 2982 }
2983 else
cea2e8a9 2984 result = my_stat();
5ff3f7a4 2985#else
cea2e8a9 2986 result = my_stat();
5ff3f7a4 2987#endif
22865c03 2988 SPAGAIN;
a0d0e21e
LW		 2989 if (result < 0)
2990 RETPUSHUNDEF;
3280af22 2991 if (cando(S_IWUSR, 1, &PL_statcache))
a0d0e21e
LW		 2992 RETPUSHYES;
2993 RETPUSHNO;
2994}
2995
2996PP(pp_fteexec)
2997{
9cad6237 2998 I32 result;
2a3ff820 2999 dSP;
5ff3f7a4 3000#ifdef PERL_EFF_ACCESS_X_OK
2d8e6c8d 3001 STRLEN n_a;
5ff3f7a4 3002 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 3003 result = PERL_EFF_ACCESS_X_OK(TOPpx);
5ff3f7a4
GS		 3004 if (result == 0)
3005 RETPUSHYES;
3006 if (result < 0)
3007 RETPUSHUNDEF;
3008 RETPUSHNO;
22865c03
GS		 3009 }
3010 else
cea2e8a9 3011 result = my_stat();
5ff3f7a4 3012#else
cea2e8a9 3013 result = my_stat();
5ff3f7a4 3014#endif
22865c03 3015 SPAGAIN;
a0d0e21e
LW		 3016 if (result < 0)
3017 RETPUSHUNDEF;
3280af22 3018 if (cando(S_IXUSR, 1, &PL_statcache))
a0d0e21e
LW		 3019 RETPUSHYES;
3020 RETPUSHNO;
3021}
3022
3023PP(pp_ftis)
3024{
9cad6237 3025 I32 result = my_stat();
2a3ff820 3026 dSP;
a0d0e21e
LW		 3027 if (result < 0)
3028 RETPUSHUNDEF;
3029 RETPUSHYES;
3030}
3031
3032PP(pp_fteowned)
3033{
cea2e8a9 3034 return pp_ftrowned();
a0d0e21e
LW		 3035}
3036
3037PP(pp_ftrowned)
3038{
9cad6237 3039 I32 result = my_stat();
2a3ff820 3040 dSP;
a0d0e21e
LW		 3041 if (result < 0)
3042 RETPUSHUNDEF;
146174a9
CB		 3043 if (PL_statcache.st_uid == (PL_op->op_type == OP_FTEOWNED ?
3044 PL_euid : PL_uid) )
a0d0e21e
LW		 3045 RETPUSHYES;
3046 RETPUSHNO;
3047}
3048
3049PP(pp_ftzero)
3050{
9cad6237 3051 I32 result = my_stat();
2a3ff820 3052 dSP;
a0d0e21e
LW		 3053 if (result < 0)
3054 RETPUSHUNDEF;
146174a9 3055 if (PL_statcache.st_size == 0)
a0d0e21e
LW		 3056 RETPUSHYES;
3057 RETPUSHNO;
3058}
3059
3060PP(pp_ftsize)
3061{
9cad6237 3062 I32 result = my_stat();
2a3ff820 3063 dSP; dTARGET;
a0d0e21e
LW		 3064 if (result < 0)
3065 RETPUSHUNDEF;
146174a9
CB		 3066#if Off_t_size > IVSIZE
3067 PUSHn(PL_statcache.st_size);
3068#else
3280af22 3069 PUSHi(PL_statcache.st_size);
146174a9 3070#endif
a0d0e21e
LW		 3071 RETURN;
3072}
3073
3074PP(pp_ftmtime)
3075{
9cad6237 3076 I32 result = my_stat();
2a3ff820 3077 dSP; dTARGET;
a0d0e21e
LW		 3078 if (result < 0)
3079 RETPUSHUNDEF;
c6419e06 3080 PUSHn( (PL_basetime - PL_statcache.st_mtime) / 86400.0 );
a0d0e21e
LW		 3081 RETURN;
3082}
3083
3084PP(pp_ftatime)
3085{
9cad6237 3086 I32 result = my_stat();
2a3ff820 3087 dSP; dTARGET;
a0d0e21e
LW		 3088 if (result < 0)
3089 RETPUSHUNDEF;
c6419e06 3090 PUSHn( (PL_basetime - PL_statcache.st_atime) / 86400.0 );
a0d0e21e
LW		 3091 RETURN;
3092}
3093
3094PP(pp_ftctime)
3095{
9cad6237 3096 I32 result = my_stat();
2a3ff820 3097 dSP; dTARGET;
a0d0e21e
LW		 3098 if (result < 0)
3099 RETPUSHUNDEF;
c6419e06 3100 PUSHn( (PL_basetime - PL_statcache.st_ctime) / 86400.0 );
a0d0e21e
LW		 3101 RETURN;
3102}
3103
3104PP(pp_ftsock)
3105{
9cad6237 3106 I32 result = my_stat();
2a3ff820 3107 dSP;
a0d0e21e
LW		 3108 if (result < 0)
3109 RETPUSHUNDEF;
3280af22 3110 if (S_ISSOCK(PL_statcache.st_mode))
a0d0e21e
LW		 3111 RETPUSHYES;
3112 RETPUSHNO;
3113}
3114
3115PP(pp_ftchr)
3116{
9cad6237 3117 I32 result = my_stat();
2a3ff820 3118 dSP;
a0d0e21e
LW		 3119 if (result < 0)
3120 RETPUSHUNDEF;
3280af22 3121 if (S_ISCHR(PL_statcache.st_mode))
a0d0e21e
LW		 3122 RETPUSHYES;
3123 RETPUSHNO;
3124}
3125
3126PP(pp_ftblk)
3127{
9cad6237 3128 I32 result = my_stat();
2a3ff820 3129 dSP;
a0d0e21e
LW		 3130 if (result < 0)
3131 RETPUSHUNDEF;
3280af22 3132 if (S_ISBLK(PL_statcache.st_mode))
a0d0e21e
LW		 3133 RETPUSHYES;
3134 RETPUSHNO;
3135}
3136
3137PP(pp_ftfile)
3138{
9cad6237 3139 I32 result = my_stat();
2a3ff820 3140 dSP;
a0d0e21e
LW		 3141 if (result < 0)
3142 RETPUSHUNDEF;
3280af22 3143 if (S_ISREG(PL_statcache.st_mode))
a0d0e21e
LW		 3144 RETPUSHYES;
3145 RETPUSHNO;
3146}
3147
3148PP(pp_ftdir)
3149{
9cad6237 3150 I32 result = my_stat();
2a3ff820 3151 dSP;
a0d0e21e
LW		 3152 if (result < 0)
3153 RETPUSHUNDEF;
3280af22 3154 if (S_ISDIR(PL_statcache.st_mode))
a0d0e21e
LW		 3155 RETPUSHYES;
3156 RETPUSHNO;
3157}
3158
3159PP(pp_ftpipe)
3160{
9cad6237 3161 I32 result = my_stat();
2a3ff820 3162 dSP;
a0d0e21e
LW		 3163 if (result < 0)
3164 RETPUSHUNDEF;
3280af22 3165 if (S_ISFIFO(PL_statcache.st_mode))
a0d0e21e
LW		 3166 RETPUSHYES;
3167 RETPUSHNO;
3168}
3169
3170PP(pp_ftlink)
3171{
9cad6237 3172 I32 result = my_lstat();
2a3ff820 3173 dSP;
a0d0e21e
LW		 3174 if (result < 0)
3175 RETPUSHUNDEF;
3280af22 3176 if (S_ISLNK(PL_statcache.st_mode))
a0d0e21e
LW		 3177 RETPUSHYES;
3178 RETPUSHNO;
3179}
3180
3181PP(pp_ftsuid)
3182{
39644a26 3183 dSP;
a0d0e21e 3184#ifdef S_ISUID
cea2e8a9 3185 I32 result = my_stat();
a0d0e21e
LW		 3186 SPAGAIN;
3187 if (result < 0)
3188 RETPUSHUNDEF;
3280af22 3189 if (PL_statcache.st_mode & S_ISUID)
a0d0e21e
LW		 3190 RETPUSHYES;
3191#endif
3192 RETPUSHNO;
3193}
3194
3195PP(pp_ftsgid)
3196{
39644a26 3197 dSP;
a0d0e21e 3198#ifdef S_ISGID
cea2e8a9 3199 I32 result = my_stat();
a0d0e21e
LW		 3200 SPAGAIN;
3201 if (result < 0)
3202 RETPUSHUNDEF;
3280af22 3203 if (PL_statcache.st_mode & S_ISGID)
a0d0e21e
LW		 3204 RETPUSHYES;
3205#endif
3206 RETPUSHNO;
3207}
3208
3209PP(pp_ftsvtx)
3210{
39644a26 3211 dSP;
a0d0e21e 3212#ifdef S_ISVTX
cea2e8a9 3213 I32 result = my_stat();
a0d0e21e
LW		 3214 SPAGAIN;
3215 if (result < 0)
3216 RETPUSHUNDEF;
3280af22 3217 if (PL_statcache.st_mode & S_ISVTX)
a0d0e21e
LW		 3218 RETPUSHYES;
3219#endif
3220 RETPUSHNO;
3221}
3222
3223PP(pp_fttty)
3224{
39644a26 3225 dSP;
a0d0e21e
LW		 3226 int fd;
3227 GV *gv;
fb73857a 3228 char *tmps = Nullch;
2d8e6c8d 3229 STRLEN n_a;
fb73857a 3230
533c011a 3231 if (PL_op->op_flags & OPf_REF)
146174a9 3232 gv = cGVOP_gv;
fb73857a 3233 else if (isGV(TOPs))
3234 gv = (GV*)POPs;
3235 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3236 gv = (GV*)SvRV(POPs);
a0d0e21e 3237 else
2d8e6c8d 3238 gv = gv_fetchpv(tmps = POPpx, FALSE, SVt_PVIO);
fb73857a 3239
a0d0e21e 3240 if (GvIO(gv) && IoIFP(GvIOp(gv)))
760ac839 3241 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
fb73857a 3242 else if (tmps && isDIGIT(*tmps))
a0d0e21e
LW		 3243 fd = atoi(tmps);
3244 else
3245 RETPUSHUNDEF;
6ad3d225 3246 if (PerlLIO_isatty(fd))
a0d0e21e
LW		 3247 RETPUSHYES;
3248 RETPUSHNO;
3249}
3250
16d20bd9
AD		 3251#if defined(atarist) /* this will work with atariST. Configure will
3252 make guesses for other systems. */
3253# define FILE_base(f) ((f)->_base)
3254# define FILE_ptr(f) ((f)->_ptr)
3255# define FILE_cnt(f) ((f)->_cnt)
3256# define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
a0d0e21e
LW		 3257#endif
3258
3259PP(pp_fttext)
3260{
39644a26 3261 dSP;
a0d0e21e
LW		 3262 I32 i;
3263 I32 len;
3264 I32 odd = 0;
3265 STDCHAR tbuf[512];
3266 register STDCHAR *s;
3267 register IO *io;
5f05dabc 3268 register SV *sv;
3269 GV *gv;
2d8e6c8d 3270 STRLEN n_a;
146174a9 3271 PerlIO *fp;
a0d0e21e 3272
533c011a 3273 if (PL_op->op_flags & OPf_REF)
146174a9 3274 gv = cGVOP_gv;
5f05dabc 3275 else if (isGV(TOPs))
3276 gv = (GV*)POPs;
3277 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3278 gv = (GV*)SvRV(POPs);
3279 else
3280 gv = Nullgv;
3281
3282 if (gv) {
a0d0e21e 3283 EXTEND(SP, 1);
3280af22
NIS		 3284 if (gv == PL_defgv) {
3285 if (PL_statgv)
3286 io = GvIO(PL_statgv);
a0d0e21e 3287 else {
3280af22 3288 sv = PL_statname;
a0d0e21e
LW		 3289 goto really_filename;
3290 }
3291 }
3292 else {
3280af22
NIS		 3293 PL_statgv = gv;
3294 PL_laststatval = -1;
3295 sv_setpv(PL_statname, "");
3296 io = GvIO(PL_statgv);
a0d0e21e
LW		 3297 }
3298 if (io && IoIFP(io)) {
5f05dabc 3299 if (! PerlIO_has_base(IoIFP(io)))
cea2e8a9 3300 DIE(aTHX_ "-T and -B not implemented on filehandles");
3280af22
NIS		 3301 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3302 if (PL_laststatval < 0)
5f05dabc 3303 RETPUSHUNDEF;
9cbac4c7 3304 if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
533c011a 3305 if (PL_op->op_type == OP_FTTEXT)
a0d0e21e
LW		 3306 RETPUSHNO;
3307 else
3308 RETPUSHYES;
9cbac4c7 3309 }
a20bf0c3 3310 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
760ac839 3311 i = PerlIO_getc(IoIFP(io));
a0d0e21e 3312 if (i != EOF)
760ac839 3313 (void)PerlIO_ungetc(IoIFP(io),i);
a0d0e21e 3314 }
a20bf0c3 3315 if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
a0d0e21e 3316 RETPUSHYES;
a20bf0c3
JH		 3317 len = PerlIO_get_bufsiz(IoIFP(io));
3318 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
760ac839
LW		 3319 /* sfio can have large buffers - limit to 512 */
3320 if (len > 512)
3321 len = 512;
a0d0e21e
LW		 3322 }
3323 else {
2dd78f96 3324 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
146174a9 3325 gv = cGVOP_gv;
2dd78f96 3326 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
146174a9 3327 }
91487cfc 3328 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW		 3329 RETPUSHUNDEF;
3330 }
3331 }
3332 else {
3333 sv = POPs;
5f05dabc 3334 really_filename:
3280af22
NIS		 3335 PL_statgv = Nullgv;
3336 PL_laststatval = -1;
5c9aa243 3337 PL_laststype = OP_STAT;
2d8e6c8d 3338 sv_setpv(PL_statname, SvPV(sv, n_a));
146174a9 3339 if (!(fp = PerlIO_open(SvPVX(PL_statname), "r"))) {
2d8e6c8d 3340 if (ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, n_a), '\n'))
9014280d 3341 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
a0d0e21e
LW		 3342 RETPUSHUNDEF;
3343 }
146174a9
CB		 3344 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3345 if (PL_laststatval < 0) {
3346 (void)PerlIO_close(fp);
5f05dabc 3347 RETPUSHUNDEF;
146174a9 3348 }
60382766 3349 PerlIO_binmode(aTHX_ fp, '<', O_BINARY, Nullch);
146174a9
CB		 3350 len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3351 (void)PerlIO_close(fp);
a0d0e21e 3352 if (len <= 0) {
533c011a 3353 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
a0d0e21e
LW		 3354 RETPUSHNO; /* special case NFS directories */
3355 RETPUSHYES; /* null file is anything */
3356 }
3357 s = tbuf;
3358 }
3359
3360 /* now scan s to look for textiness */
4633a7c4 3361 /* XXX ASCII dependent code */
a0d0e21e 3362
146174a9
CB		 3363#if defined(DOSISH) || defined(USEMYBINMODE)
3364 /* ignore trailing ^Z on short files */
3365 if (len && len < sizeof(tbuf) && tbuf[len-1] == 26)
3366 --len;
3367#endif
3368
a0d0e21e
LW		 3369 for (i = 0; i < len; i++, s++) {
3370 if (!*s) { /* null never allowed in text */
3371 odd += len;
3372 break;
3373 }
9d116dd7 3374#ifdef EBCDIC
301e8125 3375 else if (!(isPRINT(*s) || isSPACE(*s)))
9d116dd7
JH		 3376 odd++;
3377#else
146174a9
CB		 3378 else if (*s & 128) {
3379#ifdef USE_LOCALE
2de3dbcc 3380 if (IN_LOCALE_RUNTIME && isALPHA_LC(*s))
b3f66c68
GS		 3381 continue;
3382#endif
3383 /* utf8 characters don't count as odd */
fd400ab9 3384 if (UTF8_IS_START(*s)) {
b3f66c68
GS		 3385 int ulen = UTF8SKIP(s);
3386 if (ulen < len - i) {
3387 int j;
3388 for (j = 1; j < ulen; j++) {
fd400ab9 3389 if (!UTF8_IS_CONTINUATION(s[j]))
b3f66c68
GS		 3390 goto not_utf8;
3391 }
3392 --ulen; /* loop does extra increment */
3393 s += ulen;
3394 i += ulen;
3395 continue;
3396 }
3397 }
3398 not_utf8:
3399 odd++;
146174a9 3400 }
a0d0e21e
LW		 3401 else if (*s < 32 &&
3402 *s != '\n' && *s != '\r' && *s != '\b' &&
3403 *s != '\t' && *s != '\f' && *s != 27)
3404 odd++;
9d116dd7 3405#endif
a0d0e21e
LW		 3406 }
3407
533c011a 3408 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
a0d0e21e
LW		 3409 RETPUSHNO;
3410 else
3411 RETPUSHYES;
3412}
3413
3414PP(pp_ftbinary)
3415{
cea2e8a9 3416 return pp_fttext();
a0d0e21e
LW		 3417}
3418
3419/* File calls. */
3420
3421PP(pp_chdir)
3422{
39644a26 3423 dSP; dTARGET;
a0d0e21e
LW		 3424 char *tmps;
3425 SV **svp;
2d8e6c8d 3426 STRLEN n_a;
a0d0e21e 3427
35ae6b54
MS		 3428 if( MAXARG == 1 )
3429 tmps = POPpx;
3430 else
3431 tmps = 0;
3432
3433 if( !tmps || !*tmps ) {
3434 if ( (svp = hv_fetch(GvHVn(PL_envgv), "HOME", 4, FALSE))
3435 || (svp = hv_fetch(GvHVn(PL_envgv), "LOGDIR", 6, FALSE))
491527d0 3436#ifdef VMS
35ae6b54 3437 || (svp = hv_fetch(GvHVn(PL_envgv), "SYS$LOGIN", 9, FALSE))
491527d0 3438#endif
35ae6b54
MS		 3439 )
3440 {
3441 if( MAXARG == 1 )
9014280d 3442 deprecate("chdir('') or chdir(undef) as chdir()");
35ae6b54
MS		 3443 tmps = SvPV(*svp, n_a);
3444 }
72f496dc 3445 else {
389ec635 3446 PUSHi(0);
b7ab37f8 3447 TAINT_PROPER("chdir");
389ec635
MS		 3448 RETURN;
3449 }
8ea155d1 3450 }
8ea155d1 3451
a0d0e21e 3452 TAINT_PROPER("chdir");
6ad3d225 3453 PUSHi( PerlDir_chdir(tmps) >= 0 );
748a9306
LW		 3454#ifdef VMS
3455 /* Clear the DEFAULT element of ENV so we'll get the new value
3456 * in the future. */
6b88bc9c 3457 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
748a9306 3458#endif
a0d0e21e
LW		 3459 RETURN;
3460}
3461
3462PP(pp_chown)
3463{
a0d0e21e 3464#ifdef HAS_CHOWN
76ffd3b9
IZ		 3465 dSP; dMARK; dTARGET;
3466 I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3467
a0d0e21e
LW		 3468 SP = MARK;
3469 PUSHi(value);
3470 RETURN;
3471#else
0322a713 3472 DIE(aTHX_ PL_no_func, "chown");
a0d0e21e
LW		 3473#endif
3474}
3475
3476PP(pp_chroot)
3477{
a0d0e21e 3478#ifdef HAS_CHROOT
76ffd3b9 3479 dSP; dTARGET;
2d8e6c8d 3480 STRLEN n_a;
d05c1ba0 3481 char *tmps = POPpx;
a0d0e21e
LW		 3482 TAINT_PROPER("chroot");
3483 PUSHi( chroot(tmps) >= 0 );
3484 RETURN;
3485#else
cea2e8a9 3486 DIE(aTHX_ PL_no_func, "chroot");
a0d0e21e
LW		 3487#endif
3488}
3489
3490PP(pp_unlink)
3491{
39644a26 3492 dSP; dMARK; dTARGET;
a0d0e21e 3493 I32 value;
533c011a 3494 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 3495 SP = MARK;
3496 PUSHi(value);
3497 RETURN;
3498}
3499
3500PP(pp_chmod)
3501{
39644a26 3502 dSP; dMARK; dTARGET;
a0d0e21e 3503 I32 value;
533c011a 3504 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 3505 SP = MARK;
3506 PUSHi(value);
3507 RETURN;
3508}
3509
3510PP(pp_utime)
3511{
39644a26 3512 dSP; dMARK; dTARGET;
a0d0e21e 3513 I32 value;
533c011a 3514 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 3515 SP = MARK;
3516 PUSHi(value);
3517 RETURN;
3518}
3519
3520PP(pp_rename)
3521{
39644a26 3522 dSP; dTARGET;
a0d0e21e 3523 int anum;
2d8e6c8d 3524 STRLEN n_a;
a0d0e21e 3525
2d8e6c8d
GS		 3526 char *tmps2 = POPpx;
3527 char *tmps = SvPV(TOPs, n_a);
a0d0e21e
LW		 3528 TAINT_PROPER("rename");
3529#ifdef HAS_RENAME
baed7233 3530 anum = PerlLIO_rename(tmps, tmps2);
a0d0e21e 3531#else
6b88bc9c 3532 if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
ed969818
W		 3533 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3534 anum = 1;
3535 else {
3654eb6c 3536 if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
ed969818
W		 3537 (void)UNLINK(tmps2);
3538 if (!(anum = link(tmps, tmps2)))
3539 anum = UNLINK(tmps);
3540 }
a0d0e21e
LW		 3541 }
3542#endif
3543 SETi( anum >= 0 );
3544 RETURN;
3545}
3546
3547PP(pp_link)
3548{
a0d0e21e 3549#ifdef HAS_LINK
370f6000 3550 dSP; dTARGET;
2d8e6c8d
GS		 3551 STRLEN n_a;
3552 char *tmps2 = POPpx;
3553 char *tmps = SvPV(TOPs, n_a);
a0d0e21e 3554 TAINT_PROPER("link");
146174a9 3555 SETi( PerlLIO_link(tmps, tmps2) >= 0 );
65850d11 3556 RETURN;
a0d0e21e 3557#else
0322a713 3558 DIE(aTHX_ PL_no_func, "link");
a0d0e21e 3559#endif
a0d0e21e
LW		 3560}
3561
3562PP(pp_symlink)
3563{
a0d0e21e 3564#ifdef HAS_SYMLINK
9cad6237 3565 dSP; dTARGET;
2d8e6c8d
GS		 3566 STRLEN n_a;
3567 char *tmps2 = POPpx;
3568 char *tmps = SvPV(TOPs, n_a);
a0d0e21e
LW		 3569 TAINT_PROPER("symlink");
3570 SETi( symlink(tmps, tmps2) >= 0 );
3571 RETURN;
3572#else
cea2e8a9 3573 DIE(aTHX_ PL_no_func, "symlink");
a0d0e21e
LW		 3574#endif
3575}
3576
3577PP(pp_readlink)
3578{
76ffd3b9 3579 dSP;
a0d0e21e 3580#ifdef HAS_SYMLINK
76ffd3b9 3581 dTARGET;
a0d0e21e 3582 char *tmps;
46fc3d4c 3583 char buf[MAXPATHLEN];
a0d0e21e 3584 int len;
2d8e6c8d 3585 STRLEN n_a;
46fc3d4c 3586
fb73857a 3587#ifndef INCOMPLETE_TAINTS
3588 TAINT;
3589#endif
2d8e6c8d 3590 tmps = POPpx;
97dcea33 3591 len = readlink(tmps, buf, sizeof(buf) - 1);
a0d0e21e
LW		 3592 EXTEND(SP, 1);
3593 if (len < 0)
3594 RETPUSHUNDEF;
3595 PUSHp(buf, len);
3596 RETURN;
3597#else
3598 EXTEND(SP, 1);
3599 RETSETUNDEF; /* just pretend it's a normal file */
3600#endif
3601}
3602
3603#if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
ba106d47 3604STATIC int
cea2e8a9 3605S_dooneliner(pTHX_ char *cmd, char *filename)
a0d0e21e 3606{
1e422769 3607 char *save_filename = filename;
3608 char *cmdline;
3609 char *s;
760ac839 3610 PerlIO *myfp;
1e422769 3611 int anum = 1;
a0d0e21e 3612
1e422769 3613 New(666, cmdline, strlen(cmd) + (strlen(filename) * 2) + 10, char);
3614 strcpy(cmdline, cmd);
3615 strcat(cmdline, " ");
3616 for (s = cmdline + strlen(cmdline); *filename; ) {
a0d0e21e
LW		 3617 *s++ = '\\';
3618 *s++ = *filename++;
3619 }
3620 strcpy(s, " 2>&1");
6ad3d225 3621 myfp = PerlProc_popen(cmdline, "r");
1e422769 3622 Safefree(cmdline);
3623
a0d0e21e 3624 if (myfp) {
1e422769 3625 SV *tmpsv = sv_newmortal();
6b88bc9c 3626 /* Need to save/restore 'PL_rs' ?? */
760ac839 3627 s = sv_gets(tmpsv, myfp, 0);
6ad3d225 3628 (void)PerlProc_pclose(myfp);
a0d0e21e 3629 if (s != Nullch) {
1e422769 3630 int e;
3631 for (e = 1;
a0d0e21e 3632#ifdef HAS_SYS_ERRLIST
1e422769 3633 e <= sys_nerr
3634#endif
3635 ; e++)
3636 {
3637 /* you don't see this */
3638 char *errmsg =
3639#ifdef HAS_SYS_ERRLIST
3640 sys_errlist[e]
a0d0e21e 3641#else
1e422769 3642 strerror(e)
a0d0e21e 3643#endif
1e422769 3644 ;
3645 if (!errmsg)
3646 break;
3647 if (instr(s, errmsg)) {
3648 SETERRNO(e,0);
3649 return 0;
3650 }
a0d0e21e 3651 }
748a9306 3652 SETERRNO(0,0);
a0d0e21e
LW		 3653#ifndef EACCES
3654#define EACCES EPERM
3655#endif
1e422769 3656 if (instr(s, "cannot make"))
748a9306 3657 SETERRNO(EEXIST,RMS$_FEX);
1e422769 3658 else if (instr(s, "existing file"))
748a9306 3659 SETERRNO(EEXIST,RMS$_FEX);
1e422769 3660 else if (instr(s, "ile exists"))
748a9306 3661 SETERRNO(EEXIST,RMS$_FEX);
1e422769 3662 else if (instr(s, "non-exist"))
748a9306 3663 SETERRNO(ENOENT,RMS$_FNF);
1e422769 3664 else if (instr(s, "does not exist"))
748a9306 3665 SETERRNO(ENOENT,RMS$_FNF);
1e422769 3666 else if (instr(s, "not empty"))
748a9306 3667 SETERRNO(EBUSY,SS$_DEVOFFLINE);
1e422769 3668 else if (instr(s, "cannot access"))
748a9306 3669 SETERRNO(EACCES,RMS$_PRV);
a0d0e21e 3670 else
748a9306 3671 SETERRNO(EPERM,RMS$_PRV);
a0d0e21e
LW		 3672 return 0;
3673 }
3674 else { /* some mkdirs return no failure indication */
6b88bc9c 3675 anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
911d147d 3676 if (PL_op->op_type == OP_RMDIR)
a0d0e21e
LW		 3677 anum = !anum;
3678 if (anum)
748a9306 3679 SETERRNO(0,0);
a0d0e21e 3680 else
748a9306 3681 SETERRNO(EACCES,RMS$_PRV); /* a guess */
a0d0e21e
LW		 3682 }
3683 return anum;
3684 }
3685 else
3686 return 0;
3687}
3688#endif
3689
3690PP(pp_mkdir)
3691{
39644a26 3692 dSP; dTARGET;
5a211162 3693 int mode;
a0d0e21e
LW		 3694#ifndef HAS_MKDIR
3695 int oldumask;
3696#endif
df25ddba 3697 STRLEN len;
5a211162 3698 char *tmps;
df25ddba 3699 bool copy = FALSE;
5a211162
GS		 3700
3701 if (MAXARG > 1)
3702 mode = POPi;
3703 else
3704 mode = 0777;
3705
df25ddba
JH		 3706 tmps = SvPV(TOPs, len);
3707 /* Different operating and file systems take differently to
16ac3975
JH		 3708 * trailing slashes. According to POSIX 1003.1 1996 Edition
3709 * any number of trailing slashes should be allowed.
3710 * Thusly we snip them away so that even non-conforming
3711 * systems are happy. */
3712 /* We should probably do this "filtering" for all
3713 * the functions that expect (potentially) directory names:
3714 * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3715 * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3716 if (len > 1 && tmps[len-1] == '/') {
3717 while (tmps[len] == '/' && len > 1)
3718 len--;
3719 tmps = savepvn(tmps, len);
df25ddba
JH		 3720 copy = TRUE;
3721 }
a0d0e21e
LW		 3722
3723 TAINT_PROPER("mkdir");
3724#ifdef HAS_MKDIR
6ad3d225 3725 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
a0d0e21e
LW		 3726#else
3727 SETi( dooneliner("mkdir", tmps) );
6ad3d225
GS		 3728 oldumask = PerlLIO_umask(0);
3729 PerlLIO_umask(oldumask);
3730 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
a0d0e21e 3731#endif
df25ddba
JH		 3732 if (copy)
3733 Safefree(tmps);
a0d0e21e
LW		 3734 RETURN;
3735}
3736
3737PP(pp_rmdir)
3738{
39644a26 3739 dSP; dTARGET;
a0d0e21e 3740 char *tmps;
2d8e6c8d 3741 STRLEN n_a;
a0d0e21e 3742
2d8e6c8d 3743 tmps = POPpx;
a0d0e21e
LW		 3744 TAINT_PROPER("rmdir");
3745#ifdef HAS_RMDIR
6ad3d225 3746 XPUSHi( PerlDir_rmdir(tmps) >= 0 );
a0d0e21e
LW		 3747#else
3748 XPUSHi( dooneliner("rmdir", tmps) );
3749#endif
3750 RETURN;
3751}
3752
3753/* Directory calls. */
3754
3755PP(pp_open_dir)
3756{
a0d0e21e 3757#if defined(Direntry_t) && defined(HAS_READDIR)
9cad6237 3758 dSP;
2d8e6c8d
GS		 3759 STRLEN n_a;
3760 char *dirname = POPpx;
1e2c6ed7
JH		 3761 GV *gv = (GV*)POPs;
3762 register IO *io = GvIOn(gv);
a0d0e21e
LW		 3763
3764 if (!io)
3765 goto nope;
3766
3767 if (IoDIRP(io))
6ad3d225
GS		 3768 PerlDir_close(IoDIRP(io));
3769 if (!(IoDIRP(io) = PerlDir_open(dirname)))
a0d0e21e
LW		 3770 goto nope;
3771
3772 RETPUSHYES;
3773nope:
3774 if (!errno)
91487cfc 3775 SETERRNO(EBADF,RMS$_DIR);
a0d0e21e
LW		 3776 RETPUSHUNDEF;
3777#else
cea2e8a9 3778 DIE(aTHX_ PL_no_dir_func, "opendir");
a0d0e21e
LW		 3779#endif
3780}
3781
3782PP(pp_readdir)
3783{
a0d0e21e 3784#if defined(Direntry_t) && defined(HAS_READDIR)
9cad6237 3785 dSP;
fd8cd3a3 3786#if !defined(I_DIRENT) && !defined(VMS)
20ce7b12 3787 Direntry_t *readdir (DIR *);
a0d0e21e
LW		 3788#endif
3789 register Direntry_t *dp;
3790 GV *gv = (GV*)POPs;
3791 register IO *io = GvIOn(gv);
fb73857a 3792 SV *sv;
a0d0e21e
LW		 3793
3794 if (!io || !IoDIRP(io))
3795 goto nope;
3796
3797 if (GIMME == G_ARRAY) {
3798 /*SUPPRESS 560*/
155aba94 3799 while ((dp = (Direntry_t *)PerlDir_read(IoDIRP(io)))) {
a0d0e21e 3800#ifdef DIRNAMLEN
79cb57f6 3801 sv = newSVpvn(dp->d_name, dp->d_namlen);
a0d0e21e 3802#else
fb73857a 3803 sv = newSVpv(dp->d_name, 0);
3804#endif
3805#ifndef INCOMPLETE_TAINTS
26fb8f1f
GS		 3806 if (!(IoFLAGS(io) & IOf_UNTAINT))
3807 SvTAINTED_on(sv);
a0d0e21e 3808#endif
fb73857a 3809 XPUSHs(sv_2mortal(sv));
a0d0e21e
LW		 3810 }
3811 }
3812 else {
6ad3d225 3813 if (!(dp = (Direntry_t *)PerlDir_read(IoDIRP(io))))
a0d0e21e
LW		 3814 goto nope;
3815#ifdef DIRNAMLEN
79cb57f6 3816 sv = newSVpvn(dp->d_name, dp->d_namlen);
a0d0e21e 3817#else
fb73857a 3818 sv = newSVpv(dp->d_name, 0);
a0d0e21e 3819#endif
fb73857a 3820#ifndef INCOMPLETE_TAINTS
26fb8f1f
GS		 3821 if (!(IoFLAGS(io) & IOf_UNTAINT))
3822 SvTAINTED_on(sv);
fb73857a 3823#endif
3824 XPUSHs(sv_2mortal(sv));
a0d0e21e
LW		 3825 }
3826 RETURN;
3827
3828nope:
3829 if (!errno)
91487cfc 3830 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 3831 if (GIMME == G_ARRAY)
3832 RETURN;
3833 else
3834 RETPUSHUNDEF;
3835#else
cea2e8a9 3836 DIE(aTHX_ PL_no_dir_func, "readdir");
a0d0e21e
LW		 3837#endif
3838}
3839
3840PP(pp_telldir)
3841{
a0d0e21e 3842#if defined(HAS_TELLDIR) || defined(telldir)
9cad6237 3843 dSP; dTARGET;
968dcd91
JH		 3844 /* XXX does _anyone_ need this? --AD 2/20/1998 */
3845 /* XXX netbsd still seemed to.
3846 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3847 --JHI 1999-Feb-02 */
3848# if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
20ce7b12 3849 long telldir (DIR *);
dfe9444c 3850# endif
a0d0e21e
LW		 3851 GV *gv = (GV*)POPs;
3852 register IO *io = GvIOn(gv);
3853
3854 if (!io || !IoDIRP(io))
3855 goto nope;
3856
6ad3d225 3857 PUSHi( PerlDir_tell(IoDIRP(io)) );
a0d0e21e
LW		 3858 RETURN;
3859nope:
3860 if (!errno)
91487cfc 3861 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 3862 RETPUSHUNDEF;
3863#else
cea2e8a9 3864 DIE(aTHX_ PL_no_dir_func, "telldir");
a0d0e21e
LW		 3865#endif
3866}
3867
3868PP(pp_seekdir)
3869{
a0d0e21e 3870#if defined(HAS_SEEKDIR) || defined(seekdir)
9cad6237 3871 dSP;
a0d0e21e
LW		 3872 long along = POPl;
3873 GV *gv = (GV*)POPs;
3874 register IO *io = GvIOn(gv);
3875
3876 if (!io || !IoDIRP(io))
3877 goto nope;
3878
6ad3d225 3879 (void)PerlDir_seek(IoDIRP(io), along);
a0d0e21e
LW		 3880
3881 RETPUSHYES;
3882nope:
3883 if (!errno)
91487cfc 3884 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 3885 RETPUSHUNDEF;
3886#else
cea2e8a9 3887 DIE(aTHX_ PL_no_dir_func, "seekdir");
a0d0e21e
LW		 3888#endif
3889}
3890
3891PP(pp_rewinddir)
3892{
a0d0e21e 3893#if defined(HAS_REWINDDIR) || defined(rewinddir)
9cad6237 3894 dSP;
a0d0e21e
LW		 3895 GV *gv = (GV*)POPs;
3896 register IO *io = GvIOn(gv);
3897
3898 if (!io || !IoDIRP(io))
3899 goto nope;
3900
6ad3d225 3901 (void)PerlDir_rewind(IoDIRP(io));
a0d0e21e
LW		 3902 RETPUSHYES;
3903nope:
3904 if (!errno)
91487cfc 3905 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 3906 RETPUSHUNDEF;
3907#else
cea2e8a9 3908 DIE(aTHX_ PL_no_dir_func, "rewinddir");
a0d0e21e
LW		 3909#endif
3910}
3911
3912PP(pp_closedir)
3913{
a0d0e21e 3914#if defined(Direntry_t) && defined(HAS_READDIR)
9cad6237 3915 dSP;
a0d0e21e
LW		 3916 GV *gv = (GV*)POPs;
3917 register IO *io = GvIOn(gv);
3918
3919 if (!io || !IoDIRP(io))
3920 goto nope;
3921
3922#ifdef VOID_CLOSEDIR
6ad3d225 3923 PerlDir_close(IoDIRP(io));
a0d0e21e 3924#else
6ad3d225 3925 if (PerlDir_close(IoDIRP(io)) < 0) {
748a9306 3926 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
a0d0e21e 3927 goto nope;
748a9306 3928 }
a0d0e21e
LW		 3929#endif
3930 IoDIRP(io) = 0;
3931
3932 RETPUSHYES;
3933nope:
3934 if (!errno)
91487cfc 3935 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW		 3936 RETPUSHUNDEF;
3937#else
cea2e8a9 3938 DIE(aTHX_ PL_no_dir_func, "closedir");
a0d0e21e
LW		 3939#endif
3940}
3941
3942/* Process control. */
3943
3944PP(pp_fork)
3945{
44a8e56a 3946#ifdef HAS_FORK
39644a26 3947 dSP; dTARGET;
761237fe 3948 Pid_t childpid;
a0d0e21e
LW		 3949 GV *tmpgv;
3950
3951 EXTEND(SP, 1);
45bc9206 3952 PERL_FLUSHALL_FOR_CHILD;
52e18b1f 3953 childpid = PerlProc_fork();
a0d0e21e
LW		 3954 if (childpid < 0)
3955 RETSETUNDEF;
3956 if (!childpid) {
3957 /*SUPPRESS 560*/
306196c3
MS		 3958 if ((tmpgv = gv_fetchpv("$", TRUE, SVt_PV))) {
3959 SvREADONLY_off(GvSV(tmpgv));
146174a9 3960 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
306196c3
MS		 3961 SvREADONLY_on(GvSV(tmpgv));
3962 }
3280af22 3963 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
a0d0e21e
LW		 3964 }
3965 PUSHi(childpid);
3966 RETURN;
3967#else
146174a9 3968# if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
39644a26 3969 dSP; dTARGET;
146174a9
CB		 3970 Pid_t childpid;
3971
3972 EXTEND(SP, 1);
3973 PERL_FLUSHALL_FOR_CHILD;
3974 childpid = PerlProc_fork();
60fa28ff
GS		 3975 if (childpid == -1)
3976 RETSETUNDEF;
146174a9
CB		 3977 PUSHi(childpid);
3978 RETURN;
3979# else
0322a713 3980 DIE(aTHX_ PL_no_func, "fork");
146174a9 3981# endif
a0d0e21e
LW		 3982#endif
3983}
3984
3985PP(pp_wait)
3986{
301e8125 3987#if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
39644a26 3988 dSP; dTARGET;
761237fe 3989 Pid_t childpid;
a0d0e21e 3990 int argflags;
a0d0e21e 3991
0a0ada86 3992#ifdef PERL_OLD_SIGNALS
44a8e56a 3993 childpid = wait4pid(-1, &argflags, 0);
0a0ada86
NIS		 3994#else
3995 while ((childpid = wait4pid(-1, &argflags, 0)) == -1 && errno == EINTR) {
3996 PERL_ASYNC_CHECK();
3997 }
3998#endif
68a29c53
GS		 3999# if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4000 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4001 STATUS_NATIVE_SET((childpid && childpid != -1) ? argflags : -1);
4002# else
f86702cc 4003 STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
68a29c53 4004# endif
44a8e56a 4005 XPUSHi(childpid);
a0d0e21e
LW		 4006 RETURN;
4007#else
0322a713 4008 DIE(aTHX_ PL_no_func, "wait");
a0d0e21e
LW		 4009#endif
4010}
4011
4012PP(pp_waitpid)
4013{
301e8125 4014#if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
39644a26 4015 dSP; dTARGET;
761237fe 4016 Pid_t childpid;
a0d0e21e
LW		 4017 int optype;
4018 int argflags;
a0d0e21e 4019
a0d0e21e
LW		 4020 optype = POPi;
4021 childpid = TOPi;
0a0ada86 4022#ifdef PERL_OLD_SIGNALS
a0d0e21e 4023 childpid = wait4pid(childpid, &argflags, optype);
0a0ada86
NIS		 4024#else
4025 while ((childpid = wait4pid(childpid, &argflags, optype)) == -1 && errno == EINTR) {
4026 PERL_ASYNC_CHECK();
4027 }
4028#endif
68a29c53
GS		 4029# if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4030 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4031 STATUS_NATIVE_SET((childpid && childpid != -1) ? argflags : -1);
4032# else
f86702cc 4033 STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
68a29c53 4034# endif
44a8e56a 4035 SETi(childpid);
a0d0e21e
LW		 4036 RETURN;
4037#else
0322a713 4038 DIE(aTHX_ PL_no_func, "waitpid");
a0d0e21e
LW		 4039#endif
4040}
4041
4042PP(pp_system)
4043{
39644a26 4044 dSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e 4045 I32 value;
2d8e6c8d 4046 STRLEN n_a;
76ffd3b9 4047 int result;
e7766f89 4048 I32 did_pipes = 0;
a0d0e21e 4049
bbd7eb8a 4050 if (PL_tainting) {
159f47d9 4051 int some_arg_tainted = 0;
bbd7eb8a
RD		 4052 TAINT_ENV();
4053 while (++MARK <= SP) {
4054 (void)SvPV_nolen(*MARK); /* stringify for taint check */
159f47d9
RGS		 4055 if (PL_tainted) {
4056 some_arg_tainted = 1;
bbd7eb8a 4057 break;
159f47d9 4058 }
bbd7eb8a
RD		 4059 }
4060 MARK = ORIGMARK;
4061 /* XXX Remove warning at end of deprecation cycle --RD 2002-02 */
4062 if (SP - MARK == 1) {
a0d0e21e
LW		 4063 TAINT_PROPER("system");
4064 }
159f47d9 4065 else if (some_arg_tainted && ckWARN2(WARN_TAINT, WARN_DEPRECATED)) {
12bcd1a6 4066 Perl_warner(aTHX_ packWARN2(WARN_TAINT, WARN_DEPRECATED),
bbd7eb8a
RD		 4067 "Use of tainted arguments in %s is deprecated", "system");
4068 }
a0d0e21e 4069 }
45bc9206 4070 PERL_FLUSHALL_FOR_CHILD;
273b0206 4071#if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
d7e492a4 4072 {
eb160463
GS		 4073 Pid_t childpid;
4074 int pp[2];
4075
4076 if (PerlProc_pipe(pp) >= 0)
4077 did_pipes = 1;
4078 while ((childpid = PerlProc_fork()) == -1) {
4079 if (errno != EAGAIN) {
4080 value = -1;
4081 SP = ORIGMARK;
4082 PUSHi(value);
4083 if (did_pipes) {
4084 PerlLIO_close(pp[0]);
4085 PerlLIO_close(pp[1]);
4086 }
4087 RETURN;
4088 }
4089 sleep(5);
4090 }
4091 if (childpid > 0) {
4092 Sigsave_t ihand,qhand; /* place to save signals during system() */
4093 int status;
4094
4095 if (did_pipes)
4096 PerlLIO_close(pp[1]);
64ca3a65 4097#ifndef PERL_MICRO
eb160463
GS		 4098 rsignal_save(SIGINT, SIG_IGN, &ihand);
4099 rsignal_save(SIGQUIT, SIG_IGN, &qhand);
64ca3a65 4100#endif
eb160463
GS		 4101 do {
4102 result = wait4pid(childpid, &status, 0);
4103 } while (result == -1 && errno == EINTR);
64ca3a65 4104#ifndef PERL_MICRO
eb160463
GS		 4105 (void)rsignal_restore(SIGINT, &ihand);
4106 (void)rsignal_restore(SIGQUIT, &qhand);
4107#endif
4108 STATUS_NATIVE_SET(result == -1 ? -1 : status);
4109 do_execfree(); /* free any memory child malloced on fork */
4110 SP = ORIGMARK;
4111 if (did_pipes) {
4112 int errkid;
4113 int n = 0, n1;
4114
4115 while (n < sizeof(int)) {
4116 n1 = PerlLIO_read(pp[0],
4117 (void*)(((char*)&errkid)+n),
4118 (sizeof(int)) - n);
4119 if (n1 <= 0)
4120 break;
4121 n += n1;
4122 }
4123 PerlLIO_close(pp[0]);
4124 if (n) { /* Error */
4125 if (n != sizeof(int))
4126 DIE(aTHX_ "panic: kid popen errno read");
4127 errno = errkid; /* Propagate errno from kid */
4128 STATUS_CURRENT = -1;
4129 }
4130 }
4131 PUSHi(STATUS_CURRENT);
4132 RETURN;
4133 }
4134 if (did_pipes) {
4135 PerlLIO_close(pp[0]);
d5a9bfb0 4136#if defined(HAS_FCNTL) && defined(F_SETFD)
eb160463 4137 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
d5a9bfb0 4138#endif
eb160463 4139 }
e0a1f643
JH		 4140 if (PL_op->op_flags & OPf_STACKED) {
4141 SV *really = *++MARK;
4142 value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4143 }
4144 else if (SP - MARK != 1)
4145 value = (I32)do_aexec5(Nullsv, MARK, SP, pp[1], did_pipes);
4146 else {
4147 value = (I32)do_exec3(SvPVx(sv_mortalcopy(*SP), n_a), pp[1], did_pipes);
4148 }
4149 PerlProc__exit(-1);
d5a9bfb0 4150 }
c3293030 4151#else /* ! FORK or VMS or OS/2 */
922b1888
GS		 4152 PL_statusvalue = 0;
4153 result = 0;
911d147d 4154 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e 4155 SV *really = *++MARK;
54725af6
GS		 4156# ifdef WIN32
4157 value = (I32)do_aspawn(really, MARK, SP);
4158# else
c5be433b 4159 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
54725af6 4160# endif
a0d0e21e 4161 }
54725af6
GS		 4162 else if (SP - MARK != 1) {
4163# ifdef WIN32
4164 value = (I32)do_aspawn(Nullsv, MARK, SP);
4165# else
c5be433b 4166 value = (I32)do_aspawn(Nullsv, (void **)MARK, (void **)SP);
54725af6
GS		 4167# endif
4168 }
a0d0e21e 4169 else {
c5be433b 4170 value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
a0d0e21e 4171 }
922b1888
GS		 4172 if (PL_statusvalue == -1) /* hint that value must be returned as is */
4173 result = 1;
f86702cc 4174 STATUS_NATIVE_SET(value);
a0d0e21e
LW		 4175 do_execfree();
4176 SP = ORIGMARK;
922b1888 4177 PUSHi(result ? value : STATUS_CURRENT);
a0d0e21e
LW		 4178#endif /* !FORK or VMS */
4179 RETURN;
4180}
4181
4182PP(pp_exec)
4183{
39644a26 4184 dSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e 4185 I32 value;
2d8e6c8d 4186 STRLEN n_a;
a0d0e21e 4187
bbd7eb8a 4188 if (PL_tainting) {
159f47d9 4189 int some_arg_tainted = 0;
bbd7eb8a
RD		 4190 TAINT_ENV();
4191 while (++MARK <= SP) {
4192 (void)SvPV_nolen(*MARK); /* stringify for taint check */
159f47d9
RGS		 4193 if (PL_tainted) {
4194 some_arg_tainted = 1;
bbd7eb8a 4195 break;
159f47d9 4196 }
bbd7eb8a
RD		 4197 }
4198 MARK = ORIGMARK;
4199 /* XXX Remove warning at end of deprecation cycle --RD 2002-02 */
4200 if (SP - MARK == 1) {
4201 TAINT_PROPER("exec");
4202 }
159f47d9 4203 else if (some_arg_tainted && ckWARN2(WARN_TAINT, WARN_DEPRECATED)) {
12bcd1a6 4204 Perl_warner(aTHX_ packWARN2(WARN_TAINT, WARN_DEPRECATED),
bbd7eb8a
RD		 4205 "Use of tainted arguments in %s is deprecated", "exec");
4206 }
4207 }
45bc9206 4208 PERL_FLUSHALL_FOR_CHILD;
533c011a 4209 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e
LW		 4210 SV *really = *++MARK;
4211 value = (I32)do_aexec(really, MARK, SP);
4212 }
4213 else if (SP - MARK != 1)
4214#ifdef VMS
4215 value = (I32)vms_do_aexec(Nullsv, MARK, SP);
4216#else
092bebab
JH		 4217# ifdef __OPEN_VM
4218 {
c5be433b 4219 (void ) do_aspawn(Nullsv, MARK, SP);
092bebab
JH		 4220 value = 0;
4221 }
4222# else
a0d0e21e 4223 value = (I32)do_aexec(Nullsv, MARK, SP);
092bebab 4224# endif
a0d0e21e
LW		 4225#endif
4226 else {
a0d0e21e 4227#ifdef VMS
2d8e6c8d 4228 value = (I32)vms_do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
a0d0e21e 4229#else
092bebab 4230# ifdef __OPEN_VM
c5be433b 4231 (void) do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
092bebab
JH		 4232 value = 0;
4233# else
2d8e6c8d 4234 value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
092bebab 4235# endif
a0d0e21e
LW		 4236#endif
4237 }
146174a9 4238
a0d0e21e
LW		 4239 SP = ORIGMARK;
4240 PUSHi(value);
4241 RETURN;
4242}
4243
4244PP(pp_kill)
4245{
9cad6237 4246#ifdef HAS_KILL
39644a26 4247 dSP; dMARK; dTARGET;
a0d0e21e 4248 I32 value;
533c011a 4249 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 4250 SP = MARK;
4251 PUSHi(value);
4252 RETURN;
4253#else
0322a713 4254 DIE(aTHX_ PL_no_func, "kill");
a0d0e21e
LW		 4255#endif
4256}
4257
4258PP(pp_getppid)
4259{
4260#ifdef HAS_GETPPID
39644a26 4261 dSP; dTARGET;
a0d0e21e
LW		 4262 XPUSHi( getppid() );
4263 RETURN;
4264#else
cea2e8a9 4265 DIE(aTHX_ PL_no_func, "getppid");
a0d0e21e
LW		 4266#endif
4267}
4268
4269PP(pp_getpgrp)
4270{
4271#ifdef HAS_GETPGRP
39644a26 4272 dSP; dTARGET;
d8a83dd3 4273 Pid_t pid;
9853a804 4274 Pid_t pgrp;
a0d0e21e
LW		 4275
4276 if (MAXARG < 1)
4277 pid = 0;
4278 else
4279 pid = SvIVx(POPs);
c3293030 4280#ifdef BSD_GETPGRP
9853a804 4281 pgrp = (I32)BSD_GETPGRP(pid);
a0d0e21e 4282#else
146174a9 4283 if (pid != 0 && pid != PerlProc_getpid())
cea2e8a9 4284 DIE(aTHX_ "POSIX getpgrp can't take an argument");
9853a804 4285 pgrp = getpgrp();
a0d0e21e 4286#endif
9853a804 4287 XPUSHi(pgrp);
a0d0e21e
LW		 4288 RETURN;
4289#else
cea2e8a9 4290 DIE(aTHX_ PL_no_func, "getpgrp()");
a0d0e21e
LW		 4291#endif
4292}
4293
4294PP(pp_setpgrp)
4295{
4296#ifdef HAS_SETPGRP
39644a26 4297 dSP; dTARGET;
d8a83dd3
JH		 4298 Pid_t pgrp;
4299 Pid_t pid;
a0d0e21e
LW		 4300 if (MAXARG < 2) {
4301 pgrp = 0;
4302 pid = 0;
4303 }
4304 else {
4305 pgrp = POPi;
4306 pid = TOPi;
4307 }
4308
4309 TAINT_PROPER("setpgrp");
c3293030
IZ		 4310#ifdef BSD_SETPGRP
4311 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
a0d0e21e 4312#else
146174a9
CB		 4313 if ((pgrp != 0 && pgrp != PerlProc_getpid())
4314 || (pid != 0 && pid != PerlProc_getpid()))
4315 {
4316 DIE(aTHX_ "setpgrp can't take arguments");
4317 }
a0d0e21e
LW		 4318 SETi( setpgrp() >= 0 );
4319#endif /* USE_BSDPGRP */
4320 RETURN;
4321#else
cea2e8a9 4322 DIE(aTHX_ PL_no_func, "setpgrp()");
a0d0e21e
LW		 4323#endif
4324}
4325
4326PP(pp_getpriority)
4327{
a0d0e21e 4328#ifdef HAS_GETPRIORITY
9cad6237 4329 dSP; dTARGET;
d05c1ba0
JH		 4330 int who = POPi;
4331 int which = TOPi;
a0d0e21e
LW		 4332 SETi( getpriority(which, who) );
4333 RETURN;
4334#else
cea2e8a9 4335 DIE(aTHX_ PL_no_func, "getpriority()");
a0d0e21e
LW		 4336#endif
4337}
4338
4339PP(pp_setpriority)
4340{
a0d0e21e 4341#ifdef HAS_SETPRIORITY
9cad6237 4342 dSP; dTARGET;
d05c1ba0
JH		 4343 int niceval = POPi;
4344 int who = POPi;
4345 int which = TOPi;
a0d0e21e
LW		 4346 TAINT_PROPER("setpriority");
4347 SETi( setpriority(which, who, niceval) >= 0 );
4348 RETURN;
4349#else
cea2e8a9 4350 DIE(aTHX_ PL_no_func, "setpriority()");
a0d0e21e
LW		 4351#endif
4352}
4353
4354/* Time calls. */
4355
4356PP(pp_time)
4357{
39644a26 4358 dSP; dTARGET;
cbdc8872 4359#ifdef BIG_TIME
4360 XPUSHn( time(Null(Time_t*)) );
4361#else
a0d0e21e 4362 XPUSHi( time(Null(Time_t*)) );
cbdc8872 4363#endif
a0d0e21e
LW		 4364 RETURN;
4365}
4366
cd52b7b2 4367/* XXX The POSIX name is CLK_TCK; it is to be preferred
4368 to HZ. Probably. For now, assume that if the system
4369 defines HZ, it does so correctly. (Will this break
4370 on VMS?)
4371 Probably we ought to use _sysconf(_SC_CLK_TCK), if
4372 it's supported. --AD 9/96.
4373*/
4374
9bc87460
JH		 4375#ifdef __BEOS__
4376# define HZ 1000000
4377#endif
4378
a0d0e21e 4379#ifndef HZ
cd52b7b2 4380# ifdef CLK_TCK
4381# define HZ CLK_TCK
4382# else
4383# define HZ 60
4384# endif
a0d0e21e
LW		 4385#endif
4386
4387PP(pp_tms)
4388{
9cad6237 4389#ifdef HAS_TIMES
39644a26 4390 dSP;
a0d0e21e 4391 EXTEND(SP, 4);
a0d0e21e 4392#ifndef VMS
3280af22 4393 (void)PerlProc_times(&PL_timesbuf);
a0d0e21e 4394#else
6b88bc9c 4395 (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */
76e3520e
GS		 4396 /* struct tms, though same data */
4397 /* is returned. */
a0d0e21e
LW		 4398#endif
4399
65202027 4400 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_utime)/HZ)));
a0d0e21e 4401 if (GIMME == G_ARRAY) {
65202027
DS		 4402 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_stime)/HZ)));
4403 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cutime)/HZ)));
4404 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cstime)/HZ)));
a0d0e21e
LW		 4405 }
4406 RETURN;
9cad6237
JH		 4407#else
4408 DIE(aTHX_ "times not implemented");
55497cff 4409#endif /* HAS_TIMES */
a0d0e21e
LW		 4410}
4411
4412PP(pp_localtime)
4413{
cea2e8a9 4414 return pp_gmtime();
a0d0e21e
LW		 4415}
4416
4417PP(pp_gmtime)
4418{
39644a26 4419 dSP;
a0d0e21e
LW		 4420 Time_t when;
4421 struct tm *tmbuf;
4422 static char *dayname[] = {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4423 static char *monname[] = {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4424 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4425
4426 if (MAXARG < 1)
4427 (void)time(&when);
4428 else
cbdc8872 4429#ifdef BIG_TIME
4430 when = (Time_t)SvNVx(POPs);
4431#else
a0d0e21e 4432 when = (Time_t)SvIVx(POPs);
cbdc8872 4433#endif
a0d0e21e 4434
533c011a 4435 if (PL_op->op_type == OP_LOCALTIME)
a0d0e21e
LW		 4436 tmbuf = localtime(&when);
4437 else
4438 tmbuf = gmtime(&when);
4439
a0d0e21e 4440 if (GIMME != G_ARRAY) {
46fc3d4c 4441 SV *tsv;
9a5ff6d9
AB		 4442 EXTEND(SP, 1);
4443 EXTEND_MORTAL(1);
a0d0e21e
LW		 4444 if (!tmbuf)
4445 RETPUSHUNDEF;
be28567c 4446 tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %d",
f5a29b03
RB		 4447 dayname[tmbuf->tm_wday],
4448 monname[tmbuf->tm_mon],
be28567c
GS		 4449 tmbuf->tm_mday,
4450 tmbuf->tm_hour,
4451 tmbuf->tm_min,
4452 tmbuf->tm_sec,
4453 tmbuf->tm_year + 1900);
46fc3d4c 4454 PUSHs(sv_2mortal(tsv));
a0d0e21e
LW		 4455 }
4456 else if (tmbuf) {
9a5ff6d9
AB		 4457 EXTEND(SP, 9);
4458 EXTEND_MORTAL(9);
4459 PUSHs(sv_2mortal(newSViv(tmbuf->tm_sec)));
c6419e06
JH		 4460 PUSHs(sv_2mortal(newSViv(tmbuf->tm_min)));
4461 PUSHs(sv_2mortal(newSViv(tmbuf->tm_hour)));
4462 PUSHs(sv_2mortal(newSViv(tmbuf->tm_mday)));
4463 PUSHs(sv_2mortal(newSViv(tmbuf->tm_mon)));
4464 PUSHs(sv_2mortal(newSViv(tmbuf->tm_year)));
4465 PUSHs(sv_2mortal(newSViv(tmbuf->tm_wday)));
4466 PUSHs(sv_2mortal(newSViv(tmbuf->tm_yday)));
4467 PUSHs(sv_2mortal(newSViv(tmbuf->tm_isdst)));
a0d0e21e
LW		 4468 }
4469 RETURN;
4470}
4471
4472PP(pp_alarm)
4473{
9cad6237 4474#ifdef HAS_ALARM
39644a26 4475 dSP; dTARGET;
a0d0e21e 4476 int anum;
a0d0e21e
LW		 4477 anum = POPi;
4478 anum = alarm((unsigned int)anum);
4479 EXTEND(SP, 1);
4480 if (anum < 0)
4481 RETPUSHUNDEF;
c6419e06 4482 PUSHi(anum);
a0d0e21e
LW		 4483 RETURN;
4484#else
0322a713 4485 DIE(aTHX_ PL_no_func, "alarm");
a0d0e21e
LW		 4486#endif
4487}
4488
4489PP(pp_sleep)
4490{
39644a26 4491 dSP; dTARGET;
a0d0e21e
LW		 4492 I32 duration;
4493 Time_t lasttime;
4494 Time_t when;
4495
4496 (void)time(&lasttime);
4497 if (MAXARG < 1)
76e3520e 4498 PerlProc_pause();
a0d0e21e
LW		 4499 else {
4500 duration = POPi;
76e3520e 4501 PerlProc_sleep((unsigned int)duration);
a0d0e21e
LW		 4502 }
4503 (void)time(&when);
4504 XPUSHi(when - lasttime);
4505 RETURN;
4506}
4507
4508/* Shared memory. */
4509
4510PP(pp_shmget)
4511{
cea2e8a9 4512 return pp_semget();
a0d0e21e
LW		 4513}
4514
4515PP(pp_shmctl)
4516{
cea2e8a9 4517 return pp_semctl();
a0d0e21e
LW		 4518}
4519
4520PP(pp_shmread)
4521{
cea2e8a9 4522 return pp_shmwrite();
a0d0e21e
LW		 4523}
4524
4525PP(pp_shmwrite)
4526{
4527#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
39644a26 4528 dSP; dMARK; dTARGET;
533c011a 4529 I32 value = (I32)(do_shmio(PL_op->op_type, MARK, SP) >= 0);
a0d0e21e
LW		 4530 SP = MARK;
4531 PUSHi(value);
4532 RETURN;
4533#else
cea2e8a9 4534 return pp_semget();
a0d0e21e
LW		 4535#endif
4536}
4537
4538/* Message passing. */
4539
4540PP(pp_msgget)
4541{
cea2e8a9 4542 return pp_semget();
a0d0e21e
LW		 4543}
4544
4545PP(pp_msgctl)
4546{
cea2e8a9 4547 return pp_semctl();
a0d0e21e
LW		 4548}
4549
4550PP(pp_msgsnd)
4551{
4552#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
39644a26 4553 dSP; dMARK; dTARGET;
a0d0e21e
LW		 4554 I32 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4555 SP = MARK;
4556 PUSHi(value);
4557 RETURN;
4558#else
cea2e8a9 4559 return pp_semget();
a0d0e21e
LW		 4560#endif
4561}
4562
4563PP(pp_msgrcv)
4564{
4565#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
39644a26 4566 dSP; dMARK; dTARGET;
a0d0e21e
LW		 4567 I32 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4568 SP = MARK;
4569 PUSHi(value);
4570 RETURN;
4571#else
cea2e8a9 4572 return pp_semget();
a0d0e21e
LW		 4573#endif
4574}
4575
4576/* Semaphores. */
4577
4578PP(pp_semget)
4579{
4580#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
39644a26 4581 dSP; dMARK; dTARGET;
533c011a 4582 int anum = do_ipcget(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 4583 SP = MARK;
4584 if (anum == -1)
4585 RETPUSHUNDEF;
4586 PUSHi(anum);
4587 RETURN;
4588#else
cea2e8a9 4589 DIE(aTHX_ "System V IPC is not implemented on this machine");
a0d0e21e
LW		 4590#endif
4591}
4592
4593PP(pp_semctl)
4594{
4595#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
39644a26 4596 dSP; dMARK; dTARGET;
533c011a 4597 int anum = do_ipcctl(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 4598 SP = MARK;
4599 if (anum == -1)
4600 RETSETUNDEF;
4601 if (anum != 0) {
4602 PUSHi(anum);
4603 }
4604 else {
8903cb82 4605 PUSHp(zero_but_true, ZBTLEN);
a0d0e21e
LW		 4606 }
4607 RETURN;
4608#else
cea2e8a9 4609 return pp_semget();
a0d0e21e
LW		 4610#endif
4611}
4612
4613PP(pp_semop)
4614{
4615#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
39644a26 4616 dSP; dMARK; dTARGET;
a0d0e21e
LW		 4617 I32 value = (I32)(do_semop(MARK, SP) >= 0);
4618 SP = MARK;
4619 PUSHi(value);
4620 RETURN;
4621#else
cea2e8a9 4622 return pp_semget();
a0d0e21e
LW		 4623#endif
4624}
4625
4626/* Get system info. */
4627
4628PP(pp_ghbyname)
4629{
693762b4 4630#ifdef HAS_GETHOSTBYNAME
cea2e8a9 4631 return pp_ghostent();
a0d0e21e 4632#else
cea2e8a9 4633 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
a0d0e21e
LW		 4634#endif
4635}
4636
4637PP(pp_ghbyaddr)
4638{
693762b4 4639#ifdef HAS_GETHOSTBYADDR
cea2e8a9 4640 return pp_ghostent();
a0d0e21e 4641#else
cea2e8a9 4642 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
a0d0e21e
LW		 4643#endif
4644}
4645
4646PP(pp_ghostent)
4647{
693762b4 4648#if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
9cad6237 4649 dSP;
533c011a 4650 I32 which = PL_op->op_type;
a0d0e21e
LW		 4651 register char **elem;
4652 register SV *sv;
dc45a647 4653#ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
1d88b533
JH		 4654 struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4655 struct hostent *gethostbyname(Netdb_name_t);
4656 struct hostent *gethostent(void);
a0d0e21e
LW		 4657#endif
4658 struct hostent *hent;
4659 unsigned long len;
2d8e6c8d 4660 STRLEN n_a;
a0d0e21e
LW		 4661
4662 EXTEND(SP, 10);
edd309b7 4663 if (which == OP_GHBYNAME) {
dc45a647 4664#ifdef HAS_GETHOSTBYNAME
edd309b7
JH		 4665 char* name = POPpbytex;
4666 hent = PerlSock_gethostbyname(name);
dc45a647 4667#else
cea2e8a9 4668 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
dc45a647 4669#endif
edd309b7 4670 }
a0d0e21e 4671 else if (which == OP_GHBYADDR) {
dc45a647 4672#ifdef HAS_GETHOSTBYADDR
a0d0e21e 4673 int addrtype = POPi;
748a9306 4674 SV *addrsv = POPs;
a0d0e21e 4675 STRLEN addrlen;
595ae481 4676 Netdb_host_t addr = (Netdb_host_t) SvPVbyte(addrsv, addrlen);
a0d0e21e 4677
4599a1de 4678 hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
dc45a647 4679#else
cea2e8a9 4680 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
dc45a647 4681#endif
a0d0e21e
LW		 4682 }
4683 else
4684#ifdef HAS_GETHOSTENT
6ad3d225 4685 hent = PerlSock_gethostent();
a0d0e21e 4686#else
cea2e8a9 4687 DIE(aTHX_ PL_no_sock_func, "gethostent");
a0d0e21e
LW		 4688#endif
4689
4690#ifdef HOST_NOT_FOUND
10bc17b6
JH		 4691 if (!hent) {
4692#ifdef USE_REENTRANT_API
4693# ifdef USE_GETHOSTENT_ERRNO
4694 h_errno = PL_reentrant_buffer->_gethostent_errno;
4695# endif
4696#endif
4697 STATUS_NATIVE_SET(h_errno);
4698 }
a0d0e21e
LW		 4699#endif
4700
4701 if (GIMME != G_ARRAY) {
4702 PUSHs(sv = sv_newmortal());
4703 if (hent) {
4704 if (which == OP_GHBYNAME) {
fd0af264 4705 if (hent->h_addr)
4706 sv_setpvn(sv, hent->h_addr, hent->h_length);
a0d0e21e
LW		 4707 }
4708 else
4709 sv_setpv(sv, (char*)hent->h_name);
4710 }
4711 RETURN;
4712 }
4713
4714 if (hent) {
3280af22 4715 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4716 sv_setpv(sv, (char*)hent->h_name);
3280af22 4717 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 4718 for (elem = hent->h_aliases; elem && *elem; elem++) {
4719 sv_catpv(sv, *elem);
4720 if (elem[1])
4721 sv_catpvn(sv, " ", 1);
4722 }
3280af22 4723 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4724 sv_setiv(sv, (IV)hent->h_addrtype);
3280af22 4725 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4726 len = hent->h_length;
1e422769 4727 sv_setiv(sv, (IV)len);
a0d0e21e
LW		 4728#ifdef h_addr
4729 for (elem = hent->h_addr_list; elem && *elem; elem++) {
3280af22 4730 XPUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 4731 sv_setpvn(sv, *elem, len);
4732 }
4733#else
6b88bc9c 4734 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
fd0af264 4735 if (hent->h_addr)
4736 sv_setpvn(sv, hent->h_addr, len);
a0d0e21e
LW		 4737#endif /* h_addr */
4738 }
4739 RETURN;
4740#else
cea2e8a9 4741 DIE(aTHX_ PL_no_sock_func, "gethostent");
a0d0e21e
LW		 4742#endif
4743}
4744
4745PP(pp_gnbyname)
4746{
693762b4 4747#ifdef HAS_GETNETBYNAME
cea2e8a9 4748 return pp_gnetent();
a0d0e21e 4749#else
cea2e8a9 4750 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
a0d0e21e
LW		 4751#endif
4752}
4753
4754PP(pp_gnbyaddr)
4755{
693762b4 4756#ifdef HAS_GETNETBYADDR
cea2e8a9 4757 return pp_gnetent();
a0d0e21e 4758#else
cea2e8a9 4759 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
a0d0e21e
LW		 4760#endif
4761}
4762
4763PP(pp_gnetent)
4764{
693762b4 4765#if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
9cad6237 4766 dSP;
533c011a 4767 I32 which = PL_op->op_type;
a0d0e21e
LW		 4768 register char **elem;
4769 register SV *sv;
dc45a647 4770#ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
1d88b533
JH		 4771 struct netent *getnetbyaddr(Netdb_net_t, int);
4772 struct netent *getnetbyname(Netdb_name_t);
4773 struct netent *getnetent(void);
8ac85365 4774#endif
a0d0e21e 4775 struct netent *nent;
2d8e6c8d 4776 STRLEN n_a;
a0d0e21e 4777
edd309b7 4778 if (which == OP_GNBYNAME){
dc45a647 4779#ifdef HAS_GETNETBYNAME
edd309b7
JH		 4780 char *name = POPpbytex;
4781 nent = PerlSock_getnetbyname(name);
dc45a647 4782#else
cea2e8a9 4783 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
dc45a647 4784#endif
edd309b7 4785 }
a0d0e21e 4786 else if (which == OP_GNBYADDR) {
dc45a647 4787#ifdef HAS_GETNETBYADDR
a0d0e21e 4788 int addrtype = POPi;
3bb7c1b4 4789 Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
76e3520e 4790 nent = PerlSock_getnetbyaddr(addr, addrtype);
dc45a647 4791#else
cea2e8a9 4792 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
dc45a647 4793#endif
a0d0e21e
LW		 4794 }
4795 else
dc45a647 4796#ifdef HAS_GETNETENT
76e3520e 4797 nent = PerlSock_getnetent();
dc45a647 4798#else
cea2e8a9 4799 DIE(aTHX_ PL_no_sock_func, "getnetent");
dc45a647 4800#endif
a0d0e21e 4801
10bc17b6
JH		 4802#ifdef HOST_NOT_FOUND
4803 if (!nent) {
4804#ifdef USE_REENTRANT_API
4805# ifdef USE_GETNETENT_ERRNO
4806 h_errno = PL_reentrant_buffer->_getnetent_errno;
4807# endif
4808#endif
4809 STATUS_NATIVE_SET(h_errno);
4810 }
4811#endif
4812
a0d0e21e
LW		 4813 EXTEND(SP, 4);
4814 if (GIMME != G_ARRAY) {
4815 PUSHs(sv = sv_newmortal());
4816 if (nent) {
4817 if (which == OP_GNBYNAME)
1e422769 4818 sv_setiv(sv, (IV)nent->n_net);
a0d0e21e
LW		 4819 else
4820 sv_setpv(sv, nent->n_name);
4821 }
4822 RETURN;
4823 }
4824
4825 if (nent) {
3280af22 4826 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4827 sv_setpv(sv, nent->n_name);
3280af22 4828 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 4829 for (elem = nent->n_aliases; elem && *elem; elem++) {
a0d0e21e
LW		 4830 sv_catpv(sv, *elem);
4831 if (elem[1])
4832 sv_catpvn(sv, " ", 1);
4833 }
3280af22 4834 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4835 sv_setiv(sv, (IV)nent->n_addrtype);
3280af22 4836 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4837 sv_setiv(sv, (IV)nent->n_net);
a0d0e21e
LW		 4838 }
4839
4840 RETURN;
4841#else
cea2e8a9 4842 DIE(aTHX_ PL_no_sock_func, "getnetent");
a0d0e21e
LW		 4843#endif
4844}
4845
4846PP(pp_gpbyname)
4847{
693762b4 4848#ifdef HAS_GETPROTOBYNAME
cea2e8a9 4849 return pp_gprotoent();
a0d0e21e 4850#else
cea2e8a9 4851 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
a0d0e21e
LW		 4852#endif
4853}
4854
4855PP(pp_gpbynumber)
4856{
693762b4 4857#ifdef HAS_GETPROTOBYNUMBER
cea2e8a9 4858 return pp_gprotoent();
a0d0e21e 4859#else
cea2e8a9 4860 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
a0d0e21e
LW		 4861#endif
4862}
4863
4864PP(pp_gprotoent)
4865{
693762b4 4866#if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
9cad6237 4867 dSP;
533c011a 4868 I32 which = PL_op->op_type;
a0d0e21e 4869 register char **elem;
301e8125 4870 register SV *sv;
dc45a647 4871#ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
1d88b533
JH		 4872 struct protoent *getprotobyname(Netdb_name_t);
4873 struct protoent *getprotobynumber(int);
4874 struct protoent *getprotoent(void);
8ac85365 4875#endif
a0d0e21e 4876 struct protoent *pent;
2d8e6c8d 4877 STRLEN n_a;
a0d0e21e 4878
edd309b7 4879 if (which == OP_GPBYNAME) {
e5c9fcd0 4880#ifdef HAS_GETPROTOBYNAME
edd309b7
JH		 4881 char* name = POPpbytex;
4882 pent = PerlSock_getprotobyname(name);
e5c9fcd0 4883#else
cea2e8a9 4884 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
e5c9fcd0 4885#endif
edd309b7
JH		 4886 }
4887 else if (which == OP_GPBYNUMBER) {
e5c9fcd0 4888#ifdef HAS_GETPROTOBYNUMBER
edd309b7
JH		 4889 int number = POPi;
4890 pent = PerlSock_getprotobynumber(number);
e5c9fcd0 4891#else
edd309b7 4892 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
e5c9fcd0 4893#endif
edd309b7 4894 }
a0d0e21e 4895 else
e5c9fcd0 4896#ifdef HAS_GETPROTOENT
6ad3d225 4897 pent = PerlSock_getprotoent();
e5c9fcd0 4898#else
cea2e8a9 4899 DIE(aTHX_ PL_no_sock_func, "getprotoent");
e5c9fcd0 4900#endif
a0d0e21e
LW		 4901
4902 EXTEND(SP, 3);
4903 if (GIMME != G_ARRAY) {
4904 PUSHs(sv = sv_newmortal());
4905 if (pent) {
4906 if (which == OP_GPBYNAME)
1e422769 4907 sv_setiv(sv, (IV)pent->p_proto);
a0d0e21e
LW		 4908 else
4909 sv_setpv(sv, pent->p_name);
4910 }
4911 RETURN;
4912 }
4913
4914 if (pent) {
3280af22 4915 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4916 sv_setpv(sv, pent->p_name);
3280af22 4917 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 4918 for (elem = pent->p_aliases; elem && *elem; elem++) {
a0d0e21e
LW		 4919 sv_catpv(sv, *elem);
4920 if (elem[1])
4921 sv_catpvn(sv, " ", 1);
4922 }
3280af22 4923 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4924 sv_setiv(sv, (IV)pent->p_proto);
a0d0e21e
LW		 4925 }
4926
4927 RETURN;
4928#else
cea2e8a9 4929 DIE(aTHX_ PL_no_sock_func, "getprotoent");
a0d0e21e
LW		 4930#endif
4931}
4932
4933PP(pp_gsbyname)
4934{
9ec75305 4935#ifdef HAS_GETSERVBYNAME
cea2e8a9 4936 return pp_gservent();
a0d0e21e 4937#else
cea2e8a9 4938 DIE(aTHX_ PL_no_sock_func, "getservbyname");
a0d0e21e
LW		 4939#endif
4940}
4941
4942PP(pp_gsbyport)
4943{
9ec75305 4944#ifdef HAS_GETSERVBYPORT
cea2e8a9 4945 return pp_gservent();
a0d0e21e 4946#else
cea2e8a9 4947 DIE(aTHX_ PL_no_sock_func, "getservbyport");
a0d0e21e
LW		 4948#endif
4949}
4950
4951PP(pp_gservent)
4952{
693762b4 4953#if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
9cad6237 4954 dSP;
533c011a 4955 I32 which = PL_op->op_type;
a0d0e21e
LW		 4956 register char **elem;
4957 register SV *sv;
dc45a647 4958#ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
1d88b533
JH		 4959 struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
4960 struct servent *getservbyport(int, Netdb_name_t);
4961 struct servent *getservent(void);
8ac85365 4962#endif
a0d0e21e 4963 struct servent *sent;
2d8e6c8d 4964 STRLEN n_a;
a0d0e21e
LW		 4965
4966 if (which == OP_GSBYNAME) {
dc45a647 4967#ifdef HAS_GETSERVBYNAME
42e0c139
AP		 4968 char *proto = POPpbytex;
4969 char *name = POPpbytex;
a0d0e21e
LW		 4970
4971 if (proto && !*proto)
4972 proto = Nullch;
4973
6ad3d225 4974 sent = PerlSock_getservbyname(name, proto);
dc45a647 4975#else
cea2e8a9 4976 DIE(aTHX_ PL_no_sock_func, "getservbyname");
dc45a647 4977#endif
a0d0e21e
LW		 4978 }
4979 else if (which == OP_GSBYPORT) {
dc45a647 4980#ifdef HAS_GETSERVBYPORT
42e0c139 4981 char *proto = POPpbytex;
eb160463 4982 unsigned short port = (unsigned short)POPu;
a0d0e21e 4983
36477c24 4984#ifdef HAS_HTONS
6ad3d225 4985 port = PerlSock_htons(port);
36477c24 4986#endif
6ad3d225 4987 sent = PerlSock_getservbyport(port, proto);
dc45a647 4988#else
cea2e8a9 4989 DIE(aTHX_ PL_no_sock_func, "getservbyport");
dc45a647 4990#endif
a0d0e21e
LW		 4991 }
4992 else
e5c9fcd0 4993#ifdef HAS_GETSERVENT
6ad3d225 4994 sent = PerlSock_getservent();
e5c9fcd0 4995#else
cea2e8a9 4996 DIE(aTHX_ PL_no_sock_func, "getservent");
e5c9fcd0 4997#endif
a0d0e21e
LW		 4998
4999 EXTEND(SP, 4);
5000 if (GIMME != G_ARRAY) {
5001 PUSHs(sv = sv_newmortal());
5002 if (sent) {
5003 if (which == OP_GSBYNAME) {
5004#ifdef HAS_NTOHS
6ad3d225 5005 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
a0d0e21e 5006#else
1e422769 5007 sv_setiv(sv, (IV)(sent->s_port));
a0d0e21e
LW		 5008#endif
5009 }
5010 else
5011 sv_setpv(sv, sent->s_name);
5012 }
5013 RETURN;
5014 }
5015
5016 if (sent) {
3280af22 5017 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 5018 sv_setpv(sv, sent->s_name);
3280af22 5019 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 5020 for (elem = sent->s_aliases; elem && *elem; elem++) {
a0d0e21e
LW		 5021 sv_catpv(sv, *elem);
5022 if (elem[1])
5023 sv_catpvn(sv, " ", 1);
5024 }
3280af22 5025 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 5026#ifdef HAS_NTOHS
76e3520e 5027 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
a0d0e21e 5028#else
1e422769 5029 sv_setiv(sv, (IV)(sent->s_port));
a0d0e21e 5030#endif
3280af22 5031 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 5032 sv_setpv(sv, sent->s_proto);
5033 }
5034
5035 RETURN;
5036#else
cea2e8a9 5037 DIE(aTHX_ PL_no_sock_func, "getservent");
a0d0e21e
LW		 5038#endif
5039}
5040
5041PP(pp_shostent)
5042{
693762b4 5043#ifdef HAS_SETHOSTENT
9cad6237 5044 dSP;
76e3520e 5045 PerlSock_sethostent(TOPi);
a0d0e21e
LW		 5046 RETSETYES;
5047#else
cea2e8a9 5048 DIE(aTHX_ PL_no_sock_func, "sethostent");
a0d0e21e
LW		 5049#endif
5050}
5051
5052PP(pp_snetent)
5053{
693762b4 5054#ifdef HAS_SETNETENT
9cad6237 5055 dSP;
76e3520e 5056 PerlSock_setnetent(TOPi);
a0d0e21e
LW		 5057 RETSETYES;
5058#else
cea2e8a9 5059 DIE(aTHX_ PL_no_sock_func, "setnetent");
a0d0e21e
LW		 5060#endif
5061}
5062
5063PP(pp_sprotoent)
5064{
693762b4 5065#ifdef HAS_SETPROTOENT
9cad6237 5066 dSP;
76e3520e 5067 PerlSock_setprotoent(TOPi);
a0d0e21e
LW		 5068 RETSETYES;
5069#else
cea2e8a9 5070 DIE(aTHX_ PL_no_sock_func, "setprotoent");
a0d0e21e
LW		 5071#endif
5072}
5073
5074PP(pp_sservent)
5075{
693762b4 5076#ifdef HAS_SETSERVENT
9cad6237 5077 dSP;
76e3520e 5078 PerlSock_setservent(TOPi);
a0d0e21e
LW		 5079 RETSETYES;
5080#else
cea2e8a9 5081 DIE(aTHX_ PL_no_sock_func, "setservent");
a0d0e21e
LW		 5082#endif
5083}
5084
5085PP(pp_ehostent)
5086{
693762b4 5087#ifdef HAS_ENDHOSTENT
9cad6237 5088 dSP;
76e3520e 5089 PerlSock_endhostent();
924508f0 5090 EXTEND(SP,1);
a0d0e21e
LW		 5091 RETPUSHYES;
5092#else
cea2e8a9 5093 DIE(aTHX_ PL_no_sock_func, "endhostent");
a0d0e21e
LW		 5094#endif
5095}
5096
5097PP(pp_enetent)
5098{
693762b4 5099#ifdef HAS_ENDNETENT
9cad6237 5100 dSP;
76e3520e 5101 PerlSock_endnetent();
924508f0 5102 EXTEND(SP,1);
a0d0e21e
LW		 5103 RETPUSHYES;
5104#else
cea2e8a9 5105 DIE(aTHX_ PL_no_sock_func, "endnetent");
a0d0e21e
LW		 5106#endif
5107}
5108
5109PP(pp_eprotoent)
5110{
693762b4 5111#ifdef HAS_ENDPROTOENT
9cad6237 5112 dSP;
76e3520e 5113 PerlSock_endprotoent();
924508f0 5114 EXTEND(SP,1);
a0d0e21e
LW		 5115 RETPUSHYES;
5116#else
cea2e8a9 5117 DIE(aTHX_ PL_no_sock_func, "endprotoent");
a0d0e21e
LW		 5118#endif
5119}
5120
5121PP(pp_eservent)
5122{
693762b4 5123#ifdef HAS_ENDSERVENT
9cad6237 5124 dSP;
76e3520e 5125 PerlSock_endservent();
924508f0 5126 EXTEND(SP,1);
a0d0e21e
LW		 5127 RETPUSHYES;
5128#else
cea2e8a9 5129 DIE(aTHX_ PL_no_sock_func, "endservent");
a0d0e21e
LW		 5130#endif
5131}
5132
5133PP(pp_gpwnam)
5134{
5135#ifdef HAS_PASSWD
cea2e8a9 5136 return pp_gpwent();
a0d0e21e 5137#else
cea2e8a9 5138 DIE(aTHX_ PL_no_func, "getpwnam");
a0d0e21e
LW		 5139#endif
5140}
5141
5142PP(pp_gpwuid)
5143{
5144#ifdef HAS_PASSWD
cea2e8a9 5145 return pp_gpwent();
a0d0e21e 5146#else
cea2e8a9 5147 DIE(aTHX_ PL_no_func, "getpwuid");
a0d0e21e
LW		 5148#endif
5149}
5150
5151PP(pp_gpwent)
5152{
0994c4d0 5153#ifdef HAS_PASSWD
9cad6237 5154 dSP;
533c011a 5155 I32 which = PL_op->op_type;
a0d0e21e 5156 register SV *sv;
2d8e6c8d 5157 STRLEN n_a;
e3aefe8d 5158 struct passwd *pwent = NULL;
301e8125 5159 /*
bcf53261
JH		 5160 * We currently support only the SysV getsp* shadow password interface.
5161 * The interface is declared in <shadow.h> and often one needs to link
5162 * with -lsecurity or some such.
5163 * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5164 * (and SCO?)
5165 *
5166 * AIX getpwnam() is clever enough to return the encrypted password
5167 * only if the caller (euid?) is root.
5168 *
5169 * There are at least two other shadow password APIs. Many platforms
5170 * seem to contain more than one interface for accessing the shadow
5171 * password databases, possibly for compatibility reasons.
3813c136 5172 * The getsp*() is by far he simplest one, the other two interfaces
bcf53261
JH		 5173 * are much more complicated, but also very similar to each other.
5174 *
5175 * <sys/types.h>
5176 * <sys/security.h>
5177 * <prot.h>
5178 * struct pr_passwd *getprpw*();
5179 * The password is in
3813c136
JH		 5180 * char getprpw*(...).ufld.fd_encrypt[]
5181 * Mention HAS_GETPRPWNAM here so that Configure probes for it.
bcf53261
JH		 5182 *
5183 * <sys/types.h>
5184 * <sys/security.h>
5185 * <prot.h>
5186 * struct es_passwd *getespw*();
5187 * The password is in
5188 * char *(getespw*(...).ufld.fd_encrypt)
3813c136 5189 * Mention HAS_GETESPWNAM here so that Configure probes for it.
bcf53261 5190 *
3813c136 5191 * Mention I_PROT here so that Configure probes for it.
bcf53261
JH		 5192 *
5193 * In HP-UX for getprpw*() the manual page claims that one should include
5194 * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5195 * if one includes <shadow.h> as that includes <hpsecurity.h>,
5196 * and pp_sys.c already includes <shadow.h> if there is such.
3813c136
JH		 5197 *
5198 * Note that <sys/security.h> is already probed for, but currently
5199 * it is only included in special cases.
301e8125 5200 *
bcf53261
JH		 5201 * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5202 * be preferred interface, even though also the getprpw*() interface
5203 * is available) one needs to link with -lsecurity -ldb -laud -lm.
3813c136
JH		 5204 * One also needs to call set_auth_parameters() in main() before
5205 * doing anything else, whether one is using getespw*() or getprpw*().
5206 *
5207 * Note that accessing the shadow databases can be magnitudes
5208 * slower than accessing the standard databases.
bcf53261
JH		 5209 *
5210 * --jhi
5211 */
a0d0e21e 5212
e3aefe8d
JH		 5213 switch (which) {
5214 case OP_GPWNAM:
edd309b7
JH		 5215 {
5216 char* name = POPpbytex;
5217 pwent = getpwnam(name);
5218 }
5219 break;
e3aefe8d 5220 case OP_GPWUID:
edd309b7
JH		 5221 {
5222 Uid_t uid = POPi;
5223 pwent = getpwuid(uid);
5224 }
e3aefe8d
JH		 5225 break;
5226 case OP_GPWENT:
1883634f 5227# ifdef HAS_GETPWENT
e3aefe8d 5228 pwent = getpwent();
faea9016
IRC		 5229#ifdef POSIX_BC /* In some cases pw_passwd has invalid addresses */
5230 if (pwent) pwent = getpwnam(pwent->pw_name);
5231#endif
1883634f 5232# else
a45d1c96 5233 DIE(aTHX_ PL_no_func, "getpwent");
1883634f 5234# endif
e3aefe8d
JH		 5235 break;
5236 }
8c0bfa08 5237
a0d0e21e
LW		 5238 EXTEND(SP, 10);
5239 if (GIMME != G_ARRAY) {
5240 PUSHs(sv = sv_newmortal());
5241 if (pwent) {
5242 if (which == OP_GPWNAM)
1883634f 5243# if Uid_t_sign <= 0
1e422769 5244 sv_setiv(sv, (IV)pwent->pw_uid);
1883634f 5245# else
23dcd6c8 5246 sv_setuv(sv, (UV)pwent->pw_uid);
1883634f 5247# endif
a0d0e21e
LW		 5248 else
5249 sv_setpv(sv, pwent->pw_name);
5250 }
5251 RETURN;
5252 }
5253
5254 if (pwent) {
3280af22 5255 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 5256 sv_setpv(sv, pwent->pw_name);
6ee623d5 5257
3280af22 5258 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
3813c136
JH		 5259 SvPOK_off(sv);
5260 /* If we have getspnam(), we try to dig up the shadow
5261 * password. If we are underprivileged, the shadow
5262 * interface will set the errno to EACCES or similar,
5263 * and return a null pointer. If this happens, we will
5264 * use the dummy password (usually "*" or "x") from the
5265 * standard password database.
5266 *
5267 * In theory we could skip the shadow call completely
5268 * if euid != 0 but in practice we cannot know which
5269 * security measures are guarding the shadow databases
5270 * on a random platform.
5271 *
5272 * Resist the urge to use additional shadow interfaces.
5273 * Divert the urge to writing an extension instead.
5274 *
5275 * --jhi */
e3aefe8d 5276# ifdef HAS_GETSPNAM
3813c136
JH		 5277 {
5278 struct spwd *spwent;
5279 int saverrno; /* Save and restore errno so that
5280 * underprivileged attempts seem
5281 * to have never made the unsccessful
5282 * attempt to retrieve the shadow password. */
5283
5284 saverrno = errno;
5285 spwent = getspnam(pwent->pw_name);
5286 errno = saverrno;
5287 if (spwent && spwent->sp_pwdp)
5288 sv_setpv(sv, spwent->sp_pwdp);
5289 }
f1066039 5290# endif
e020c87d 5291# ifdef PWPASSWD
3813c136
JH		 5292 if (!SvPOK(sv)) /* Use the standard password, then. */
5293 sv_setpv(sv, pwent->pw_passwd);
e020c87d 5294# endif
3813c136 5295
1883634f 5296# ifndef INCOMPLETE_TAINTS
3813c136
JH		 5297 /* passwd is tainted because user himself can diddle with it.
5298 * admittedly not much and in a very limited way, but nevertheless. */
2959b6e3 5299 SvTAINTED_on(sv);
1883634f 5300# endif
6ee623d5 5301
3280af22 5302 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1883634f 5303# if Uid_t_sign <= 0
1e422769 5304 sv_setiv(sv, (IV)pwent->pw_uid);
1883634f 5305# else
23dcd6c8 5306 sv_setuv(sv, (UV)pwent->pw_uid);
1883634f 5307# endif
6ee623d5 5308
3280af22 5309 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1883634f 5310# if Uid_t_sign <= 0
1e422769 5311 sv_setiv(sv, (IV)pwent->pw_gid);
1883634f 5312# else
23dcd6c8 5313 sv_setuv(sv, (UV)pwent->pw_gid);
1883634f 5314# endif
3813c136
JH		 5315 /* pw_change, pw_quota, and pw_age are mutually exclusive--
5316 * because of the poor interface of the Perl getpw*(),
5317 * not because there's some standard/convention saying so.
5318 * A better interface would have been to return a hash,
5319 * but we are accursed by our history, alas. --jhi. */
3280af22 5320 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1883634f 5321# ifdef PWCHANGE
1e422769 5322 sv_setiv(sv, (IV)pwent->pw_change);
6ee623d5 5323# else
1883634f
JH		 5324# ifdef PWQUOTA
5325 sv_setiv(sv, (IV)pwent->pw_quota);
5326# else
a1757be1 5327# ifdef PWAGE
a0d0e21e 5328 sv_setpv(sv, pwent->pw_age);
a1757be1 5329# endif
6ee623d5
GS		 5330# endif
5331# endif
6ee623d5 5332
3813c136
JH		 5333 /* pw_class and pw_comment are mutually exclusive--.
5334 * see the above note for pw_change, pw_quota, and pw_age. */
3280af22 5335 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1883634f 5336# ifdef PWCLASS
a0d0e21e 5337 sv_setpv(sv, pwent->pw_class);
1883634f
JH		 5338# else
5339# ifdef PWCOMMENT
a0d0e21e 5340 sv_setpv(sv, pwent->pw_comment);
1883634f 5341# endif
6ee623d5 5342# endif
6ee623d5 5343
3280af22 5344 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1883634f 5345# ifdef PWGECOS
a0d0e21e 5346 sv_setpv(sv, pwent->pw_gecos);
1883634f
JH		 5347# endif
5348# ifndef INCOMPLETE_TAINTS
d2719217 5349 /* pw_gecos is tainted because user himself can diddle with it. */
fb73857a 5350 SvTAINTED_on(sv);
1883634f 5351# endif
6ee623d5 5352
3280af22 5353 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 5354 sv_setpv(sv, pwent->pw_dir);
6ee623d5 5355
3280af22 5356 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 5357 sv_setpv(sv, pwent->pw_shell);
1883634f 5358# ifndef INCOMPLETE_TAINTS
4602f195
JH		 5359 /* pw_shell is tainted because user himself can diddle with it. */
5360 SvTAINTED_on(sv);
1883634f 5361# endif
6ee623d5 5362
1883634f 5363# ifdef PWEXPIRE
6b88bc9c 5364 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 5365 sv_setiv(sv, (IV)pwent->pw_expire);
1883634f 5366# endif
a0d0e21e
LW		 5367 }
5368 RETURN;
5369#else
cea2e8a9 5370 DIE(aTHX_ PL_no_func, "getpwent");
a0d0e21e
LW		 5371#endif
5372}
5373
5374PP(pp_spwent)
5375{
d493b042 5376#if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
9cad6237 5377 dSP;
a0d0e21e
LW		 5378 setpwent();
5379 RETPUSHYES;
5380#else
cea2e8a9 5381 DIE(aTHX_ PL_no_func, "setpwent");
a0d0e21e
LW		 5382#endif
5383}
5384
5385PP(pp_epwent)
5386{
28e8609d 5387#if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
9cad6237 5388 dSP;
a0d0e21e
LW		 5389 endpwent();
5390 RETPUSHYES;
5391#else
cea2e8a9 5392 DIE(aTHX_ PL_no_func, "endpwent");
a0d0e21e
LW		 5393#endif
5394}
5395
5396PP(pp_ggrnam)
5397{
5398#ifdef HAS_GROUP
cea2e8a9 5399 return pp_ggrent();
a0d0e21e 5400#else
cea2e8a9 5401 DIE(aTHX_ PL_no_func, "getgrnam");
a0d0e21e
LW		 5402#endif
5403}
5404
5405PP(pp_ggrgid)
5406{
5407#ifdef HAS_GROUP
cea2e8a9 5408 return pp_ggrent();
a0d0e21e 5409#else
cea2e8a9 5410 DIE(aTHX_ PL_no_func, "getgrgid");
a0d0e21e
LW		 5411#endif
5412}
5413
5414PP(pp_ggrent)
5415{
0994c4d0 5416#ifdef HAS_GROUP
9cad6237 5417 dSP;
533c011a 5418 I32 which = PL_op->op_type;
a0d0e21e
LW		 5419 register char **elem;
5420 register SV *sv;
5421 struct group *grent;
2d8e6c8d 5422 STRLEN n_a;
a0d0e21e 5423
edd309b7
JH		 5424 if (which == OP_GGRNAM) {
5425 char* name = POPpbytex;
5426 grent = (struct group *)getgrnam(name);
5427 }
5428 else if (which == OP_GGRGID) {
5429 Gid_t gid = POPi;
5430 grent = (struct group *)getgrgid(gid);
5431 }
a0d0e21e 5432 else
0994c4d0 5433#ifdef HAS_GETGRENT
a0d0e21e 5434 grent = (struct group *)getgrent();
0994c4d0
JH		 5435#else
5436 DIE(aTHX_ PL_no_func, "getgrent");
5437#endif
a0d0e21e
LW		 5438
5439 EXTEND(SP, 4);
5440 if (GIMME != G_ARRAY) {
5441 PUSHs(sv = sv_newmortal());
5442 if (grent) {
5443 if (which == OP_GGRNAM)
1e422769 5444 sv_setiv(sv, (IV)grent->gr_gid);
a0d0e21e
LW		 5445 else
5446 sv_setpv(sv, grent->gr_name);
5447 }
5448 RETURN;
5449 }
5450
5451 if (grent) {
3280af22 5452 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 5453 sv_setpv(sv, grent->gr_name);
28e8609d 5454
3280af22 5455 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
28e8609d 5456#ifdef GRPASSWD
a0d0e21e 5457 sv_setpv(sv, grent->gr_passwd);
28e8609d
JH		 5458#endif
5459
3280af22 5460 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 5461 sv_setiv(sv, (IV)grent->gr_gid);
28e8609d 5462
5b56e7c5 5463#if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
3280af22 5464 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
3d7e8424
JH		 5465 /* In UNICOS/mk (_CRAYMPP) the multithreading
5466 * versions (getgrnam_r, getgrgid_r)
5467 * seem to return an illegal pointer
5468 * as the group members list, gr_mem.
5469 * getgrent() doesn't even have a _r version
5470 * but the gr_mem is poisonous anyway.
5471 * So yes, you cannot get the list of group
5472 * members if building multithreaded in UNICOS/mk. */
c90c0ff4 5473 for (elem = grent->gr_mem; elem && *elem; elem++) {
a0d0e21e
LW		 5474 sv_catpv(sv, *elem);
5475 if (elem[1])
5476 sv_catpvn(sv, " ", 1);
5477 }
3d7e8424 5478#endif
a0d0e21e
LW		 5479 }
5480
5481 RETURN;
5482#else
cea2e8a9 5483 DIE(aTHX_ PL_no_func, "getgrent");
a0d0e21e
LW		 5484#endif
5485}
5486
5487PP(pp_sgrent)
5488{
28e8609d 5489#if defined(HAS_GROUP) && defined(HAS_SETGRENT)
9cad6237 5490 dSP;
a0d0e21e
LW		 5491 setgrent();
5492 RETPUSHYES;
5493#else
cea2e8a9 5494 DIE(aTHX_ PL_no_func, "setgrent");
a0d0e21e
LW		 5495#endif
5496}
5497
5498PP(pp_egrent)
5499{
28e8609d 5500#if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
9cad6237 5501 dSP;
a0d0e21e
LW		 5502 endgrent();
5503 RETPUSHYES;
5504#else
cea2e8a9 5505 DIE(aTHX_ PL_no_func, "endgrent");
a0d0e21e
LW		 5506#endif
5507}
5508
5509PP(pp_getlogin)
5510{
a0d0e21e 5511#ifdef HAS_GETLOGIN
9cad6237 5512 dSP; dTARGET;
a0d0e21e
LW		 5513 char *tmps;
5514 EXTEND(SP, 1);
76e3520e 5515 if (!(tmps = PerlProc_getlogin()))
a0d0e21e
LW		 5516 RETPUSHUNDEF;
5517 PUSHp(tmps, strlen(tmps));
5518 RETURN;
5519#else
cea2e8a9 5520 DIE(aTHX_ PL_no_func, "getlogin");
a0d0e21e
LW		 5521#endif
5522}
5523
5524/* Miscellaneous. */
5525
5526PP(pp_syscall)
5527{
d2719217 5528#ifdef HAS_SYSCALL
39644a26 5529 dSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW		 5530 register I32 items = SP - MARK;
5531 unsigned long a[20];
5532 register I32 i = 0;
5533 I32 retval = -1;
2d8e6c8d 5534 STRLEN n_a;
a0d0e21e 5535
3280af22 5536 if (PL_tainting) {
a0d0e21e 5537 while (++MARK <= SP) {
bbce6d69 5538 if (SvTAINTED(*MARK)) {
5539 TAINT;
5540 break;
5541 }
a0d0e21e
LW		 5542 }
5543 MARK = ORIGMARK;
5544 TAINT_PROPER("syscall");
5545 }
5546
5547 /* This probably won't work on machines where sizeof(long) != sizeof(int)
5548 * or where sizeof(long) != sizeof(char*). But such machines will
5549 * not likely have syscall implemented either, so who cares?
5550 */
5551 while (++MARK <= SP) {
5552 if (SvNIOK(*MARK) || !i)
5553 a[i++] = SvIV(*MARK);
3280af22 5554 else if (*MARK == &PL_sv_undef)
748a9306 5555 a[i++] = 0;
301e8125 5556 else
2d8e6c8d 5557 a[i++] = (unsigned long)SvPV_force(*MARK, n_a);
a0d0e21e
LW		 5558 if (i > 15)
5559 break;
5560 }
5561 switch (items) {
5562 default:
cea2e8a9 5563 DIE(aTHX_ "Too many args to syscall");
a0d0e21e 5564 case 0:
cea2e8a9 5565 DIE(aTHX_ "Too few args to syscall");
a0d0e21e
LW		 5566 case 1:
5567 retval = syscall(a[0]);
5568 break;
5569 case 2:
5570 retval = syscall(a[0],a[1]);
5571 break;
5572 case 3:
5573 retval = syscall(a[0],a[1],a[2]);
5574 break;
5575 case 4:
5576 retval = syscall(a[0],a[1],a[2],a[3]);
5577 break;
5578 case 5:
5579 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5580 break;
5581 case 6:
5582 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5583 break;
5584 case 7:
5585 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5586 break;
5587 case 8:
5588 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5589 break;
5590#ifdef atarist
5591 case 9:
5592 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5593 break;
5594 case 10:
5595 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
5596 break;
5597 case 11:
5598 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5599 a[10]);
5600 break;
5601 case 12:
5602 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5603 a[10],a[11]);
5604 break;
5605 case 13:
5606 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5607 a[10],a[11],a[12]);
5608 break;
5609 case 14:
5610 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5611 a[10],a[11],a[12],a[13]);
5612 break;
5613#endif /* atarist */
5614 }
5615 SP = ORIGMARK;
5616 PUSHi(retval);
5617 RETURN;
5618#else
cea2e8a9 5619 DIE(aTHX_ PL_no_func, "syscall");
a0d0e21e
LW		 5620#endif
5621}
5622
ff68c719 5623#ifdef FCNTL_EMULATE_FLOCK
301e8125 5624
ff68c719 5625/* XXX Emulate flock() with fcntl().
5626 What's really needed is a good file locking module.
5627*/
5628
cea2e8a9
GS		 5629static int
5630fcntl_emulate_flock(int fd, int operation)
ff68c719 5631{
5632 struct flock flock;
301e8125 5633
ff68c719 5634 switch (operation & ~LOCK_NB) {
5635 case LOCK_SH:
5636 flock.l_type = F_RDLCK;
5637 break;
5638 case LOCK_EX:
5639 flock.l_type = F_WRLCK;
5640 break;
5641 case LOCK_UN:
5642 flock.l_type = F_UNLCK;
5643 break;
5644 default:
5645 errno = EINVAL;
5646 return -1;
5647 }
5648 flock.l_whence = SEEK_SET;
d9b3e12d 5649 flock.l_start = flock.l_len = (Off_t)0;
301e8125 5650
ff68c719 5651 return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5652}
5653
5654#endif /* FCNTL_EMULATE_FLOCK */
5655
5656#ifdef LOCKF_EMULATE_FLOCK
16d20bd9
AD		 5657
5658/* XXX Emulate flock() with lockf(). This is just to increase
5659 portability of scripts. The calls are not completely
5660 interchangeable. What's really needed is a good file
5661 locking module.
5662*/
5663
76c32331 5664/* The lockf() constants might have been defined in <unistd.h>.
5665 Unfortunately, <unistd.h> causes troubles on some mixed
5666 (BSD/POSIX) systems, such as SunOS 4.1.3.
16d20bd9
AD		 5667
5668 Further, the lockf() constants aren't POSIX, so they might not be
5669 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
5670 just stick in the SVID values and be done with it. Sigh.
5671*/
5672
5673# ifndef F_ULOCK
5674# define F_ULOCK 0 /* Unlock a previously locked region */
5675# endif
5676# ifndef F_LOCK
5677# define F_LOCK 1 /* Lock a region for exclusive use */
5678# endif
5679# ifndef F_TLOCK
5680# define F_TLOCK 2 /* Test and lock a region for exclusive use */
5681# endif
5682# ifndef F_TEST
5683# define F_TEST 3 /* Test a region for other processes locks */
5684# endif
5685
cea2e8a9
GS		 5686static int
5687lockf_emulate_flock(int fd, int operation)
16d20bd9
AD		 5688{
5689 int i;
84902520
TB		 5690 int save_errno;
5691 Off_t pos;
5692
5693 /* flock locks entire file so for lockf we need to do the same */
5694 save_errno = errno;
6ad3d225 5695 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
84902520 5696 if (pos > 0) /* is seekable and needs to be repositioned */
6ad3d225 5697 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
08b714dd 5698 pos = -1; /* seek failed, so don't seek back afterwards */
84902520
TB		 5699 errno = save_errno;
5700
16d20bd9
AD		 5701 switch (operation) {
5702
5703 /* LOCK_SH - get a shared lock */
5704 case LOCK_SH:
5705 /* LOCK_EX - get an exclusive lock */
5706 case LOCK_EX:
5707 i = lockf (fd, F_LOCK, 0);
5708 break;
5709
5710 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5711 case LOCK_SH|LOCK_NB:
5712 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5713 case LOCK_EX|LOCK_NB:
5714 i = lockf (fd, F_TLOCK, 0);
5715 if (i == -1)
5716 if ((errno == EAGAIN) || (errno == EACCES))
5717 errno = EWOULDBLOCK;
5718 break;
5719
ff68c719 5720 /* LOCK_UN - unlock (non-blocking is a no-op) */
16d20bd9 5721 case LOCK_UN:
ff68c719 5722 case LOCK_UN|LOCK_NB:
16d20bd9
AD		 5723 i = lockf (fd, F_ULOCK, 0);
5724 break;
5725
5726 /* Default - can't decipher operation */
5727 default:
5728 i = -1;
5729 errno = EINVAL;
5730 break;
5731 }
84902520
TB		 5732
5733 if (pos > 0) /* need to restore position of the handle */
6ad3d225 5734 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
84902520 5735
16d20bd9
AD		 5736 return (i);
5737}
ff68c719 5738
5739#endif /* LOCKF_EMULATE_FLOCK */
Unnamed repository; edit this file 'description' to name the repository.