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
Re: [perl #16677] B::SV::FLAGS dumps core
[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
RD		 4050 if (PL_tainting) {
4051 TAINT_ENV();
4052 while (++MARK <= SP) {
4053 (void)SvPV_nolen(*MARK); /* stringify for taint check */
5a445156 4054 if (PL_tainted)
bbd7eb8a
RD		 4055 break;
4056 }
4057 MARK = ORIGMARK;
5a445156 4058 TAINT_PROPER("system");
a0d0e21e 4059 }
45bc9206 4060 PERL_FLUSHALL_FOR_CHILD;
273b0206 4061#if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
d7e492a4 4062 {
eb160463
GS		 4063 Pid_t childpid;
4064 int pp[2];
4065
4066 if (PerlProc_pipe(pp) >= 0)
4067 did_pipes = 1;
4068 while ((childpid = PerlProc_fork()) == -1) {
4069 if (errno != EAGAIN) {
4070 value = -1;
4071 SP = ORIGMARK;
4072 PUSHi(value);
4073 if (did_pipes) {
4074 PerlLIO_close(pp[0]);
4075 PerlLIO_close(pp[1]);
4076 }
4077 RETURN;
4078 }
4079 sleep(5);
4080 }
4081 if (childpid > 0) {
4082 Sigsave_t ihand,qhand; /* place to save signals during system() */
4083 int status;
4084
4085 if (did_pipes)
4086 PerlLIO_close(pp[1]);
64ca3a65 4087#ifndef PERL_MICRO
eb160463
GS		 4088 rsignal_save(SIGINT, SIG_IGN, &ihand);
4089 rsignal_save(SIGQUIT, SIG_IGN, &qhand);
64ca3a65 4090#endif
eb160463
GS		 4091 do {
4092 result = wait4pid(childpid, &status, 0);
4093 } while (result == -1 && errno == EINTR);
64ca3a65 4094#ifndef PERL_MICRO
eb160463
GS		 4095 (void)rsignal_restore(SIGINT, &ihand);
4096 (void)rsignal_restore(SIGQUIT, &qhand);
4097#endif
4098 STATUS_NATIVE_SET(result == -1 ? -1 : status);
4099 do_execfree(); /* free any memory child malloced on fork */
4100 SP = ORIGMARK;
4101 if (did_pipes) {
4102 int errkid;
4103 int n = 0, n1;
4104
4105 while (n < sizeof(int)) {
4106 n1 = PerlLIO_read(pp[0],
4107 (void*)(((char*)&errkid)+n),
4108 (sizeof(int)) - n);
4109 if (n1 <= 0)
4110 break;
4111 n += n1;
4112 }
4113 PerlLIO_close(pp[0]);
4114 if (n) { /* Error */
4115 if (n != sizeof(int))
4116 DIE(aTHX_ "panic: kid popen errno read");
4117 errno = errkid; /* Propagate errno from kid */
4118 STATUS_CURRENT = -1;
4119 }
4120 }
4121 PUSHi(STATUS_CURRENT);
4122 RETURN;
4123 }
4124 if (did_pipes) {
4125 PerlLIO_close(pp[0]);
d5a9bfb0 4126#if defined(HAS_FCNTL) && defined(F_SETFD)
eb160463 4127 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
d5a9bfb0 4128#endif
eb160463 4129 }
e0a1f643
JH		 4130 if (PL_op->op_flags & OPf_STACKED) {
4131 SV *really = *++MARK;
4132 value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4133 }
4134 else if (SP - MARK != 1)
4135 value = (I32)do_aexec5(Nullsv, MARK, SP, pp[1], did_pipes);
4136 else {
4137 value = (I32)do_exec3(SvPVx(sv_mortalcopy(*SP), n_a), pp[1], did_pipes);
4138 }
4139 PerlProc__exit(-1);
d5a9bfb0 4140 }
c3293030 4141#else /* ! FORK or VMS or OS/2 */
922b1888
GS		 4142 PL_statusvalue = 0;
4143 result = 0;
911d147d 4144 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e 4145 SV *really = *++MARK;
54725af6
GS		 4146# ifdef WIN32
4147 value = (I32)do_aspawn(really, MARK, SP);
4148# else
c5be433b 4149 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
54725af6 4150# endif
a0d0e21e 4151 }
54725af6
GS		 4152 else if (SP - MARK != 1) {
4153# ifdef WIN32
4154 value = (I32)do_aspawn(Nullsv, MARK, SP);
4155# else
c5be433b 4156 value = (I32)do_aspawn(Nullsv, (void **)MARK, (void **)SP);
54725af6
GS		 4157# endif
4158 }
a0d0e21e 4159 else {
c5be433b 4160 value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
a0d0e21e 4161 }
922b1888
GS		 4162 if (PL_statusvalue == -1) /* hint that value must be returned as is */
4163 result = 1;
f86702cc 4164 STATUS_NATIVE_SET(value);
a0d0e21e
LW		 4165 do_execfree();
4166 SP = ORIGMARK;
922b1888 4167 PUSHi(result ? value : STATUS_CURRENT);
a0d0e21e
LW		 4168#endif /* !FORK or VMS */
4169 RETURN;
4170}
4171
4172PP(pp_exec)
4173{
39644a26 4174 dSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e 4175 I32 value;
2d8e6c8d 4176 STRLEN n_a;
a0d0e21e 4177
bbd7eb8a
RD		 4178 if (PL_tainting) {
4179 TAINT_ENV();
4180 while (++MARK <= SP) {
4181 (void)SvPV_nolen(*MARK); /* stringify for taint check */
5a445156 4182 if (PL_tainted)
bbd7eb8a
RD		 4183 break;
4184 }
4185 MARK = ORIGMARK;
5a445156 4186 TAINT_PROPER("exec");
bbd7eb8a 4187 }
45bc9206 4188 PERL_FLUSHALL_FOR_CHILD;
533c011a 4189 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e
LW		 4190 SV *really = *++MARK;
4191 value = (I32)do_aexec(really, MARK, SP);
4192 }
4193 else if (SP - MARK != 1)
4194#ifdef VMS
4195 value = (I32)vms_do_aexec(Nullsv, MARK, SP);
4196#else
092bebab
JH		 4197# ifdef __OPEN_VM
4198 {
c5be433b 4199 (void ) do_aspawn(Nullsv, MARK, SP);
092bebab
JH		 4200 value = 0;
4201 }
4202# else
a0d0e21e 4203 value = (I32)do_aexec(Nullsv, MARK, SP);
092bebab 4204# endif
a0d0e21e
LW		 4205#endif
4206 else {
a0d0e21e 4207#ifdef VMS
2d8e6c8d 4208 value = (I32)vms_do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
a0d0e21e 4209#else
092bebab 4210# ifdef __OPEN_VM
c5be433b 4211 (void) do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
092bebab
JH		 4212 value = 0;
4213# else
2d8e6c8d 4214 value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
092bebab 4215# endif
a0d0e21e
LW		 4216#endif
4217 }
146174a9 4218
a0d0e21e
LW		 4219 SP = ORIGMARK;
4220 PUSHi(value);
4221 RETURN;
4222}
4223
4224PP(pp_kill)
4225{
9cad6237 4226#ifdef HAS_KILL
39644a26 4227 dSP; dMARK; dTARGET;
a0d0e21e 4228 I32 value;
533c011a 4229 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 4230 SP = MARK;
4231 PUSHi(value);
4232 RETURN;
4233#else
0322a713 4234 DIE(aTHX_ PL_no_func, "kill");
a0d0e21e
LW		 4235#endif
4236}
4237
4238PP(pp_getppid)
4239{
4240#ifdef HAS_GETPPID
39644a26 4241 dSP; dTARGET;
a0d0e21e
LW		 4242 XPUSHi( getppid() );
4243 RETURN;
4244#else
cea2e8a9 4245 DIE(aTHX_ PL_no_func, "getppid");
a0d0e21e
LW		 4246#endif
4247}
4248
4249PP(pp_getpgrp)
4250{
4251#ifdef HAS_GETPGRP
39644a26 4252 dSP; dTARGET;
d8a83dd3 4253 Pid_t pid;
9853a804 4254 Pid_t pgrp;
a0d0e21e
LW		 4255
4256 if (MAXARG < 1)
4257 pid = 0;
4258 else
4259 pid = SvIVx(POPs);
c3293030 4260#ifdef BSD_GETPGRP
9853a804 4261 pgrp = (I32)BSD_GETPGRP(pid);
a0d0e21e 4262#else
146174a9 4263 if (pid != 0 && pid != PerlProc_getpid())
cea2e8a9 4264 DIE(aTHX_ "POSIX getpgrp can't take an argument");
9853a804 4265 pgrp = getpgrp();
a0d0e21e 4266#endif
9853a804 4267 XPUSHi(pgrp);
a0d0e21e
LW		 4268 RETURN;
4269#else
cea2e8a9 4270 DIE(aTHX_ PL_no_func, "getpgrp()");
a0d0e21e
LW		 4271#endif
4272}
4273
4274PP(pp_setpgrp)
4275{
4276#ifdef HAS_SETPGRP
39644a26 4277 dSP; dTARGET;
d8a83dd3
JH		 4278 Pid_t pgrp;
4279 Pid_t pid;
a0d0e21e
LW		 4280 if (MAXARG < 2) {
4281 pgrp = 0;
4282 pid = 0;
4283 }
4284 else {
4285 pgrp = POPi;
4286 pid = TOPi;
4287 }
4288
4289 TAINT_PROPER("setpgrp");
c3293030
IZ		 4290#ifdef BSD_SETPGRP
4291 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
a0d0e21e 4292#else
146174a9
CB		 4293 if ((pgrp != 0 && pgrp != PerlProc_getpid())
4294 || (pid != 0 && pid != PerlProc_getpid()))
4295 {
4296 DIE(aTHX_ "setpgrp can't take arguments");
4297 }
a0d0e21e
LW		 4298 SETi( setpgrp() >= 0 );
4299#endif /* USE_BSDPGRP */
4300 RETURN;
4301#else
cea2e8a9 4302 DIE(aTHX_ PL_no_func, "setpgrp()");
a0d0e21e
LW		 4303#endif
4304}
4305
4306PP(pp_getpriority)
4307{
a0d0e21e 4308#ifdef HAS_GETPRIORITY
9cad6237 4309 dSP; dTARGET;
d05c1ba0
JH		 4310 int who = POPi;
4311 int which = TOPi;
a0d0e21e
LW		 4312 SETi( getpriority(which, who) );
4313 RETURN;
4314#else
cea2e8a9 4315 DIE(aTHX_ PL_no_func, "getpriority()");
a0d0e21e
LW		 4316#endif
4317}
4318
4319PP(pp_setpriority)
4320{
a0d0e21e 4321#ifdef HAS_SETPRIORITY
9cad6237 4322 dSP; dTARGET;
d05c1ba0
JH		 4323 int niceval = POPi;
4324 int who = POPi;
4325 int which = TOPi;
a0d0e21e
LW		 4326 TAINT_PROPER("setpriority");
4327 SETi( setpriority(which, who, niceval) >= 0 );
4328 RETURN;
4329#else
cea2e8a9 4330 DIE(aTHX_ PL_no_func, "setpriority()");
a0d0e21e
LW		 4331#endif
4332}
4333
4334/* Time calls. */
4335
4336PP(pp_time)
4337{
39644a26 4338 dSP; dTARGET;
cbdc8872 4339#ifdef BIG_TIME
4340 XPUSHn( time(Null(Time_t*)) );
4341#else
a0d0e21e 4342 XPUSHi( time(Null(Time_t*)) );
cbdc8872 4343#endif
a0d0e21e
LW		 4344 RETURN;
4345}
4346
cd52b7b2 4347/* XXX The POSIX name is CLK_TCK; it is to be preferred
4348 to HZ. Probably. For now, assume that if the system
4349 defines HZ, it does so correctly. (Will this break
4350 on VMS?)
4351 Probably we ought to use _sysconf(_SC_CLK_TCK), if
4352 it's supported. --AD 9/96.
4353*/
4354
9bc87460
JH		 4355#ifdef __BEOS__
4356# define HZ 1000000
4357#endif
4358
a0d0e21e 4359#ifndef HZ
cd52b7b2 4360# ifdef CLK_TCK
4361# define HZ CLK_TCK
4362# else
4363# define HZ 60
4364# endif
a0d0e21e
LW		 4365#endif
4366
4367PP(pp_tms)
4368{
9cad6237 4369#ifdef HAS_TIMES
39644a26 4370 dSP;
a0d0e21e 4371 EXTEND(SP, 4);
a0d0e21e 4372#ifndef VMS
3280af22 4373 (void)PerlProc_times(&PL_timesbuf);
a0d0e21e 4374#else
6b88bc9c 4375 (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */
76e3520e
GS		 4376 /* struct tms, though same data */
4377 /* is returned. */
a0d0e21e
LW		 4378#endif
4379
65202027 4380 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_utime)/HZ)));
a0d0e21e 4381 if (GIMME == G_ARRAY) {
65202027
DS		 4382 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_stime)/HZ)));
4383 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cutime)/HZ)));
4384 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cstime)/HZ)));
a0d0e21e
LW		 4385 }
4386 RETURN;
9cad6237
JH		 4387#else
4388 DIE(aTHX_ "times not implemented");
55497cff 4389#endif /* HAS_TIMES */
a0d0e21e
LW		 4390}
4391
4392PP(pp_localtime)
4393{
cea2e8a9 4394 return pp_gmtime();
a0d0e21e
LW		 4395}
4396
4397PP(pp_gmtime)
4398{
39644a26 4399 dSP;
a0d0e21e
LW		 4400 Time_t when;
4401 struct tm *tmbuf;
4402 static char *dayname[] = {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4403 static char *monname[] = {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4404 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4405
4406 if (MAXARG < 1)
4407 (void)time(&when);
4408 else
cbdc8872 4409#ifdef BIG_TIME
4410 when = (Time_t)SvNVx(POPs);
4411#else
a0d0e21e 4412 when = (Time_t)SvIVx(POPs);
cbdc8872 4413#endif
a0d0e21e 4414
533c011a 4415 if (PL_op->op_type == OP_LOCALTIME)
a0d0e21e
LW		 4416 tmbuf = localtime(&when);
4417 else
4418 tmbuf = gmtime(&when);
4419
a0d0e21e 4420 if (GIMME != G_ARRAY) {
46fc3d4c 4421 SV *tsv;
9a5ff6d9
AB		 4422 EXTEND(SP, 1);
4423 EXTEND_MORTAL(1);
a0d0e21e
LW		 4424 if (!tmbuf)
4425 RETPUSHUNDEF;
be28567c 4426 tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %d",
f5a29b03
RB		 4427 dayname[tmbuf->tm_wday],
4428 monname[tmbuf->tm_mon],
be28567c
GS		 4429 tmbuf->tm_mday,
4430 tmbuf->tm_hour,
4431 tmbuf->tm_min,
4432 tmbuf->tm_sec,
4433 tmbuf->tm_year + 1900);
46fc3d4c 4434 PUSHs(sv_2mortal(tsv));
a0d0e21e
LW		 4435 }
4436 else if (tmbuf) {
9a5ff6d9
AB		 4437 EXTEND(SP, 9);
4438 EXTEND_MORTAL(9);
4439 PUSHs(sv_2mortal(newSViv(tmbuf->tm_sec)));
c6419e06
JH		 4440 PUSHs(sv_2mortal(newSViv(tmbuf->tm_min)));
4441 PUSHs(sv_2mortal(newSViv(tmbuf->tm_hour)));
4442 PUSHs(sv_2mortal(newSViv(tmbuf->tm_mday)));
4443 PUSHs(sv_2mortal(newSViv(tmbuf->tm_mon)));
4444 PUSHs(sv_2mortal(newSViv(tmbuf->tm_year)));
4445 PUSHs(sv_2mortal(newSViv(tmbuf->tm_wday)));
4446 PUSHs(sv_2mortal(newSViv(tmbuf->tm_yday)));
4447 PUSHs(sv_2mortal(newSViv(tmbuf->tm_isdst)));
a0d0e21e
LW		 4448 }
4449 RETURN;
4450}
4451
4452PP(pp_alarm)
4453{
9cad6237 4454#ifdef HAS_ALARM
39644a26 4455 dSP; dTARGET;
a0d0e21e 4456 int anum;
a0d0e21e
LW		 4457 anum = POPi;
4458 anum = alarm((unsigned int)anum);
4459 EXTEND(SP, 1);
4460 if (anum < 0)
4461 RETPUSHUNDEF;
c6419e06 4462 PUSHi(anum);
a0d0e21e
LW		 4463 RETURN;
4464#else
0322a713 4465 DIE(aTHX_ PL_no_func, "alarm");
a0d0e21e
LW		 4466#endif
4467}
4468
4469PP(pp_sleep)
4470{
39644a26 4471 dSP; dTARGET;
a0d0e21e
LW		 4472 I32 duration;
4473 Time_t lasttime;
4474 Time_t when;
4475
4476 (void)time(&lasttime);
4477 if (MAXARG < 1)
76e3520e 4478 PerlProc_pause();
a0d0e21e
LW		 4479 else {
4480 duration = POPi;
76e3520e 4481 PerlProc_sleep((unsigned int)duration);
a0d0e21e
LW		 4482 }
4483 (void)time(&when);
4484 XPUSHi(when - lasttime);
4485 RETURN;
4486}
4487
4488/* Shared memory. */
4489
4490PP(pp_shmget)
4491{
cea2e8a9 4492 return pp_semget();
a0d0e21e
LW		 4493}
4494
4495PP(pp_shmctl)
4496{
cea2e8a9 4497 return pp_semctl();
a0d0e21e
LW		 4498}
4499
4500PP(pp_shmread)
4501{
cea2e8a9 4502 return pp_shmwrite();
a0d0e21e
LW		 4503}
4504
4505PP(pp_shmwrite)
4506{
4507#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
39644a26 4508 dSP; dMARK; dTARGET;
533c011a 4509 I32 value = (I32)(do_shmio(PL_op->op_type, MARK, SP) >= 0);
a0d0e21e
LW		 4510 SP = MARK;
4511 PUSHi(value);
4512 RETURN;
4513#else
cea2e8a9 4514 return pp_semget();
a0d0e21e
LW		 4515#endif
4516}
4517
4518/* Message passing. */
4519
4520PP(pp_msgget)
4521{
cea2e8a9 4522 return pp_semget();
a0d0e21e
LW		 4523}
4524
4525PP(pp_msgctl)
4526{
cea2e8a9 4527 return pp_semctl();
a0d0e21e
LW		 4528}
4529
4530PP(pp_msgsnd)
4531{
4532#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
39644a26 4533 dSP; dMARK; dTARGET;
a0d0e21e
LW		 4534 I32 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4535 SP = MARK;
4536 PUSHi(value);
4537 RETURN;
4538#else
cea2e8a9 4539 return pp_semget();
a0d0e21e
LW		 4540#endif
4541}
4542
4543PP(pp_msgrcv)
4544{
4545#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
39644a26 4546 dSP; dMARK; dTARGET;
a0d0e21e
LW		 4547 I32 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4548 SP = MARK;
4549 PUSHi(value);
4550 RETURN;
4551#else
cea2e8a9 4552 return pp_semget();
a0d0e21e
LW		 4553#endif
4554}
4555
4556/* Semaphores. */
4557
4558PP(pp_semget)
4559{
4560#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
39644a26 4561 dSP; dMARK; dTARGET;
533c011a 4562 int anum = do_ipcget(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 4563 SP = MARK;
4564 if (anum == -1)
4565 RETPUSHUNDEF;
4566 PUSHi(anum);
4567 RETURN;
4568#else
cea2e8a9 4569 DIE(aTHX_ "System V IPC is not implemented on this machine");
a0d0e21e
LW		 4570#endif
4571}
4572
4573PP(pp_semctl)
4574{
4575#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
39644a26 4576 dSP; dMARK; dTARGET;
533c011a 4577 int anum = do_ipcctl(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 4578 SP = MARK;
4579 if (anum == -1)
4580 RETSETUNDEF;
4581 if (anum != 0) {
4582 PUSHi(anum);
4583 }
4584 else {
8903cb82 4585 PUSHp(zero_but_true, ZBTLEN);
a0d0e21e
LW		 4586 }
4587 RETURN;
4588#else
cea2e8a9 4589 return pp_semget();
a0d0e21e
LW		 4590#endif
4591}
4592
4593PP(pp_semop)
4594{
4595#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
39644a26 4596 dSP; dMARK; dTARGET;
a0d0e21e
LW		 4597 I32 value = (I32)(do_semop(MARK, SP) >= 0);
4598 SP = MARK;
4599 PUSHi(value);
4600 RETURN;
4601#else
cea2e8a9 4602 return pp_semget();
a0d0e21e
LW		 4603#endif
4604}
4605
4606/* Get system info. */
4607
4608PP(pp_ghbyname)
4609{
693762b4 4610#ifdef HAS_GETHOSTBYNAME
cea2e8a9 4611 return pp_ghostent();
a0d0e21e 4612#else
cea2e8a9 4613 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
a0d0e21e
LW		 4614#endif
4615}
4616
4617PP(pp_ghbyaddr)
4618{
693762b4 4619#ifdef HAS_GETHOSTBYADDR
cea2e8a9 4620 return pp_ghostent();
a0d0e21e 4621#else
cea2e8a9 4622 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
a0d0e21e
LW		 4623#endif
4624}
4625
4626PP(pp_ghostent)
4627{
693762b4 4628#if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
9cad6237 4629 dSP;
533c011a 4630 I32 which = PL_op->op_type;
a0d0e21e
LW		 4631 register char **elem;
4632 register SV *sv;
dc45a647 4633#ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
1d88b533
JH		 4634 struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4635 struct hostent *gethostbyname(Netdb_name_t);
4636 struct hostent *gethostent(void);
a0d0e21e
LW		 4637#endif
4638 struct hostent *hent;
4639 unsigned long len;
2d8e6c8d 4640 STRLEN n_a;
a0d0e21e
LW		 4641
4642 EXTEND(SP, 10);
edd309b7 4643 if (which == OP_GHBYNAME) {
dc45a647 4644#ifdef HAS_GETHOSTBYNAME
edd309b7
JH		 4645 char* name = POPpbytex;
4646 hent = PerlSock_gethostbyname(name);
dc45a647 4647#else
cea2e8a9 4648 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
dc45a647 4649#endif
edd309b7 4650 }
a0d0e21e 4651 else if (which == OP_GHBYADDR) {
dc45a647 4652#ifdef HAS_GETHOSTBYADDR
a0d0e21e 4653 int addrtype = POPi;
748a9306 4654 SV *addrsv = POPs;
a0d0e21e 4655 STRLEN addrlen;
595ae481 4656 Netdb_host_t addr = (Netdb_host_t) SvPVbyte(addrsv, addrlen);
a0d0e21e 4657
4599a1de 4658 hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
dc45a647 4659#else
cea2e8a9 4660 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
dc45a647 4661#endif
a0d0e21e
LW		 4662 }
4663 else
4664#ifdef HAS_GETHOSTENT
6ad3d225 4665 hent = PerlSock_gethostent();
a0d0e21e 4666#else
cea2e8a9 4667 DIE(aTHX_ PL_no_sock_func, "gethostent");
a0d0e21e
LW		 4668#endif
4669
4670#ifdef HOST_NOT_FOUND
10bc17b6
JH		 4671 if (!hent) {
4672#ifdef USE_REENTRANT_API
4673# ifdef USE_GETHOSTENT_ERRNO
4674 h_errno = PL_reentrant_buffer->_gethostent_errno;
4675# endif
4676#endif
4677 STATUS_NATIVE_SET(h_errno);
4678 }
a0d0e21e
LW		 4679#endif
4680
4681 if (GIMME != G_ARRAY) {
4682 PUSHs(sv = sv_newmortal());
4683 if (hent) {
4684 if (which == OP_GHBYNAME) {
fd0af264 4685 if (hent->h_addr)
4686 sv_setpvn(sv, hent->h_addr, hent->h_length);
a0d0e21e
LW		 4687 }
4688 else
4689 sv_setpv(sv, (char*)hent->h_name);
4690 }
4691 RETURN;
4692 }
4693
4694 if (hent) {
3280af22 4695 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4696 sv_setpv(sv, (char*)hent->h_name);
3280af22 4697 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 4698 for (elem = hent->h_aliases; elem && *elem; elem++) {
4699 sv_catpv(sv, *elem);
4700 if (elem[1])
4701 sv_catpvn(sv, " ", 1);
4702 }
3280af22 4703 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4704 sv_setiv(sv, (IV)hent->h_addrtype);
3280af22 4705 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4706 len = hent->h_length;
1e422769 4707 sv_setiv(sv, (IV)len);
a0d0e21e
LW		 4708#ifdef h_addr
4709 for (elem = hent->h_addr_list; elem && *elem; elem++) {
3280af22 4710 XPUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 4711 sv_setpvn(sv, *elem, len);
4712 }
4713#else
6b88bc9c 4714 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
fd0af264 4715 if (hent->h_addr)
4716 sv_setpvn(sv, hent->h_addr, len);
a0d0e21e
LW		 4717#endif /* h_addr */
4718 }
4719 RETURN;
4720#else
cea2e8a9 4721 DIE(aTHX_ PL_no_sock_func, "gethostent");
a0d0e21e
LW		 4722#endif
4723}
4724
4725PP(pp_gnbyname)
4726{
693762b4 4727#ifdef HAS_GETNETBYNAME
cea2e8a9 4728 return pp_gnetent();
a0d0e21e 4729#else
cea2e8a9 4730 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
a0d0e21e
LW		 4731#endif
4732}
4733
4734PP(pp_gnbyaddr)
4735{
693762b4 4736#ifdef HAS_GETNETBYADDR
cea2e8a9 4737 return pp_gnetent();
a0d0e21e 4738#else
cea2e8a9 4739 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
a0d0e21e
LW		 4740#endif
4741}
4742
4743PP(pp_gnetent)
4744{
693762b4 4745#if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
9cad6237 4746 dSP;
533c011a 4747 I32 which = PL_op->op_type;
a0d0e21e
LW		 4748 register char **elem;
4749 register SV *sv;
dc45a647 4750#ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
1d88b533
JH		 4751 struct netent *getnetbyaddr(Netdb_net_t, int);
4752 struct netent *getnetbyname(Netdb_name_t);
4753 struct netent *getnetent(void);
8ac85365 4754#endif
a0d0e21e 4755 struct netent *nent;
2d8e6c8d 4756 STRLEN n_a;
a0d0e21e 4757
edd309b7 4758 if (which == OP_GNBYNAME){
dc45a647 4759#ifdef HAS_GETNETBYNAME
edd309b7
JH		 4760 char *name = POPpbytex;
4761 nent = PerlSock_getnetbyname(name);
dc45a647 4762#else
cea2e8a9 4763 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
dc45a647 4764#endif
edd309b7 4765 }
a0d0e21e 4766 else if (which == OP_GNBYADDR) {
dc45a647 4767#ifdef HAS_GETNETBYADDR
a0d0e21e 4768 int addrtype = POPi;
3bb7c1b4 4769 Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
76e3520e 4770 nent = PerlSock_getnetbyaddr(addr, addrtype);
dc45a647 4771#else
cea2e8a9 4772 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
dc45a647 4773#endif
a0d0e21e
LW		 4774 }
4775 else
dc45a647 4776#ifdef HAS_GETNETENT
76e3520e 4777 nent = PerlSock_getnetent();
dc45a647 4778#else
cea2e8a9 4779 DIE(aTHX_ PL_no_sock_func, "getnetent");
dc45a647 4780#endif
a0d0e21e 4781
10bc17b6
JH		 4782#ifdef HOST_NOT_FOUND
4783 if (!nent) {
4784#ifdef USE_REENTRANT_API
4785# ifdef USE_GETNETENT_ERRNO
4786 h_errno = PL_reentrant_buffer->_getnetent_errno;
4787# endif
4788#endif
4789 STATUS_NATIVE_SET(h_errno);
4790 }
4791#endif
4792
a0d0e21e
LW		 4793 EXTEND(SP, 4);
4794 if (GIMME != G_ARRAY) {
4795 PUSHs(sv = sv_newmortal());
4796 if (nent) {
4797 if (which == OP_GNBYNAME)
1e422769 4798 sv_setiv(sv, (IV)nent->n_net);
a0d0e21e
LW		 4799 else
4800 sv_setpv(sv, nent->n_name);
4801 }
4802 RETURN;
4803 }
4804
4805 if (nent) {
3280af22 4806 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4807 sv_setpv(sv, nent->n_name);
3280af22 4808 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 4809 for (elem = nent->n_aliases; elem && *elem; elem++) {
a0d0e21e
LW		 4810 sv_catpv(sv, *elem);
4811 if (elem[1])
4812 sv_catpvn(sv, " ", 1);
4813 }
3280af22 4814 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4815 sv_setiv(sv, (IV)nent->n_addrtype);
3280af22 4816 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4817 sv_setiv(sv, (IV)nent->n_net);
a0d0e21e
LW		 4818 }
4819
4820 RETURN;
4821#else
cea2e8a9 4822 DIE(aTHX_ PL_no_sock_func, "getnetent");
a0d0e21e
LW		 4823#endif
4824}
4825
4826PP(pp_gpbyname)
4827{
693762b4 4828#ifdef HAS_GETPROTOBYNAME
cea2e8a9 4829 return pp_gprotoent();
a0d0e21e 4830#else
cea2e8a9 4831 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
a0d0e21e
LW		 4832#endif
4833}
4834
4835PP(pp_gpbynumber)
4836{
693762b4 4837#ifdef HAS_GETPROTOBYNUMBER
cea2e8a9 4838 return pp_gprotoent();
a0d0e21e 4839#else
cea2e8a9 4840 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
a0d0e21e
LW		 4841#endif
4842}
4843
4844PP(pp_gprotoent)
4845{
693762b4 4846#if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
9cad6237 4847 dSP;
533c011a 4848 I32 which = PL_op->op_type;
a0d0e21e 4849 register char **elem;
301e8125 4850 register SV *sv;
dc45a647 4851#ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
1d88b533
JH		 4852 struct protoent *getprotobyname(Netdb_name_t);
4853 struct protoent *getprotobynumber(int);
4854 struct protoent *getprotoent(void);
8ac85365 4855#endif
a0d0e21e 4856 struct protoent *pent;
2d8e6c8d 4857 STRLEN n_a;
a0d0e21e 4858
edd309b7 4859 if (which == OP_GPBYNAME) {
e5c9fcd0 4860#ifdef HAS_GETPROTOBYNAME
edd309b7
JH		 4861 char* name = POPpbytex;
4862 pent = PerlSock_getprotobyname(name);
e5c9fcd0 4863#else
cea2e8a9 4864 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
e5c9fcd0 4865#endif
edd309b7
JH		 4866 }
4867 else if (which == OP_GPBYNUMBER) {
e5c9fcd0 4868#ifdef HAS_GETPROTOBYNUMBER
edd309b7
JH		 4869 int number = POPi;
4870 pent = PerlSock_getprotobynumber(number);
e5c9fcd0 4871#else
edd309b7 4872 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
e5c9fcd0 4873#endif
edd309b7 4874 }
a0d0e21e 4875 else
e5c9fcd0 4876#ifdef HAS_GETPROTOENT
6ad3d225 4877 pent = PerlSock_getprotoent();
e5c9fcd0 4878#else
cea2e8a9 4879 DIE(aTHX_ PL_no_sock_func, "getprotoent");
e5c9fcd0 4880#endif
a0d0e21e
LW		 4881
4882 EXTEND(SP, 3);
4883 if (GIMME != G_ARRAY) {
4884 PUSHs(sv = sv_newmortal());
4885 if (pent) {
4886 if (which == OP_GPBYNAME)
1e422769 4887 sv_setiv(sv, (IV)pent->p_proto);
a0d0e21e
LW		 4888 else
4889 sv_setpv(sv, pent->p_name);
4890 }
4891 RETURN;
4892 }
4893
4894 if (pent) {
3280af22 4895 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4896 sv_setpv(sv, pent->p_name);
3280af22 4897 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 4898 for (elem = pent->p_aliases; elem && *elem; elem++) {
a0d0e21e
LW		 4899 sv_catpv(sv, *elem);
4900 if (elem[1])
4901 sv_catpvn(sv, " ", 1);
4902 }
3280af22 4903 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4904 sv_setiv(sv, (IV)pent->p_proto);
a0d0e21e
LW		 4905 }
4906
4907 RETURN;
4908#else
cea2e8a9 4909 DIE(aTHX_ PL_no_sock_func, "getprotoent");
a0d0e21e
LW		 4910#endif
4911}
4912
4913PP(pp_gsbyname)
4914{
9ec75305 4915#ifdef HAS_GETSERVBYNAME
cea2e8a9 4916 return pp_gservent();
a0d0e21e 4917#else
cea2e8a9 4918 DIE(aTHX_ PL_no_sock_func, "getservbyname");
a0d0e21e
LW		 4919#endif
4920}
4921
4922PP(pp_gsbyport)
4923{
9ec75305 4924#ifdef HAS_GETSERVBYPORT
cea2e8a9 4925 return pp_gservent();
a0d0e21e 4926#else
cea2e8a9 4927 DIE(aTHX_ PL_no_sock_func, "getservbyport");
a0d0e21e
LW		 4928#endif
4929}
4930
4931PP(pp_gservent)
4932{
693762b4 4933#if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
9cad6237 4934 dSP;
533c011a 4935 I32 which = PL_op->op_type;
a0d0e21e
LW		 4936 register char **elem;
4937 register SV *sv;
dc45a647 4938#ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
1d88b533
JH		 4939 struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
4940 struct servent *getservbyport(int, Netdb_name_t);
4941 struct servent *getservent(void);
8ac85365 4942#endif
a0d0e21e 4943 struct servent *sent;
2d8e6c8d 4944 STRLEN n_a;
a0d0e21e
LW		 4945
4946 if (which == OP_GSBYNAME) {
dc45a647 4947#ifdef HAS_GETSERVBYNAME
42e0c139
AP		 4948 char *proto = POPpbytex;
4949 char *name = POPpbytex;
a0d0e21e
LW		 4950
4951 if (proto && !*proto)
4952 proto = Nullch;
4953
6ad3d225 4954 sent = PerlSock_getservbyname(name, proto);
dc45a647 4955#else
cea2e8a9 4956 DIE(aTHX_ PL_no_sock_func, "getservbyname");
dc45a647 4957#endif
a0d0e21e
LW		 4958 }
4959 else if (which == OP_GSBYPORT) {
dc45a647 4960#ifdef HAS_GETSERVBYPORT
42e0c139 4961 char *proto = POPpbytex;
eb160463 4962 unsigned short port = (unsigned short)POPu;
a0d0e21e 4963
36477c24 4964#ifdef HAS_HTONS
6ad3d225 4965 port = PerlSock_htons(port);
36477c24 4966#endif
6ad3d225 4967 sent = PerlSock_getservbyport(port, proto);
dc45a647 4968#else
cea2e8a9 4969 DIE(aTHX_ PL_no_sock_func, "getservbyport");
dc45a647 4970#endif
a0d0e21e
LW		 4971 }
4972 else
e5c9fcd0 4973#ifdef HAS_GETSERVENT
6ad3d225 4974 sent = PerlSock_getservent();
e5c9fcd0 4975#else
cea2e8a9 4976 DIE(aTHX_ PL_no_sock_func, "getservent");
e5c9fcd0 4977#endif
a0d0e21e
LW		 4978
4979 EXTEND(SP, 4);
4980 if (GIMME != G_ARRAY) {
4981 PUSHs(sv = sv_newmortal());
4982 if (sent) {
4983 if (which == OP_GSBYNAME) {
4984#ifdef HAS_NTOHS
6ad3d225 4985 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
a0d0e21e 4986#else
1e422769 4987 sv_setiv(sv, (IV)(sent->s_port));
a0d0e21e
LW		 4988#endif
4989 }
4990 else
4991 sv_setpv(sv, sent->s_name);
4992 }
4993 RETURN;
4994 }
4995
4996 if (sent) {
3280af22 4997 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4998 sv_setpv(sv, sent->s_name);
3280af22 4999 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 5000 for (elem = sent->s_aliases; elem && *elem; elem++) {
a0d0e21e
LW		 5001 sv_catpv(sv, *elem);
5002 if (elem[1])
5003 sv_catpvn(sv, " ", 1);
5004 }
3280af22 5005 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 5006#ifdef HAS_NTOHS
76e3520e 5007 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
a0d0e21e 5008#else
1e422769 5009 sv_setiv(sv, (IV)(sent->s_port));
a0d0e21e 5010#endif
3280af22 5011 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 5012 sv_setpv(sv, sent->s_proto);
5013 }
5014
5015 RETURN;
5016#else
cea2e8a9 5017 DIE(aTHX_ PL_no_sock_func, "getservent");
a0d0e21e
LW		 5018#endif
5019}
5020
5021PP(pp_shostent)
5022{
693762b4 5023#ifdef HAS_SETHOSTENT
9cad6237 5024 dSP;
76e3520e 5025 PerlSock_sethostent(TOPi);
a0d0e21e
LW		 5026 RETSETYES;
5027#else
cea2e8a9 5028 DIE(aTHX_ PL_no_sock_func, "sethostent");
a0d0e21e
LW		 5029#endif
5030}
5031
5032PP(pp_snetent)
5033{
693762b4 5034#ifdef HAS_SETNETENT
9cad6237 5035 dSP;
76e3520e 5036 PerlSock_setnetent(TOPi);
a0d0e21e
LW		 5037 RETSETYES;
5038#else
cea2e8a9 5039 DIE(aTHX_ PL_no_sock_func, "setnetent");
a0d0e21e
LW		 5040#endif
5041}
5042
5043PP(pp_sprotoent)
5044{
693762b4 5045#ifdef HAS_SETPROTOENT
9cad6237 5046 dSP;
76e3520e 5047 PerlSock_setprotoent(TOPi);
a0d0e21e
LW		 5048 RETSETYES;
5049#else
cea2e8a9 5050 DIE(aTHX_ PL_no_sock_func, "setprotoent");
a0d0e21e
LW		 5051#endif
5052}
5053
5054PP(pp_sservent)
5055{
693762b4 5056#ifdef HAS_SETSERVENT
9cad6237 5057 dSP;
76e3520e 5058 PerlSock_setservent(TOPi);
a0d0e21e
LW		 5059 RETSETYES;
5060#else
cea2e8a9 5061 DIE(aTHX_ PL_no_sock_func, "setservent");
a0d0e21e
LW		 5062#endif
5063}
5064
5065PP(pp_ehostent)
5066{
693762b4 5067#ifdef HAS_ENDHOSTENT
9cad6237 5068 dSP;
76e3520e 5069 PerlSock_endhostent();
924508f0 5070 EXTEND(SP,1);
a0d0e21e
LW		 5071 RETPUSHYES;
5072#else
cea2e8a9 5073 DIE(aTHX_ PL_no_sock_func, "endhostent");
a0d0e21e
LW		 5074#endif
5075}
5076
5077PP(pp_enetent)
5078{
693762b4 5079#ifdef HAS_ENDNETENT
9cad6237 5080 dSP;
76e3520e 5081 PerlSock_endnetent();
924508f0 5082 EXTEND(SP,1);
a0d0e21e
LW		 5083 RETPUSHYES;
5084#else
cea2e8a9 5085 DIE(aTHX_ PL_no_sock_func, "endnetent");
a0d0e21e
LW		 5086#endif
5087}
5088
5089PP(pp_eprotoent)
5090{
693762b4 5091#ifdef HAS_ENDPROTOENT
9cad6237 5092 dSP;
76e3520e 5093 PerlSock_endprotoent();
924508f0 5094 EXTEND(SP,1);
a0d0e21e
LW		 5095 RETPUSHYES;
5096#else
cea2e8a9 5097 DIE(aTHX_ PL_no_sock_func, "endprotoent");
a0d0e21e
LW		 5098#endif
5099}
5100
5101PP(pp_eservent)
5102{
693762b4 5103#ifdef HAS_ENDSERVENT
9cad6237 5104 dSP;
76e3520e 5105 PerlSock_endservent();
924508f0 5106 EXTEND(SP,1);
a0d0e21e
LW		 5107 RETPUSHYES;
5108#else
cea2e8a9 5109 DIE(aTHX_ PL_no_sock_func, "endservent");
a0d0e21e
LW		 5110#endif
5111}
5112
5113PP(pp_gpwnam)
5114{
5115#ifdef HAS_PASSWD
cea2e8a9 5116 return pp_gpwent();
a0d0e21e 5117#else
cea2e8a9 5118 DIE(aTHX_ PL_no_func, "getpwnam");
a0d0e21e
LW		 5119#endif
5120}
5121
5122PP(pp_gpwuid)
5123{
5124#ifdef HAS_PASSWD
cea2e8a9 5125 return pp_gpwent();
a0d0e21e 5126#else
cea2e8a9 5127 DIE(aTHX_ PL_no_func, "getpwuid");
a0d0e21e
LW		 5128#endif
5129}
5130
5131PP(pp_gpwent)
5132{
0994c4d0 5133#ifdef HAS_PASSWD
9cad6237 5134 dSP;
533c011a 5135 I32 which = PL_op->op_type;
a0d0e21e 5136 register SV *sv;
2d8e6c8d 5137 STRLEN n_a;
e3aefe8d 5138 struct passwd *pwent = NULL;
301e8125 5139 /*
bcf53261
JH		 5140 * We currently support only the SysV getsp* shadow password interface.
5141 * The interface is declared in <shadow.h> and often one needs to link
5142 * with -lsecurity or some such.
5143 * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5144 * (and SCO?)
5145 *
5146 * AIX getpwnam() is clever enough to return the encrypted password
5147 * only if the caller (euid?) is root.
5148 *
5149 * There are at least two other shadow password APIs. Many platforms
5150 * seem to contain more than one interface for accessing the shadow
5151 * password databases, possibly for compatibility reasons.
3813c136 5152 * The getsp*() is by far he simplest one, the other two interfaces
bcf53261
JH		 5153 * are much more complicated, but also very similar to each other.
5154 *
5155 * <sys/types.h>
5156 * <sys/security.h>
5157 * <prot.h>
5158 * struct pr_passwd *getprpw*();
5159 * The password is in
3813c136
JH		 5160 * char getprpw*(...).ufld.fd_encrypt[]
5161 * Mention HAS_GETPRPWNAM here so that Configure probes for it.
bcf53261
JH		 5162 *
5163 * <sys/types.h>
5164 * <sys/security.h>
5165 * <prot.h>
5166 * struct es_passwd *getespw*();
5167 * The password is in
5168 * char *(getespw*(...).ufld.fd_encrypt)
3813c136 5169 * Mention HAS_GETESPWNAM here so that Configure probes for it.
bcf53261 5170 *
3813c136 5171 * Mention I_PROT here so that Configure probes for it.
bcf53261
JH		 5172 *
5173 * In HP-UX for getprpw*() the manual page claims that one should include
5174 * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5175 * if one includes <shadow.h> as that includes <hpsecurity.h>,
5176 * and pp_sys.c already includes <shadow.h> if there is such.
3813c136
JH		 5177 *
5178 * Note that <sys/security.h> is already probed for, but currently
5179 * it is only included in special cases.
301e8125 5180 *
bcf53261
JH		 5181 * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5182 * be preferred interface, even though also the getprpw*() interface
5183 * is available) one needs to link with -lsecurity -ldb -laud -lm.
3813c136
JH		 5184 * One also needs to call set_auth_parameters() in main() before
5185 * doing anything else, whether one is using getespw*() or getprpw*().
5186 *
5187 * Note that accessing the shadow databases can be magnitudes
5188 * slower than accessing the standard databases.
bcf53261
JH		 5189 *
5190 * --jhi
5191 */
a0d0e21e 5192
e3aefe8d
JH		 5193 switch (which) {
5194 case OP_GPWNAM:
edd309b7
JH		 5195 {
5196 char* name = POPpbytex;
5197 pwent = getpwnam(name);
5198 }
5199 break;
e3aefe8d 5200 case OP_GPWUID:
edd309b7
JH		 5201 {
5202 Uid_t uid = POPi;
5203 pwent = getpwuid(uid);
5204 }
e3aefe8d
JH		 5205 break;
5206 case OP_GPWENT:
1883634f 5207# ifdef HAS_GETPWENT
e3aefe8d 5208 pwent = getpwent();
faea9016
IRC		 5209#ifdef POSIX_BC /* In some cases pw_passwd has invalid addresses */
5210 if (pwent) pwent = getpwnam(pwent->pw_name);
5211#endif
1883634f 5212# else
a45d1c96 5213 DIE(aTHX_ PL_no_func, "getpwent");
1883634f 5214# endif
e3aefe8d
JH		 5215 break;
5216 }
8c0bfa08 5217
a0d0e21e
LW		 5218 EXTEND(SP, 10);
5219 if (GIMME != G_ARRAY) {
5220 PUSHs(sv = sv_newmortal());
5221 if (pwent) {
5222 if (which == OP_GPWNAM)
1883634f 5223# if Uid_t_sign <= 0
1e422769 5224 sv_setiv(sv, (IV)pwent->pw_uid);
1883634f 5225# else
23dcd6c8 5226 sv_setuv(sv, (UV)pwent->pw_uid);
1883634f 5227# endif
a0d0e21e
LW		 5228 else
5229 sv_setpv(sv, pwent->pw_name);
5230 }
5231 RETURN;
5232 }
5233
5234 if (pwent) {
3280af22 5235 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 5236 sv_setpv(sv, pwent->pw_name);
6ee623d5 5237
3280af22 5238 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
3813c136
JH		 5239 SvPOK_off(sv);
5240 /* If we have getspnam(), we try to dig up the shadow
5241 * password. If we are underprivileged, the shadow
5242 * interface will set the errno to EACCES or similar,
5243 * and return a null pointer. If this happens, we will
5244 * use the dummy password (usually "*" or "x") from the
5245 * standard password database.
5246 *
5247 * In theory we could skip the shadow call completely
5248 * if euid != 0 but in practice we cannot know which
5249 * security measures are guarding the shadow databases
5250 * on a random platform.
5251 *
5252 * Resist the urge to use additional shadow interfaces.
5253 * Divert the urge to writing an extension instead.
5254 *
5255 * --jhi */
e3aefe8d 5256# ifdef HAS_GETSPNAM
3813c136
JH		 5257 {
5258 struct spwd *spwent;
5259 int saverrno; /* Save and restore errno so that
5260 * underprivileged attempts seem
5261 * to have never made the unsccessful
5262 * attempt to retrieve the shadow password. */
5263
5264 saverrno = errno;
5265 spwent = getspnam(pwent->pw_name);
5266 errno = saverrno;
5267 if (spwent && spwent->sp_pwdp)
5268 sv_setpv(sv, spwent->sp_pwdp);
5269 }
f1066039 5270# endif
e020c87d 5271# ifdef PWPASSWD
3813c136
JH		 5272 if (!SvPOK(sv)) /* Use the standard password, then. */
5273 sv_setpv(sv, pwent->pw_passwd);
e020c87d 5274# endif
3813c136 5275
1883634f 5276# ifndef INCOMPLETE_TAINTS
3813c136
JH		 5277 /* passwd is tainted because user himself can diddle with it.
5278 * admittedly not much and in a very limited way, but nevertheless. */
2959b6e3 5279 SvTAINTED_on(sv);
1883634f 5280# endif
6ee623d5 5281
3280af22 5282 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1883634f 5283# if Uid_t_sign <= 0
1e422769 5284 sv_setiv(sv, (IV)pwent->pw_uid);
1883634f 5285# else
23dcd6c8 5286 sv_setuv(sv, (UV)pwent->pw_uid);
1883634f 5287# endif
6ee623d5 5288
3280af22 5289 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1883634f 5290# if Uid_t_sign <= 0
1e422769 5291 sv_setiv(sv, (IV)pwent->pw_gid);
1883634f 5292# else
23dcd6c8 5293 sv_setuv(sv, (UV)pwent->pw_gid);
1883634f 5294# endif
3813c136
JH		 5295 /* pw_change, pw_quota, and pw_age are mutually exclusive--
5296 * because of the poor interface of the Perl getpw*(),
5297 * not because there's some standard/convention saying so.
5298 * A better interface would have been to return a hash,
5299 * but we are accursed by our history, alas. --jhi. */
3280af22 5300 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1883634f 5301# ifdef PWCHANGE
1e422769 5302 sv_setiv(sv, (IV)pwent->pw_change);
6ee623d5 5303# else
1883634f
JH		 5304# ifdef PWQUOTA
5305 sv_setiv(sv, (IV)pwent->pw_quota);
5306# else
a1757be1 5307# ifdef PWAGE
a0d0e21e 5308 sv_setpv(sv, pwent->pw_age);
a1757be1 5309# endif
6ee623d5
GS		 5310# endif
5311# endif
6ee623d5 5312
3813c136
JH		 5313 /* pw_class and pw_comment are mutually exclusive--.
5314 * see the above note for pw_change, pw_quota, and pw_age. */
3280af22 5315 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1883634f 5316# ifdef PWCLASS
a0d0e21e 5317 sv_setpv(sv, pwent->pw_class);
1883634f
JH		 5318# else
5319# ifdef PWCOMMENT
a0d0e21e 5320 sv_setpv(sv, pwent->pw_comment);
1883634f 5321# endif
6ee623d5 5322# endif
6ee623d5 5323
3280af22 5324 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1883634f 5325# ifdef PWGECOS
a0d0e21e 5326 sv_setpv(sv, pwent->pw_gecos);
1883634f
JH		 5327# endif
5328# ifndef INCOMPLETE_TAINTS
d2719217 5329 /* pw_gecos is tainted because user himself can diddle with it. */
fb73857a 5330 SvTAINTED_on(sv);
1883634f 5331# endif
6ee623d5 5332
3280af22 5333 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 5334 sv_setpv(sv, pwent->pw_dir);
6ee623d5 5335
3280af22 5336 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 5337 sv_setpv(sv, pwent->pw_shell);
1883634f 5338# ifndef INCOMPLETE_TAINTS
4602f195
JH		 5339 /* pw_shell is tainted because user himself can diddle with it. */
5340 SvTAINTED_on(sv);
1883634f 5341# endif
6ee623d5 5342
1883634f 5343# ifdef PWEXPIRE
6b88bc9c 5344 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 5345 sv_setiv(sv, (IV)pwent->pw_expire);
1883634f 5346# endif
a0d0e21e
LW		 5347 }
5348 RETURN;
5349#else
cea2e8a9 5350 DIE(aTHX_ PL_no_func, "getpwent");
a0d0e21e
LW		 5351#endif
5352}
5353
5354PP(pp_spwent)
5355{
d493b042 5356#if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
9cad6237 5357 dSP;
a0d0e21e
LW		 5358 setpwent();
5359 RETPUSHYES;
5360#else
cea2e8a9 5361 DIE(aTHX_ PL_no_func, "setpwent");
a0d0e21e
LW		 5362#endif
5363}
5364
5365PP(pp_epwent)
5366{
28e8609d 5367#if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
9cad6237 5368 dSP;
a0d0e21e
LW		 5369 endpwent();
5370 RETPUSHYES;
5371#else
cea2e8a9 5372 DIE(aTHX_ PL_no_func, "endpwent");
a0d0e21e
LW		 5373#endif
5374}
5375
5376PP(pp_ggrnam)
5377{
5378#ifdef HAS_GROUP
cea2e8a9 5379 return pp_ggrent();
a0d0e21e 5380#else
cea2e8a9 5381 DIE(aTHX_ PL_no_func, "getgrnam");
a0d0e21e
LW		 5382#endif
5383}
5384
5385PP(pp_ggrgid)
5386{
5387#ifdef HAS_GROUP
cea2e8a9 5388 return pp_ggrent();
a0d0e21e 5389#else
cea2e8a9 5390 DIE(aTHX_ PL_no_func, "getgrgid");
a0d0e21e
LW		 5391#endif
5392}
5393
5394PP(pp_ggrent)
5395{
0994c4d0 5396#ifdef HAS_GROUP
9cad6237 5397 dSP;
533c011a 5398 I32 which = PL_op->op_type;
a0d0e21e
LW		 5399 register char **elem;
5400 register SV *sv;
5401 struct group *grent;
2d8e6c8d 5402 STRLEN n_a;
a0d0e21e 5403
edd309b7
JH		 5404 if (which == OP_GGRNAM) {
5405 char* name = POPpbytex;
5406 grent = (struct group *)getgrnam(name);
5407 }
5408 else if (which == OP_GGRGID) {
5409 Gid_t gid = POPi;
5410 grent = (struct group *)getgrgid(gid);
5411 }
a0d0e21e 5412 else
0994c4d0 5413#ifdef HAS_GETGRENT
a0d0e21e 5414 grent = (struct group *)getgrent();
0994c4d0
JH		 5415#else
5416 DIE(aTHX_ PL_no_func, "getgrent");
5417#endif
a0d0e21e
LW		 5418
5419 EXTEND(SP, 4);
5420 if (GIMME != G_ARRAY) {
5421 PUSHs(sv = sv_newmortal());
5422 if (grent) {
5423 if (which == OP_GGRNAM)
1e422769 5424 sv_setiv(sv, (IV)grent->gr_gid);
a0d0e21e
LW		 5425 else
5426 sv_setpv(sv, grent->gr_name);
5427 }
5428 RETURN;
5429 }
5430
5431 if (grent) {
3280af22 5432 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 5433 sv_setpv(sv, grent->gr_name);
28e8609d 5434
3280af22 5435 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
28e8609d 5436#ifdef GRPASSWD
a0d0e21e 5437 sv_setpv(sv, grent->gr_passwd);
28e8609d
JH		 5438#endif
5439
3280af22 5440 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 5441 sv_setiv(sv, (IV)grent->gr_gid);
28e8609d 5442
5b56e7c5 5443#if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
3280af22 5444 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
3d7e8424
JH		 5445 /* In UNICOS/mk (_CRAYMPP) the multithreading
5446 * versions (getgrnam_r, getgrgid_r)
5447 * seem to return an illegal pointer
5448 * as the group members list, gr_mem.
5449 * getgrent() doesn't even have a _r version
5450 * but the gr_mem is poisonous anyway.
5451 * So yes, you cannot get the list of group
5452 * members if building multithreaded in UNICOS/mk. */
c90c0ff4 5453 for (elem = grent->gr_mem; elem && *elem; elem++) {
a0d0e21e
LW		 5454 sv_catpv(sv, *elem);
5455 if (elem[1])
5456 sv_catpvn(sv, " ", 1);
5457 }
3d7e8424 5458#endif
a0d0e21e
LW		 5459 }
5460
5461 RETURN;
5462#else
cea2e8a9 5463 DIE(aTHX_ PL_no_func, "getgrent");
a0d0e21e
LW		 5464#endif
5465}
5466
5467PP(pp_sgrent)
5468{
28e8609d 5469#if defined(HAS_GROUP) && defined(HAS_SETGRENT)
9cad6237 5470 dSP;
a0d0e21e
LW		 5471 setgrent();
5472 RETPUSHYES;
5473#else
cea2e8a9 5474 DIE(aTHX_ PL_no_func, "setgrent");
a0d0e21e
LW		 5475#endif
5476}
5477
5478PP(pp_egrent)
5479{
28e8609d 5480#if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
9cad6237 5481 dSP;
a0d0e21e
LW		 5482 endgrent();
5483 RETPUSHYES;
5484#else
cea2e8a9 5485 DIE(aTHX_ PL_no_func, "endgrent");
a0d0e21e
LW		 5486#endif
5487}
5488
5489PP(pp_getlogin)
5490{
a0d0e21e 5491#ifdef HAS_GETLOGIN
9cad6237 5492 dSP; dTARGET;
a0d0e21e
LW		 5493 char *tmps;
5494 EXTEND(SP, 1);
76e3520e 5495 if (!(tmps = PerlProc_getlogin()))
a0d0e21e
LW		 5496 RETPUSHUNDEF;
5497 PUSHp(tmps, strlen(tmps));
5498 RETURN;
5499#else
cea2e8a9 5500 DIE(aTHX_ PL_no_func, "getlogin");
a0d0e21e
LW		 5501#endif
5502}
5503
5504/* Miscellaneous. */
5505
5506PP(pp_syscall)
5507{
d2719217 5508#ifdef HAS_SYSCALL
39644a26 5509 dSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW		 5510 register I32 items = SP - MARK;
5511 unsigned long a[20];
5512 register I32 i = 0;
5513 I32 retval = -1;
2d8e6c8d 5514 STRLEN n_a;
a0d0e21e 5515
3280af22 5516 if (PL_tainting) {
a0d0e21e 5517 while (++MARK <= SP) {
bbce6d69 5518 if (SvTAINTED(*MARK)) {
5519 TAINT;
5520 break;
5521 }
a0d0e21e
LW		 5522 }
5523 MARK = ORIGMARK;
5524 TAINT_PROPER("syscall");
5525 }
5526
5527 /* This probably won't work on machines where sizeof(long) != sizeof(int)
5528 * or where sizeof(long) != sizeof(char*). But such machines will
5529 * not likely have syscall implemented either, so who cares?
5530 */
5531 while (++MARK <= SP) {
5532 if (SvNIOK(*MARK) || !i)
5533 a[i++] = SvIV(*MARK);
3280af22 5534 else if (*MARK == &PL_sv_undef)
748a9306 5535 a[i++] = 0;
301e8125 5536 else
2d8e6c8d 5537 a[i++] = (unsigned long)SvPV_force(*MARK, n_a);
a0d0e21e
LW		 5538 if (i > 15)
5539 break;
5540 }
5541 switch (items) {
5542 default:
cea2e8a9 5543 DIE(aTHX_ "Too many args to syscall");
a0d0e21e 5544 case 0:
cea2e8a9 5545 DIE(aTHX_ "Too few args to syscall");
a0d0e21e
LW		 5546 case 1:
5547 retval = syscall(a[0]);
5548 break;
5549 case 2:
5550 retval = syscall(a[0],a[1]);
5551 break;
5552 case 3:
5553 retval = syscall(a[0],a[1],a[2]);
5554 break;
5555 case 4:
5556 retval = syscall(a[0],a[1],a[2],a[3]);
5557 break;
5558 case 5:
5559 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5560 break;
5561 case 6:
5562 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5563 break;
5564 case 7:
5565 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5566 break;
5567 case 8:
5568 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5569 break;
5570#ifdef atarist
5571 case 9:
5572 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5573 break;
5574 case 10:
5575 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
5576 break;
5577 case 11:
5578 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5579 a[10]);
5580 break;
5581 case 12:
5582 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5583 a[10],a[11]);
5584 break;
5585 case 13:
5586 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5587 a[10],a[11],a[12]);
5588 break;
5589 case 14:
5590 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5591 a[10],a[11],a[12],a[13]);
5592 break;
5593#endif /* atarist */
5594 }
5595 SP = ORIGMARK;
5596 PUSHi(retval);
5597 RETURN;
5598#else
cea2e8a9 5599 DIE(aTHX_ PL_no_func, "syscall");
a0d0e21e
LW		 5600#endif
5601}
5602
ff68c719 5603#ifdef FCNTL_EMULATE_FLOCK
301e8125 5604
ff68c719 5605/* XXX Emulate flock() with fcntl().
5606 What's really needed is a good file locking module.
5607*/
5608
cea2e8a9
GS		 5609static int
5610fcntl_emulate_flock(int fd, int operation)
ff68c719 5611{
5612 struct flock flock;
301e8125 5613
ff68c719 5614 switch (operation & ~LOCK_NB) {
5615 case LOCK_SH:
5616 flock.l_type = F_RDLCK;
5617 break;
5618 case LOCK_EX:
5619 flock.l_type = F_WRLCK;
5620 break;
5621 case LOCK_UN:
5622 flock.l_type = F_UNLCK;
5623 break;
5624 default:
5625 errno = EINVAL;
5626 return -1;
5627 }
5628 flock.l_whence = SEEK_SET;
d9b3e12d 5629 flock.l_start = flock.l_len = (Off_t)0;
301e8125 5630
ff68c719 5631 return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5632}
5633
5634#endif /* FCNTL_EMULATE_FLOCK */
5635
5636#ifdef LOCKF_EMULATE_FLOCK
16d20bd9
AD		 5637
5638/* XXX Emulate flock() with lockf(). This is just to increase
5639 portability of scripts. The calls are not completely
5640 interchangeable. What's really needed is a good file
5641 locking module.
5642*/
5643
76c32331 5644/* The lockf() constants might have been defined in <unistd.h>.
5645 Unfortunately, <unistd.h> causes troubles on some mixed
5646 (BSD/POSIX) systems, such as SunOS 4.1.3.
16d20bd9
AD		 5647
5648 Further, the lockf() constants aren't POSIX, so they might not be
5649 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
5650 just stick in the SVID values and be done with it. Sigh.
5651*/
5652
5653# ifndef F_ULOCK
5654# define F_ULOCK 0 /* Unlock a previously locked region */
5655# endif
5656# ifndef F_LOCK
5657# define F_LOCK 1 /* Lock a region for exclusive use */
5658# endif
5659# ifndef F_TLOCK
5660# define F_TLOCK 2 /* Test and lock a region for exclusive use */
5661# endif
5662# ifndef F_TEST
5663# define F_TEST 3 /* Test a region for other processes locks */
5664# endif
5665
cea2e8a9
GS		 5666static int
5667lockf_emulate_flock(int fd, int operation)
16d20bd9
AD		 5668{
5669 int i;
84902520
TB		 5670 int save_errno;
5671 Off_t pos;
5672
5673 /* flock locks entire file so for lockf we need to do the same */
5674 save_errno = errno;
6ad3d225 5675 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
84902520 5676 if (pos > 0) /* is seekable and needs to be repositioned */
6ad3d225 5677 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
08b714dd 5678 pos = -1; /* seek failed, so don't seek back afterwards */
84902520
TB		 5679 errno = save_errno;
5680
16d20bd9
AD		 5681 switch (operation) {
5682
5683 /* LOCK_SH - get a shared lock */
5684 case LOCK_SH:
5685 /* LOCK_EX - get an exclusive lock */
5686 case LOCK_EX:
5687 i = lockf (fd, F_LOCK, 0);
5688 break;
5689
5690 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5691 case LOCK_SH|LOCK_NB:
5692 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5693 case LOCK_EX|LOCK_NB:
5694 i = lockf (fd, F_TLOCK, 0);
5695 if (i == -1)
5696 if ((errno == EAGAIN) || (errno == EACCES))
5697 errno = EWOULDBLOCK;
5698 break;
5699
ff68c719 5700 /* LOCK_UN - unlock (non-blocking is a no-op) */
16d20bd9 5701 case LOCK_UN:
ff68c719 5702 case LOCK_UN|LOCK_NB:
16d20bd9
AD		 5703 i = lockf (fd, F_ULOCK, 0);
5704 break;
5705
5706 /* Default - can't decipher operation */
5707 default:
5708 i = -1;
5709 errno = EINVAL;
5710 break;
5711 }
84902520
TB		 5712
5713 if (pos > 0) /* need to restore position of the handle */
6ad3d225 5714 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
84902520 5715
16d20bd9
AD		 5716 return (i);
5717}
ff68c719 5718
5719#endif /* LOCKF_EMULATE_FLOCK */
Unnamed repository; edit this file 'description' to name the repository.