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