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