This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
some additions for makefiles for win32 (for perl@7674)
[perl5.git] / pp_sys.c
CommitLineData
a0d0e21e
LW
1/* pp_sys.c
2 *
cb50131a 3 * Copyright (c) 1991-2000, 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
76c32331
PP
38/* XXX If this causes problems, set i_unistd=undef in the hint file. */
39#ifdef I_UNISTD
40# include <unistd.h>
41#endif
42
301e8125
NIS
43#ifdef HAS_SYSCALL
44#ifdef __cplusplus
8ac85365
NIS
45extern "C" int syscall(unsigned long,...);
46#endif
47#endif
48
76c32331
PP
49#ifdef I_SYS_WAIT
50# include <sys/wait.h>
51#endif
52
53#ifdef I_SYS_RESOURCE
54# include <sys/resource.h>
16d20bd9 55#endif
a0d0e21e
LW
56
57#if defined(HAS_SOCKET) && !defined(VMS) /* VMS handles sockets via vmsish.h */
58# include <sys/socket.h>
29209bc5 59# if defined(USE_SOCKS) && defined(I_SOCKS)
f269dd06
JH
60# if !defined(INCLUDE_PROTOTYPES)
61# define INCLUDE_PROTOTYPES /* for <socks.h> */
62# define PERL_SOCKS_NEED_PROTOTYPES
63# endif
86959918 64# include <socks.h>
f269dd06
JH
65# ifdef PERL_SOCKS_NEED_PROTOTYPES /* keep cpp space clean */
66# undef INCLUDE_PROTOTYPES
67# undef PERL_SOCKS_NEED_PROTOTYPES
68# endif
301e8125 69# endif
3fd537d4
JH
70# ifdef I_NETDB
71# include <netdb.h>
72# endif
a0d0e21e
LW
73# ifndef ENOTSOCK
74# ifdef I_NET_ERRNO
75# include <net/errno.h>
76# endif
77# endif
78#endif
79
80#ifdef HAS_SELECT
81#ifdef I_SYS_SELECT
a0d0e21e
LW
82#include <sys/select.h>
83#endif
84#endif
a0d0e21e 85
dc45a647
MB
86/* XXX Configure test needed.
87 h_errno might not be a simple 'int', especially for multi-threaded
5ff3f7a4
GS
88 applications, see "extern int errno in perl.h". Creating such
89 a test requires taking into account the differences between
90 compiling multithreaded and singlethreaded ($ccflags et al).
91 HOST_NOT_FOUND is typically defined in <netdb.h>.
dc45a647 92*/
cb50131a 93#if defined(HOST_NOT_FOUND) && !defined(h_errno) && !defined(__CYGWIN__)
a0d0e21e
LW
94extern int h_errno;
95#endif
96
97#ifdef HAS_PASSWD
98# ifdef I_PWD
99# include <pwd.h>
100# else
20ce7b12
GS
101 struct passwd *getpwnam (char *);
102 struct passwd *getpwuid (Uid_t);
a0d0e21e 103# endif
28e8609d 104# ifdef HAS_GETPWENT
20ce7b12 105 struct passwd *getpwent (void);
28e8609d 106# endif
a0d0e21e
LW
107#endif
108
109#ifdef HAS_GROUP
110# ifdef I_GRP
111# include <grp.h>
112# else
20ce7b12
GS
113 struct group *getgrnam (char *);
114 struct group *getgrgid (Gid_t);
a0d0e21e 115# endif
28e8609d 116# ifdef HAS_GETGRENT
20ce7b12 117 struct group *getgrent (void);
28e8609d 118# endif
a0d0e21e
LW
119#endif
120
121#ifdef I_UTIME
3730b96e 122# if defined(_MSC_VER) || defined(__MINGW32__)
3fe9a6f1
PP
123# include <sys/utime.h>
124# else
125# include <utime.h>
126# endif
a0d0e21e 127#endif
a0d0e21e 128
54310121
PP
129/* Put this after #includes because fork and vfork prototypes may conflict. */
130#ifndef HAS_VFORK
131# define vfork fork
132#endif
133
cbdc8872 134#ifdef HAS_CHSIZE
cd52b7b2
PP
135# ifdef my_chsize /* Probably #defined to Perl_my_chsize in embed.h */
136# undef my_chsize
137# endif
6ad3d225 138# define my_chsize PerlLIO_chsize
cbdc8872
PP
139#endif
140
ff68c719
PP
141#ifdef HAS_FLOCK
142# define FLOCK flock
143#else /* no flock() */
144
36477c24
PP
145 /* fcntl.h might not have been included, even if it exists, because
146 the current Configure only sets I_FCNTL if it's needed to pick up
147 the *_OK constants. Make sure it has been included before testing
148 the fcntl() locking constants. */
149# if defined(HAS_FCNTL) && !defined(I_FCNTL)
150# include <fcntl.h>
151# endif
152
9d9004a9 153# if defined(HAS_FCNTL) && defined(FCNTL_CAN_LOCK)
ff68c719
PP
154# define FLOCK fcntl_emulate_flock
155# define FCNTL_EMULATE_FLOCK
156# else /* no flock() or fcntl(F_SETLK,...) */
157# ifdef HAS_LOCKF
158# define FLOCK lockf_emulate_flock
159# define LOCKF_EMULATE_FLOCK
160# endif /* lockf */
161# endif /* no flock() or fcntl(F_SETLK,...) */
162
163# ifdef FLOCK
20ce7b12 164 static int FLOCK (int, int);
ff68c719
PP
165
166 /*
167 * These are the flock() constants. Since this sytems doesn't have
168 * flock(), the values of the constants are probably not available.
169 */
170# ifndef LOCK_SH
171# define LOCK_SH 1
172# endif
173# ifndef LOCK_EX
174# define LOCK_EX 2
175# endif
176# ifndef LOCK_NB
177# define LOCK_NB 4
178# endif
179# ifndef LOCK_UN
180# define LOCK_UN 8
181# endif
182# endif /* emulating flock() */
183
184#endif /* no flock() */
55497cff 185
85ab1d1d
JH
186#define ZBTLEN 10
187static char zero_but_true[ZBTLEN + 1] = "0 but true";
188
5ff3f7a4
GS
189#if defined(I_SYS_ACCESS) && !defined(R_OK)
190# include <sys/access.h>
191#endif
192
c529f79d
CB
193#if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
194# define FD_CLOEXEC 1 /* NeXT needs this */
195#endif
196
5ff3f7a4
GS
197#undef PERL_EFF_ACCESS_R_OK /* EFFective uid/gid ACCESS R_OK */
198#undef PERL_EFF_ACCESS_W_OK
199#undef PERL_EFF_ACCESS_X_OK
200
201/* F_OK unused: if stat() cannot find it... */
202
203#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_ACCESS) && defined(EFF_ONLY_OK) && !defined(NO_EFF_ONLY_OK)
c955f117 204 /* Digital UNIX (when the EFF_ONLY_OK gets fixed), UnixWare */
5ff3f7a4
GS
205# define PERL_EFF_ACCESS_R_OK(p) (access((p), R_OK | EFF_ONLY_OK))
206# define PERL_EFF_ACCESS_W_OK(p) (access((p), W_OK | EFF_ONLY_OK))
207# define PERL_EFF_ACCESS_X_OK(p) (access((p), X_OK | EFF_ONLY_OK))
208#endif
209
210#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_EACCESS)
3813c136 211# ifdef I_SYS_SECURITY
5ff3f7a4
GS
212# include <sys/security.h>
213# endif
c955f117
JH
214# ifdef ACC_SELF
215 /* HP SecureWare */
216# define PERL_EFF_ACCESS_R_OK(p) (eaccess((p), R_OK, ACC_SELF))
217# define PERL_EFF_ACCESS_W_OK(p) (eaccess((p), W_OK, ACC_SELF))
218# define PERL_EFF_ACCESS_X_OK(p) (eaccess((p), X_OK, ACC_SELF))
219# else
220 /* SCO */
221# define PERL_EFF_ACCESS_R_OK(p) (eaccess((p), R_OK))
222# define PERL_EFF_ACCESS_W_OK(p) (eaccess((p), W_OK))
223# define PERL_EFF_ACCESS_X_OK(p) (eaccess((p), X_OK))
224# endif
5ff3f7a4
GS
225#endif
226
227#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_ACCESSX) && defined(ACC_SELF)
c955f117 228 /* AIX */
5ff3f7a4
GS
229# define PERL_EFF_ACCESS_R_OK(p) (accessx((p), R_OK, ACC_SELF))
230# define PERL_EFF_ACCESS_W_OK(p) (accessx((p), W_OK, ACC_SELF))
231# define PERL_EFF_ACCESS_X_OK(p) (accessx((p), X_OK, ACC_SELF))
232#endif
233
327c3667
GS
234#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_ACCESS) \
235 && (defined(HAS_SETREUID) || defined(HAS_SETRESUID) \
236 || defined(HAS_SETREGID) || defined(HAS_SETRESGID))
5ff3f7a4 237/* The Hard Way. */
327c3667 238STATIC int
7f4774ae 239S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
ba106d47 240{
5ff3f7a4
GS
241 Uid_t ruid = getuid();
242 Uid_t euid = geteuid();
243 Gid_t rgid = getgid();
244 Gid_t egid = getegid();
245 int res;
246
146174a9 247 LOCK_CRED_MUTEX;
5ff3f7a4 248#if !defined(HAS_SETREUID) && !defined(HAS_SETRESUID)
cea2e8a9 249 Perl_croak(aTHX_ "switching effective uid is not implemented");
5ff3f7a4
GS
250#else
251#ifdef HAS_SETREUID
252 if (setreuid(euid, ruid))
253#else
254#ifdef HAS_SETRESUID
255 if (setresuid(euid, ruid, (Uid_t)-1))
256#endif
257#endif
cea2e8a9 258 Perl_croak(aTHX_ "entering effective uid failed");
5ff3f7a4
GS
259#endif
260
261#if !defined(HAS_SETREGID) && !defined(HAS_SETRESGID)
cea2e8a9 262 Perl_croak(aTHX_ "switching effective gid is not implemented");
5ff3f7a4
GS
263#else
264#ifdef HAS_SETREGID
265 if (setregid(egid, rgid))
266#else
267#ifdef HAS_SETRESGID
268 if (setresgid(egid, rgid, (Gid_t)-1))
269#endif
270#endif
cea2e8a9 271 Perl_croak(aTHX_ "entering effective gid failed");
5ff3f7a4
GS
272#endif
273
274 res = access(path, mode);
275
276#ifdef HAS_SETREUID
277 if (setreuid(ruid, euid))
278#else
279#ifdef HAS_SETRESUID
280 if (setresuid(ruid, euid, (Uid_t)-1))
281#endif
282#endif
cea2e8a9 283 Perl_croak(aTHX_ "leaving effective uid failed");
5ff3f7a4
GS
284
285#ifdef HAS_SETREGID
286 if (setregid(rgid, egid))
287#else
288#ifdef HAS_SETRESGID
289 if (setresgid(rgid, egid, (Gid_t)-1))
290#endif
291#endif
cea2e8a9 292 Perl_croak(aTHX_ "leaving effective gid failed");
146174a9 293 UNLOCK_CRED_MUTEX;
5ff3f7a4
GS
294
295 return res;
296}
297# define PERL_EFF_ACCESS_R_OK(p) (emulate_eaccess((p), R_OK))
298# define PERL_EFF_ACCESS_W_OK(p) (emulate_eaccess((p), W_OK))
299# define PERL_EFF_ACCESS_X_OK(p) (emulate_eaccess((p), X_OK))
300#endif
301
302#if !defined(PERL_EFF_ACCESS_R_OK)
327c3667 303STATIC int
7f4774ae 304S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
ba106d47 305{
cea2e8a9 306 Perl_croak(aTHX_ "switching effective uid is not implemented");
5ff3f7a4
GS
307 /*NOTREACHED*/
308 return -1;
309}
310#endif
311
a0d0e21e
LW
312PP(pp_backtick)
313{
4e35701f 314 djSP; dTARGET;
760ac839 315 PerlIO *fp;
2d8e6c8d
GS
316 STRLEN n_a;
317 char *tmps = POPpx;
54310121 318 I32 gimme = GIMME_V;
16fe6d59 319 char *mode = "r";
54310121 320
a0d0e21e 321 TAINT_PROPER("``");
16fe6d59
GS
322 if (PL_op->op_private & OPpOPEN_IN_RAW)
323 mode = "rb";
324 else if (PL_op->op_private & OPpOPEN_IN_CRLF)
325 mode = "rt";
326 fp = PerlProc_popen(tmps, mode);
a0d0e21e 327 if (fp) {
54310121 328 if (gimme == G_VOID) {
96827780
MB
329 char tmpbuf[256];
330 while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0)
54310121
PP
331 /*SUPPRESS 530*/
332 ;
333 }
334 else if (gimme == G_SCALAR) {
aa689395 335 sv_setpv(TARG, ""); /* note that this preserves previous buffer */
a0d0e21e
LW
336 while (sv_gets(TARG, fp, SvCUR(TARG)) != Nullch)
337 /*SUPPRESS 530*/
338 ;
339 XPUSHs(TARG);
aa689395 340 SvTAINTED_on(TARG);
a0d0e21e
LW
341 }
342 else {
343 SV *sv;
344
345 for (;;) {
8d6dde3e 346 sv = NEWSV(56, 79);
a0d0e21e
LW
347 if (sv_gets(sv, fp, 0) == Nullch) {
348 SvREFCNT_dec(sv);
349 break;
350 }
351 XPUSHs(sv_2mortal(sv));
352 if (SvLEN(sv) - SvCUR(sv) > 20) {
353 SvLEN_set(sv, SvCUR(sv)+1);
354 Renew(SvPVX(sv), SvLEN(sv), char);
355 }
aa689395 356 SvTAINTED_on(sv);
a0d0e21e
LW
357 }
358 }
6ad3d225 359 STATUS_NATIVE_SET(PerlProc_pclose(fp));
aa689395 360 TAINT; /* "I believe that this is not gratuitous!" */
a0d0e21e
LW
361 }
362 else {
f86702cc 363 STATUS_NATIVE_SET(-1);
54310121 364 if (gimme == G_SCALAR)
a0d0e21e
LW
365 RETPUSHUNDEF;
366 }
367
368 RETURN;
369}
370
371PP(pp_glob)
372{
373 OP *result;
f5284f61
IZ
374 tryAMAGICunTARGET(iter, -1);
375
71686f12
GS
376 /* Note that we only ever get here if File::Glob fails to load
377 * without at the same time croaking, for some reason, or if
378 * perl was built with PERL_EXTERNAL_GLOB */
379
a0d0e21e 380 ENTER;
a0d0e21e 381
c90c0ff4 382#ifndef VMS
3280af22 383 if (PL_tainting) {
7bac28a0
PP
384 /*
385 * The external globbing program may use things we can't control,
386 * so for security reasons we must assume the worst.
387 */
388 TAINT;
22c35a8c 389 taint_proper(PL_no_security, "glob");
7bac28a0 390 }
c90c0ff4 391#endif /* !VMS */
7bac28a0 392
3280af22
NIS
393 SAVESPTR(PL_last_in_gv); /* We don't want this to be permanent. */
394 PL_last_in_gv = (GV*)*PL_stack_sp--;
a0d0e21e 395
3280af22 396 SAVESPTR(PL_rs); /* This is not permanent, either. */
79cb57f6 397 PL_rs = sv_2mortal(newSVpvn("\000", 1));
c07a80fd
PP
398#ifndef DOSISH
399#ifndef CSH
6b88bc9c 400 *SvPVX(PL_rs) = '\n';
a0d0e21e 401#endif /* !CSH */
55497cff 402#endif /* !DOSISH */
c07a80fd 403
a0d0e21e
LW
404 result = do_readline();
405 LEAVE;
406 return result;
407}
408
15e52e56 409#if 0 /* XXX never used! */
a0d0e21e
LW
410PP(pp_indread)
411{
2d8e6c8d
GS
412 STRLEN n_a;
413 PL_last_in_gv = gv_fetchpv(SvPVx(GvSV((GV*)(*PL_stack_sp--)), n_a), TRUE,SVt_PVIO);
a0d0e21e
LW
414 return do_readline();
415}
15e52e56 416#endif
a0d0e21e
LW
417
418PP(pp_rcatline)
419{
146174a9 420 PL_last_in_gv = cGVOP_gv;
a0d0e21e
LW
421 return do_readline();
422}
423
424PP(pp_warn)
425{
4e35701f 426 djSP; dMARK;
06bf62c7 427 SV *tmpsv;
a0d0e21e 428 char *tmps;
06bf62c7 429 STRLEN len;
a0d0e21e
LW
430 if (SP - MARK != 1) {
431 dTARGET;
3280af22 432 do_join(TARG, &PL_sv_no, MARK, SP);
06bf62c7 433 tmpsv = TARG;
a0d0e21e
LW
434 SP = MARK + 1;
435 }
436 else {
06bf62c7 437 tmpsv = TOPs;
a0d0e21e 438 }
06bf62c7
GS
439 tmps = SvPV(tmpsv, len);
440 if (!tmps || !len) {
4e6ea2c3
GS
441 SV *error = ERRSV;
442 (void)SvUPGRADE(error, SVt_PV);
443 if (SvPOK(error) && SvCUR(error))
444 sv_catpv(error, "\t...caught");
06bf62c7
GS
445 tmpsv = error;
446 tmps = SvPV(tmpsv, len);
a0d0e21e 447 }
06bf62c7
GS
448 if (!tmps || !len)
449 tmpsv = sv_2mortal(newSVpvn("Warning: something's wrong", 26));
450
cb50131a 451 Perl_warn(aTHX_ "%"SVf, tmpsv);
a0d0e21e
LW
452 RETSETYES;
453}
454
455PP(pp_die)
456{
4e35701f 457 djSP; dMARK;
a0d0e21e 458 char *tmps;
06bf62c7
GS
459 SV *tmpsv;
460 STRLEN len;
461 bool multiarg = 0;
a0d0e21e
LW
462 if (SP - MARK != 1) {
463 dTARGET;
3280af22 464 do_join(TARG, &PL_sv_no, MARK, SP);
06bf62c7
GS
465 tmpsv = TARG;
466 tmps = SvPV(tmpsv, len);
467 multiarg = 1;
a0d0e21e
LW
468 SP = MARK + 1;
469 }
470 else {
4e6ea2c3 471 tmpsv = TOPs;
06bf62c7 472 tmps = SvROK(tmpsv) ? Nullch : SvPV(tmpsv, len);
a0d0e21e 473 }
06bf62c7 474 if (!tmps || !len) {
4e6ea2c3
GS
475 SV *error = ERRSV;
476 (void)SvUPGRADE(error, SVt_PV);
06bf62c7
GS
477 if (multiarg ? SvROK(error) : SvROK(tmpsv)) {
478 if (!multiarg)
4e6ea2c3 479 SvSetSV(error,tmpsv);
06bf62c7 480 else if (sv_isobject(error)) {
05423cc9
GS
481 HV *stash = SvSTASH(SvRV(error));
482 GV *gv = gv_fetchmethod(stash, "PROPAGATE");
483 if (gv) {
146174a9 484 SV *file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0));
b448e4fe 485 SV *line = sv_2mortal(newSVuv(CopLINE(PL_curcop)));
05423cc9
GS
486 EXTEND(SP, 3);
487 PUSHMARK(SP);
488 PUSHs(error);
489 PUSHs(file);
490 PUSHs(line);
491 PUTBACK;
864dbfa3
GS
492 call_sv((SV*)GvCV(gv),
493 G_SCALAR|G_EVAL|G_KEEPERR);
3280af22 494 sv_setsv(error,*PL_stack_sp--);
05423cc9
GS
495 }
496 }
cea2e8a9 497 DIE(aTHX_ Nullch);
4e6ea2c3
GS
498 }
499 else {
500 if (SvPOK(error) && SvCUR(error))
501 sv_catpv(error, "\t...propagated");
06bf62c7
GS
502 tmpsv = error;
503 tmps = SvPV(tmpsv, len);
4e6ea2c3 504 }
a0d0e21e 505 }
06bf62c7
GS
506 if (!tmps || !len)
507 tmpsv = sv_2mortal(newSVpvn("Died", 4));
508
cb50131a 509 DIE(aTHX_ "%"SVf, tmpsv);
a0d0e21e
LW
510}
511
512/* I/O. */
513
514PP(pp_open)
515{
4e35701f 516 djSP; dTARGET;
a0d0e21e
LW
517 GV *gv;
518 SV *sv;
6aa016ca 519 SV *name = Nullsv;
6170680b 520 I32 have_name = 0;
a0d0e21e
LW
521 char *tmps;
522 STRLEN len;
4592e6ca 523 MAGIC *mg;
a0d0e21e 524
6170680b
IZ
525 if (MAXARG > 2) {
526 name = POPs;
527 have_name = 1;
528 }
a0d0e21e
LW
529 if (MAXARG > 1)
530 sv = POPs;
5f05dabc 531 if (!isGV(TOPs))
cea2e8a9 532 DIE(aTHX_ PL_no_usym, "filehandle");
5f05dabc
PP
533 if (MAXARG <= 1)
534 sv = GvSV(TOPs);
a0d0e21e 535 gv = (GV*)POPs;
5f05dabc 536 if (!isGV(gv))
cea2e8a9 537 DIE(aTHX_ PL_no_usym, "filehandle");
36477c24
PP
538 if (GvIOp(gv))
539 IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
853846ea 540
155aba94 541 if ((mg = SvTIED_mg((SV*)gv, 'q'))) {
4592e6ca
NIS
542 PUSHMARK(SP);
543 XPUSHs(SvTIED_obj((SV*)gv, mg));
544 XPUSHs(sv);
6170680b
IZ
545 if (have_name)
546 XPUSHs(name);
4592e6ca
NIS
547 PUTBACK;
548 ENTER;
864dbfa3 549 call_method("OPEN", G_SCALAR);
4592e6ca
NIS
550 LEAVE;
551 SPAGAIN;
552 RETURN;
553 }
554
a0d0e21e 555 tmps = SvPV(sv, len);
6170680b 556 if (do_open9(gv, tmps, len, FALSE, O_RDONLY, 0, Nullfp, name, have_name))
3280af22
NIS
557 PUSHi( (I32)PL_forkprocess );
558 else if (PL_forkprocess == 0) /* we are a new child */
a0d0e21e
LW
559 PUSHi(0);
560 else
561 RETPUSHUNDEF;
562 RETURN;
563}
564
565PP(pp_close)
566{
4e35701f 567 djSP;
a0d0e21e 568 GV *gv;
1d603a67 569 MAGIC *mg;
a0d0e21e
LW
570
571 if (MAXARG == 0)
3280af22 572 gv = PL_defoutgv;
a0d0e21e
LW
573 else
574 gv = (GV*)POPs;
1d603a67 575
155aba94 576 if ((mg = SvTIED_mg((SV*)gv, 'q'))) {
1d603a67 577 PUSHMARK(SP);
33c27489 578 XPUSHs(SvTIED_obj((SV*)gv, mg));
1d603a67
GB
579 PUTBACK;
580 ENTER;
864dbfa3 581 call_method("CLOSE", G_SCALAR);
1d603a67
GB
582 LEAVE;
583 SPAGAIN;
584 RETURN;
585 }
a0d0e21e 586 EXTEND(SP, 1);
54310121 587 PUSHs(boolSV(do_close(gv, TRUE)));
a0d0e21e
LW
588 RETURN;
589}
590
591PP(pp_pipe_op)
592{
4e35701f 593 djSP;
a0d0e21e
LW
594#ifdef HAS_PIPE
595 GV *rgv;
596 GV *wgv;
597 register IO *rstio;
598 register IO *wstio;
599 int fd[2];
600
601 wgv = (GV*)POPs;
602 rgv = (GV*)POPs;
603
604 if (!rgv || !wgv)
605 goto badexit;
606
4633a7c4 607 if (SvTYPE(rgv) != SVt_PVGV || SvTYPE(wgv) != SVt_PVGV)
cea2e8a9 608 DIE(aTHX_ PL_no_usym, "filehandle");
a0d0e21e
LW
609 rstio = GvIOn(rgv);
610 wstio = GvIOn(wgv);
611
612 if (IoIFP(rstio))
613 do_close(rgv, FALSE);
614 if (IoIFP(wstio))
615 do_close(wgv, FALSE);
616
6ad3d225 617 if (PerlProc_pipe(fd) < 0)
a0d0e21e
LW
618 goto badexit;
619
760ac839
LW
620 IoIFP(rstio) = PerlIO_fdopen(fd[0], "r");
621 IoOFP(wstio) = PerlIO_fdopen(fd[1], "w");
a0d0e21e 622 IoIFP(wstio) = IoOFP(wstio);
50952442
JH
623 IoTYPE(rstio) = IoTYPE_RDONLY;
624 IoTYPE(wstio) = IoTYPE_WRONLY;
a0d0e21e
LW
625
626 if (!IoIFP(rstio) || !IoOFP(wstio)) {
760ac839 627 if (IoIFP(rstio)) PerlIO_close(IoIFP(rstio));
6ad3d225 628 else PerlLIO_close(fd[0]);
760ac839 629 if (IoOFP(wstio)) PerlIO_close(IoOFP(wstio));
6ad3d225 630 else PerlLIO_close(fd[1]);
a0d0e21e
LW
631 goto badexit;
632 }
4771b018
GS
633#if defined(HAS_FCNTL) && defined(F_SETFD)
634 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
635 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
636#endif
a0d0e21e
LW
637 RETPUSHYES;
638
639badexit:
640 RETPUSHUNDEF;
641#else
cea2e8a9 642 DIE(aTHX_ PL_no_func, "pipe");
a0d0e21e
LW
643#endif
644}
645
646PP(pp_fileno)
647{
4e35701f 648 djSP; dTARGET;
a0d0e21e
LW
649 GV *gv;
650 IO *io;
760ac839 651 PerlIO *fp;
4592e6ca
NIS
652 MAGIC *mg;
653
a0d0e21e
LW
654 if (MAXARG < 1)
655 RETPUSHUNDEF;
656 gv = (GV*)POPs;
4592e6ca
NIS
657
658 if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
659 PUSHMARK(SP);
660 XPUSHs(SvTIED_obj((SV*)gv, mg));
661 PUTBACK;
662 ENTER;
864dbfa3 663 call_method("FILENO", G_SCALAR);
4592e6ca
NIS
664 LEAVE;
665 SPAGAIN;
666 RETURN;
667 }
668
a0d0e21e
LW
669 if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io)))
670 RETPUSHUNDEF;
760ac839 671 PUSHi(PerlIO_fileno(fp));
a0d0e21e
LW
672 RETURN;
673}
674
675PP(pp_umask)
676{
4e35701f 677 djSP; dTARGET;
761237fe 678 Mode_t anum;
a0d0e21e
LW
679
680#ifdef HAS_UMASK
681 if (MAXARG < 1) {
6ad3d225
GS
682 anum = PerlLIO_umask(0);
683 (void)PerlLIO_umask(anum);
a0d0e21e
LW
684 }
685 else
6ad3d225 686 anum = PerlLIO_umask(POPi);
a0d0e21e
LW
687 TAINT_PROPER("umask");
688 XPUSHi(anum);
689#else
eec2d3df
GS
690 /* Only DIE if trying to restrict permissions on `user' (self).
691 * Otherwise it's harmless and more useful to just return undef
692 * since 'group' and 'other' concepts probably don't exist here. */
693 if (MAXARG >= 1 && (POPi & 0700))
cea2e8a9 694 DIE(aTHX_ "umask not implemented");
6b88bc9c 695 XPUSHs(&PL_sv_undef);
a0d0e21e
LW
696#endif
697 RETURN;
698}
699
700PP(pp_binmode)
701{
4e35701f 702 djSP;
a0d0e21e
LW
703 GV *gv;
704 IO *io;
760ac839 705 PerlIO *fp;
4592e6ca 706 MAGIC *mg;
16fe6d59 707 SV *discp = Nullsv;
a0d0e21e
LW
708
709 if (MAXARG < 1)
710 RETPUSHUNDEF;
16fe6d59
GS
711 if (MAXARG > 1)
712 discp = POPs;
a0d0e21e 713
301e8125 714 gv = (GV*)POPs;
4592e6ca
NIS
715
716 if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
717 PUSHMARK(SP);
718 XPUSHs(SvTIED_obj((SV*)gv, mg));
16fe6d59
GS
719 if (discp)
720 XPUSHs(discp);
4592e6ca
NIS
721 PUTBACK;
722 ENTER;
864dbfa3 723 call_method("BINMODE", G_SCALAR);
4592e6ca
NIS
724 LEAVE;
725 SPAGAIN;
726 RETURN;
727 }
a0d0e21e
LW
728
729 EXTEND(SP, 1);
730 if (!(io = GvIO(gv)) || !(fp = IoIFP(io)))
55497cff 731 RETPUSHUNDEF;
a0d0e21e 732
301e8125 733 if (do_binmode(fp,IoTYPE(io),mode_from_discipline(discp)))
a0d0e21e
LW
734 RETPUSHYES;
735 else
736 RETPUSHUNDEF;
a0d0e21e
LW
737}
738
739PP(pp_tie)
740{
4e35701f 741 djSP;
e336de0d 742 dMARK;
a0d0e21e
LW
743 SV *varsv;
744 HV* stash;
745 GV *gv;
a0d0e21e 746 SV *sv;
3280af22 747 I32 markoff = MARK - PL_stack_base;
a0d0e21e 748 char *methname;
6b05c17a 749 int how = 'P';
e336de0d 750 U32 items;
2d8e6c8d 751 STRLEN n_a;
a0d0e21e 752
e336de0d 753 varsv = *++MARK;
6b05c17a
NIS
754 switch(SvTYPE(varsv)) {
755 case SVt_PVHV:
756 methname = "TIEHASH";
757 break;
758 case SVt_PVAV:
759 methname = "TIEARRAY";
760 break;
761 case SVt_PVGV:
762 methname = "TIEHANDLE";
763 how = 'q';
764 break;
765 default:
766 methname = "TIESCALAR";
767 how = 'q';
768 break;
769 }
e336de0d
GS
770 items = SP - MARK++;
771 if (sv_isobject(*MARK)) {
6b05c17a 772 ENTER;
e788e7d3 773 PUSHSTACKi(PERLSI_MAGIC);
e336de0d
GS
774 PUSHMARK(SP);
775 EXTEND(SP,items);
776 while (items--)
777 PUSHs(*MARK++);
778 PUTBACK;
864dbfa3 779 call_method(methname, G_SCALAR);
301e8125 780 }
6b05c17a 781 else {
864dbfa3 782 /* Not clear why we don't call call_method here too.
6b05c17a
NIS
783 * perhaps to get different error message ?
784 */
e336de0d 785 stash = gv_stashsv(*MARK, FALSE);
6b05c17a 786 if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
cea2e8a9 787 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%s\"",
301e8125 788 methname, SvPV(*MARK,n_a));
6b05c17a
NIS
789 }
790 ENTER;
e788e7d3 791 PUSHSTACKi(PERLSI_MAGIC);
e336de0d
GS
792 PUSHMARK(SP);
793 EXTEND(SP,items);
794 while (items--)
795 PUSHs(*MARK++);
796 PUTBACK;
864dbfa3 797 call_sv((SV*)GvCV(gv), G_SCALAR);
6b05c17a 798 }
a0d0e21e
LW
799 SPAGAIN;
800
801 sv = TOPs;
d3acc0f7 802 POPSTACK;
a0d0e21e 803 if (sv_isobject(sv)) {
33c27489 804 sv_unmagic(varsv, how);
ae21d580
JH
805 /* Croak if a self-tie on an aggregate is attempted. */
806 if (varsv == SvRV(sv) &&
807 (SvTYPE(sv) == SVt_PVAV ||
808 SvTYPE(sv) == SVt_PVHV))
809 Perl_croak(aTHX_
810 "Self-ties of arrays and hashes are not supported");
68a4a7e4 811 sv_magic(varsv, sv, how, Nullch, 0);
a0d0e21e
LW
812 }
813 LEAVE;
3280af22 814 SP = PL_stack_base + markoff;
a0d0e21e
LW
815 PUSHs(sv);
816 RETURN;
817}
818
819PP(pp_untie)
820{
4e35701f 821 djSP;
33c27489
GS
822 SV *sv = POPs;
823 char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) ? 'P' : 'q';
55497cff 824
cbdc8872 825 MAGIC * mg ;
155aba94 826 if ((mg = SvTIED_mg(sv, how))) {
a29a5827
NIS
827 SV *obj = SvRV(mg->mg_obj);
828 GV *gv;
829 CV *cv = NULL;
a29a5827
NIS
830 if ((gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE)) &&
831 isGV(gv) && (cv = GvCV(gv))) {
832 PUSHMARK(SP);
833 XPUSHs(SvTIED_obj((SV*)gv, mg));
301e8125 834 XPUSHs(sv_2mortal(newSViv(SvREFCNT(obj)-1)));
a29a5827
NIS
835 PUTBACK;
836 ENTER;
837 call_sv((SV *)cv, G_VOID);
838 LEAVE;
839 SPAGAIN;
cbdc8872 840 }
301e8125
NIS
841 else if (ckWARN(WARN_UNTIE)) {
842 if (mg && SvREFCNT(obj) > 1)
843 Perl_warner(aTHX_ WARN_UNTIE,
844 "untie attempted while %"UVuf" inner references still exist",
845 (UV)SvREFCNT(obj) - 1 ) ;
846 }
cbdc8872 847 }
33c27489 848 sv_unmagic(sv, how);
55497cff 849 RETPUSHYES;
a0d0e21e
LW
850}
851
c07a80fd
PP
852PP(pp_tied)
853{
4e35701f 854 djSP;
33c27489
GS
855 SV *sv = POPs;
856 char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) ? 'P' : 'q';
857 MAGIC *mg;
c07a80fd 858
155aba94 859 if ((mg = SvTIED_mg(sv, how))) {
33c27489
GS
860 SV *osv = SvTIED_obj(sv, mg);
861 if (osv == mg->mg_obj)
862 osv = sv_mortalcopy(osv);
863 PUSHs(osv);
864 RETURN;
c07a80fd 865 }
c07a80fd
PP
866 RETPUSHUNDEF;
867}
868
a0d0e21e
LW
869PP(pp_dbmopen)
870{
4e35701f 871 djSP;
a0d0e21e
LW
872 HV *hv;
873 dPOPPOPssrl;
874 HV* stash;
875 GV *gv;
a0d0e21e
LW
876 SV *sv;
877
878 hv = (HV*)POPs;
879
3280af22 880 sv = sv_mortalcopy(&PL_sv_no);
a0d0e21e
LW
881 sv_setpv(sv, "AnyDBM_File");
882 stash = gv_stashsv(sv, FALSE);
8ebc5c01 883 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
a0d0e21e 884 PUTBACK;
864dbfa3 885 require_pv("AnyDBM_File.pm");
a0d0e21e 886 SPAGAIN;
8ebc5c01 887 if (!(gv = gv_fetchmethod(stash, "TIEHASH")))
cea2e8a9 888 DIE(aTHX_ "No dbm on this machine");
a0d0e21e
LW
889 }
890
57d3b86d 891 ENTER;
924508f0 892 PUSHMARK(SP);
6b05c17a 893
924508f0 894 EXTEND(SP, 5);
a0d0e21e
LW
895 PUSHs(sv);
896 PUSHs(left);
897 if (SvIV(right))
b448e4fe 898 PUSHs(sv_2mortal(newSVuv(O_RDWR|O_CREAT)));
a0d0e21e 899 else
b448e4fe 900 PUSHs(sv_2mortal(newSVuv(O_RDWR)));
a0d0e21e 901 PUSHs(right);
57d3b86d 902 PUTBACK;
864dbfa3 903 call_sv((SV*)GvCV(gv), G_SCALAR);
a0d0e21e
LW
904 SPAGAIN;
905
906 if (!sv_isobject(TOPs)) {
924508f0
GS
907 SP--;
908 PUSHMARK(SP);
a0d0e21e
LW
909 PUSHs(sv);
910 PUSHs(left);
b448e4fe 911 PUSHs(sv_2mortal(newSVuv(O_RDONLY)));
a0d0e21e 912 PUSHs(right);
a0d0e21e 913 PUTBACK;
864dbfa3 914 call_sv((SV*)GvCV(gv), G_SCALAR);
a0d0e21e
LW
915 SPAGAIN;
916 }
917
6b05c17a 918 if (sv_isobject(TOPs)) {
301e8125 919 sv_unmagic((SV *) hv, 'P');
a0d0e21e 920 sv_magic((SV*)hv, TOPs, 'P', Nullch, 0);
6b05c17a 921 }
a0d0e21e
LW
922 LEAVE;
923 RETURN;
924}
925
926PP(pp_dbmclose)
927{
cea2e8a9 928 return pp_untie();
a0d0e21e
LW
929}
930
931PP(pp_sselect)
932{
4e35701f 933 djSP; dTARGET;
a0d0e21e
LW
934#ifdef HAS_SELECT
935 register I32 i;
936 register I32 j;
937 register char *s;
938 register SV *sv;
65202027 939 NV value;
a0d0e21e
LW
940 I32 maxlen = 0;
941 I32 nfound;
942 struct timeval timebuf;
943 struct timeval *tbuf = &timebuf;
944 I32 growsize;
945 char *fd_sets[4];
2d8e6c8d 946 STRLEN n_a;
a0d0e21e
LW
947#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
948 I32 masksize;
949 I32 offset;
950 I32 k;
951
952# if BYTEORDER & 0xf0000
953# define ORDERBYTE (0x88888888 - BYTEORDER)
954# else
955# define ORDERBYTE (0x4444 - BYTEORDER)
956# endif
957
958#endif
959
960 SP -= 4;
961 for (i = 1; i <= 3; i++) {
962 if (!SvPOK(SP[i]))
963 continue;
964 j = SvCUR(SP[i]);
965 if (maxlen < j)
966 maxlen = j;
967 }
968
5ff3f7a4 969/* little endians can use vecs directly */
a0d0e21e 970#if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
5ff3f7a4 971# if SELECT_MIN_BITS > 1
f2da832e
JH
972 /* If SELECT_MIN_BITS is greater than one we most probably will want
973 * to align the sizes with SELECT_MIN_BITS/8 because for example
974 * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
f556e5b9 975 * UNIX, Solaris, NeXT, Darwin) the smallest quantum select() operates
8f1f23e8 976 * on (sets/tests/clears bits) is 32 bits. */
f2da832e 977 growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
5ff3f7a4 978# else
4633a7c4 979 growsize = sizeof(fd_set);
5ff3f7a4
GS
980# endif
981# else
982# ifdef NFDBITS
a0d0e21e 983
5ff3f7a4
GS
984# ifndef NBBY
985# define NBBY 8
986# endif
a0d0e21e
LW
987
988 masksize = NFDBITS / NBBY;
5ff3f7a4 989# else
a0d0e21e 990 masksize = sizeof(long); /* documented int, everyone seems to use long */
5ff3f7a4 991# endif
a0d0e21e
LW
992 growsize = maxlen + (masksize - (maxlen % masksize));
993 Zero(&fd_sets[0], 4, char*);
994#endif
995
996 sv = SP[4];
997 if (SvOK(sv)) {
998 value = SvNV(sv);
999 if (value < 0.0)
1000 value = 0.0;
1001 timebuf.tv_sec = (long)value;
65202027 1002 value -= (NV)timebuf.tv_sec;
a0d0e21e
LW
1003 timebuf.tv_usec = (long)(value * 1000000.0);
1004 }
1005 else
1006 tbuf = Null(struct timeval*);
1007
1008 for (i = 1; i <= 3; i++) {
1009 sv = SP[i];
1010 if (!SvOK(sv)) {
1011 fd_sets[i] = 0;
1012 continue;
1013 }
1014 else if (!SvPOK(sv))
2d8e6c8d 1015 SvPV_force(sv,n_a); /* force string conversion */
a0d0e21e
LW
1016 j = SvLEN(sv);
1017 if (j < growsize) {
1018 Sv_Grow(sv, growsize);
a0d0e21e 1019 }
c07a80fd
PP
1020 j = SvCUR(sv);
1021 s = SvPVX(sv) + j;
1022 while (++j <= growsize) {
1023 *s++ = '\0';
1024 }
1025
a0d0e21e
LW
1026#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1027 s = SvPVX(sv);
1028 New(403, fd_sets[i], growsize, char);
1029 for (offset = 0; offset < growsize; offset += masksize) {
1030 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1031 fd_sets[i][j+offset] = s[(k % masksize) + offset];
1032 }
1033#else
1034 fd_sets[i] = SvPVX(sv);
1035#endif
1036 }
1037
6ad3d225 1038 nfound = PerlSock_select(
a0d0e21e
LW
1039 maxlen * 8,
1040 (Select_fd_set_t) fd_sets[1],
1041 (Select_fd_set_t) fd_sets[2],
1042 (Select_fd_set_t) fd_sets[3],
1043 tbuf);
1044 for (i = 1; i <= 3; i++) {
1045 if (fd_sets[i]) {
1046 sv = SP[i];
1047#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1048 s = SvPVX(sv);
1049 for (offset = 0; offset < growsize; offset += masksize) {
1050 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1051 s[(k % masksize) + offset] = fd_sets[i][j+offset];
1052 }
1053 Safefree(fd_sets[i]);
1054#endif
1055 SvSETMAGIC(sv);
1056 }
1057 }
1058
1059 PUSHi(nfound);
1060 if (GIMME == G_ARRAY && tbuf) {
65202027
DS
1061 value = (NV)(timebuf.tv_sec) +
1062 (NV)(timebuf.tv_usec) / 1000000.0;
3280af22 1063 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW
1064 sv_setnv(sv, value);
1065 }
1066 RETURN;
1067#else
cea2e8a9 1068 DIE(aTHX_ "select not implemented");
a0d0e21e
LW
1069#endif
1070}
1071
4633a7c4 1072void
864dbfa3 1073Perl_setdefout(pTHX_ GV *gv)
4633a7c4 1074{
11343788 1075 dTHR;
4633a7c4
LW
1076 if (gv)
1077 (void)SvREFCNT_inc(gv);
3280af22
NIS
1078 if (PL_defoutgv)
1079 SvREFCNT_dec(PL_defoutgv);
1080 PL_defoutgv = gv;
4633a7c4
LW
1081}
1082
a0d0e21e
LW
1083PP(pp_select)
1084{
4e35701f 1085 djSP; dTARGET;
4633a7c4
LW
1086 GV *newdefout, *egv;
1087 HV *hv;
1088
533c011a 1089 newdefout = (PL_op->op_private > 0) ? ((GV *) POPs) : (GV *) NULL;
4633a7c4 1090
3280af22 1091 egv = GvEGV(PL_defoutgv);
4633a7c4 1092 if (!egv)
3280af22 1093 egv = PL_defoutgv;
4633a7c4
LW
1094 hv = GvSTASH(egv);
1095 if (! hv)
3280af22 1096 XPUSHs(&PL_sv_undef);
4633a7c4 1097 else {
cbdc8872 1098 GV **gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
f86702cc 1099 if (gvp && *gvp == egv) {
f7aaccc2 1100 gv_efullname4(TARG, PL_defoutgv, Nullch, TRUE);
f86702cc
PP
1101 XPUSHTARG;
1102 }
1103 else {
1104 XPUSHs(sv_2mortal(newRV((SV*)egv)));
1105 }
4633a7c4
LW
1106 }
1107
1108 if (newdefout) {
ded8aa31
GS
1109 if (!GvIO(newdefout))
1110 gv_IOadd(newdefout);
4633a7c4
LW
1111 setdefout(newdefout);
1112 }
1113
a0d0e21e
LW
1114 RETURN;
1115}
1116
1117PP(pp_getc)
1118{
4e35701f 1119 djSP; dTARGET;
a0d0e21e 1120 GV *gv;
2ae324a7 1121 MAGIC *mg;
a0d0e21e 1122
32da55ab 1123 if (MAXARG == 0)
3280af22 1124 gv = PL_stdingv;
a0d0e21e
LW
1125 else
1126 gv = (GV*)POPs;
2ae324a7 1127
155aba94 1128 if ((mg = SvTIED_mg((SV*)gv, 'q'))) {
54310121 1129 I32 gimme = GIMME_V;
2ae324a7 1130 PUSHMARK(SP);
33c27489 1131 XPUSHs(SvTIED_obj((SV*)gv, mg));
2ae324a7
PP
1132 PUTBACK;
1133 ENTER;
864dbfa3 1134 call_method("GETC", gimme);
2ae324a7
PP
1135 LEAVE;
1136 SPAGAIN;
54310121
PP
1137 if (gimme == G_SCALAR)
1138 SvSetMagicSV_nosteal(TARG, TOPs);
2ae324a7
PP
1139 RETURN;
1140 }
9bc64814 1141 if (!gv || do_eof(gv)) /* make sure we have fp with something */
a0d0e21e 1142 RETPUSHUNDEF;
bbce6d69 1143 TAINT;
a0d0e21e 1144 sv_setpv(TARG, " ");
9bc64814 1145 *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
a0d0e21e
LW
1146 PUSHTARG;
1147 RETURN;
1148}
1149
1150PP(pp_read)
1151{
cea2e8a9 1152 return pp_sysread();
a0d0e21e
LW
1153}
1154
76e3520e 1155STATIC OP *
cea2e8a9 1156S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
a0d0e21e 1157{
11343788 1158 dTHR;
c09156bb 1159 register PERL_CONTEXT *cx;
54310121 1160 I32 gimme = GIMME_V;
a0d0e21e
LW
1161 AV* padlist = CvPADLIST(cv);
1162 SV** svp = AvARRAY(padlist);
1163
1164 ENTER;
1165 SAVETMPS;
1166
1167 push_return(retop);
146174a9 1168 PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
a0d0e21e 1169 PUSHFORMAT(cx);
146174a9 1170 SAVEVPTR(PL_curpad);
3280af22 1171 PL_curpad = AvARRAY((AV*)svp[1]);
a0d0e21e 1172
4633a7c4 1173 setdefout(gv); /* locally select filehandle so $% et al work */
a0d0e21e
LW
1174 return CvSTART(cv);
1175}
1176
1177PP(pp_enterwrite)
1178{
4e35701f 1179 djSP;
a0d0e21e
LW
1180 register GV *gv;
1181 register IO *io;
1182 GV *fgv;
1183 CV *cv;
1184
1185 if (MAXARG == 0)
3280af22 1186 gv = PL_defoutgv;
a0d0e21e
LW
1187 else {
1188 gv = (GV*)POPs;
1189 if (!gv)
3280af22 1190 gv = PL_defoutgv;
a0d0e21e
LW
1191 }
1192 EXTEND(SP, 1);
1193 io = GvIO(gv);
1194 if (!io) {
1195 RETPUSHNO;
1196 }
1197 if (IoFMT_GV(io))
1198 fgv = IoFMT_GV(io);
1199 else
1200 fgv = gv;
1201
1202 cv = GvFORM(fgv);
a0d0e21e 1203 if (!cv) {
2dd78f96 1204 char *name = NULL;
a0d0e21e 1205 if (fgv) {
748a9306 1206 SV *tmpsv = sv_newmortal();
43693395 1207 gv_efullname4(tmpsv, fgv, Nullch, FALSE);
2dd78f96 1208 name = SvPV_nolen(tmpsv);
a0d0e21e 1209 }
2dd78f96
JH
1210 if (name && *name)
1211 DIE(aTHX_ "Undefined format \"%s\" called", name);
cea2e8a9 1212 DIE(aTHX_ "Not a format reference");
a0d0e21e 1213 }
44a8e56a
PP
1214 if (CvCLONE(cv))
1215 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
a0d0e21e 1216
44a8e56a 1217 IoFLAGS(io) &= ~IOf_DIDTOP;
533c011a 1218 return doform(cv,gv,PL_op->op_next);
a0d0e21e
LW
1219}
1220
1221PP(pp_leavewrite)
1222{
4e35701f 1223 djSP;
a0d0e21e
LW
1224 GV *gv = cxstack[cxstack_ix].blk_sub.gv;
1225 register IO *io = GvIOp(gv);
760ac839
LW
1226 PerlIO *ofp = IoOFP(io);
1227 PerlIO *fp;
a0d0e21e
LW
1228 SV **newsp;
1229 I32 gimme;
c09156bb 1230 register PERL_CONTEXT *cx;
a0d0e21e 1231
760ac839 1232 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
3280af22
NIS
1233 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1234 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1235 PL_formtarget != PL_toptarget)
a0d0e21e 1236 {
4633a7c4
LW
1237 GV *fgv;
1238 CV *cv;
a0d0e21e
LW
1239 if (!IoTOP_GV(io)) {
1240 GV *topgv;
46fc3d4c 1241 SV *topname;
a0d0e21e
LW
1242
1243 if (!IoTOP_NAME(io)) {
1244 if (!IoFMT_NAME(io))
1245 IoFMT_NAME(io) = savepv(GvNAME(gv));
cea2e8a9 1246 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%s_TOP", IoFMT_NAME(io)));
46fc3d4c 1247 topgv = gv_fetchpv(SvPVX(topname), FALSE, SVt_PVFM);
748a9306 1248 if ((topgv && GvFORM(topgv)) ||
a0d0e21e 1249 !gv_fetchpv("top",FALSE,SVt_PVFM))
46fc3d4c 1250 IoTOP_NAME(io) = savepv(SvPVX(topname));
a0d0e21e
LW
1251 else
1252 IoTOP_NAME(io) = savepv("top");
1253 }
1254 topgv = gv_fetchpv(IoTOP_NAME(io),FALSE, SVt_PVFM);
1255 if (!topgv || !GvFORM(topgv)) {
1256 IoLINES_LEFT(io) = 100000000;
1257 goto forget_top;
1258 }
1259 IoTOP_GV(io) = topgv;
1260 }
748a9306
LW
1261 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1262 I32 lines = IoLINES_LEFT(io);
3280af22 1263 char *s = SvPVX(PL_formtarget);
8e07c86e
AD
1264 if (lines <= 0) /* Yow, header didn't even fit!!! */
1265 goto forget_top;
748a9306
LW
1266 while (lines-- > 0) {
1267 s = strchr(s, '\n');
1268 if (!s)
1269 break;
1270 s++;
1271 }
1272 if (s) {
3280af22
NIS
1273 PerlIO_write(ofp, SvPVX(PL_formtarget), s - SvPVX(PL_formtarget));
1274 sv_chop(PL_formtarget, s);
1275 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
748a9306
LW
1276 }
1277 }
a0d0e21e 1278 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
3280af22 1279 PerlIO_write(ofp, SvPVX(PL_formfeed), SvCUR(PL_formfeed));
a0d0e21e
LW
1280 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1281 IoPAGE(io)++;
3280af22 1282 PL_formtarget = PL_toptarget;
748a9306 1283 IoFLAGS(io) |= IOf_DIDTOP;
4633a7c4
LW
1284 fgv = IoTOP_GV(io);
1285 if (!fgv)
cea2e8a9 1286 DIE(aTHX_ "bad top format reference");
4633a7c4 1287 cv = GvFORM(fgv);
2dd78f96
JH
1288 {
1289 char *name = NULL;
1290 if (!cv) {
1291 SV *sv = sv_newmortal();
1292 gv_efullname4(sv, fgv, Nullch, FALSE);
1293 name = SvPV_nolen(sv);
1294 }
1295 if (name && *name)
1296 DIE(aTHX_ "Undefined top format \"%s\" called",name);
1297 /* why no:
1298 else
1299 DIE(aTHX_ "Undefined top format called");
1300 ?*/
4633a7c4 1301 }
44a8e56a
PP
1302 if (CvCLONE(cv))
1303 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
533c011a 1304 return doform(cv,gv,PL_op);
a0d0e21e
LW
1305 }
1306
1307 forget_top:
3280af22 1308 POPBLOCK(cx,PL_curpm);
a0d0e21e
LW
1309 POPFORMAT(cx);
1310 LEAVE;
1311
1312 fp = IoOFP(io);
1313 if (!fp) {
599cee73 1314 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
cb50131a 1315 if (IoIFP(io)) {
2dd78f96
JH
1316 /* integrate with report_evil_fh()? */
1317 char *name = NULL;
1318 if (isGV(gv)) {
1319 SV* sv = sv_newmortal();
1320 gv_efullname4(sv, gv, Nullch, FALSE);
1321 name = SvPV_nolen(sv);
1322 }
1323 if (name && *name)
1324 Perl_warner(aTHX_ WARN_IO,
1325 "Filehandle %s opened only for input", name);
1326 else
1327 Perl_warner(aTHX_ WARN_IO,
1328 "Filehandle opened only for input");
cb50131a 1329 }
599cee73 1330 else if (ckWARN(WARN_CLOSED))
bc37a18f 1331 report_evil_fh(gv, io, PL_op->op_type);
a0d0e21e 1332 }
3280af22 1333 PUSHs(&PL_sv_no);
a0d0e21e
LW
1334 }
1335 else {
3280af22 1336 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
599cee73 1337 if (ckWARN(WARN_IO))
cea2e8a9 1338 Perl_warner(aTHX_ WARN_IO, "page overflow");
a0d0e21e 1339 }
3280af22 1340 if (!PerlIO_write(ofp, SvPVX(PL_formtarget), SvCUR(PL_formtarget)) ||
760ac839 1341 PerlIO_error(fp))
3280af22 1342 PUSHs(&PL_sv_no);
a0d0e21e 1343 else {
3280af22
NIS
1344 FmLINES(PL_formtarget) = 0;
1345 SvCUR_set(PL_formtarget, 0);
1346 *SvEND(PL_formtarget) = '\0';
a0d0e21e 1347 if (IoFLAGS(io) & IOf_FLUSH)
760ac839 1348 (void)PerlIO_flush(fp);
3280af22 1349 PUSHs(&PL_sv_yes);
a0d0e21e
LW
1350 }
1351 }
3280af22 1352 PL_formtarget = PL_bodytarget;
a0d0e21e
LW
1353 PUTBACK;
1354 return pop_return();
1355}
1356
1357PP(pp_prtf)
1358{
4e35701f 1359 djSP; dMARK; dORIGMARK;
a0d0e21e
LW
1360 GV *gv;
1361 IO *io;
760ac839 1362 PerlIO *fp;
26db47c4 1363 SV *sv;
46fc3d4c 1364 MAGIC *mg;
2d8e6c8d 1365 STRLEN n_a;
a0d0e21e 1366
533c011a 1367 if (PL_op->op_flags & OPf_STACKED)
a0d0e21e
LW
1368 gv = (GV*)*++MARK;
1369 else
3280af22 1370 gv = PL_defoutgv;
46fc3d4c 1371
155aba94 1372 if ((mg = SvTIED_mg((SV*)gv, 'q'))) {
46fc3d4c 1373 if (MARK == ORIGMARK) {
4352c267 1374 MEXTEND(SP, 1);
46fc3d4c
PP
1375 ++MARK;
1376 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1377 ++SP;
1378 }
1379 PUSHMARK(MARK - 1);
33c27489 1380 *MARK = SvTIED_obj((SV*)gv, mg);
46fc3d4c
PP
1381 PUTBACK;
1382 ENTER;
864dbfa3 1383 call_method("PRINTF", G_SCALAR);
46fc3d4c
PP
1384 LEAVE;
1385 SPAGAIN;
1386 MARK = ORIGMARK + 1;
1387 *MARK = *SP;
1388 SP = MARK;
1389 RETURN;
1390 }
1391
26db47c4 1392 sv = NEWSV(0,0);
a0d0e21e 1393 if (!(io = GvIO(gv))) {
2dd78f96
JH
1394 dTHR;
1395 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1396 report_evil_fh(gv, io, PL_op->op_type);
748a9306 1397 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW
1398 goto just_say_no;
1399 }
1400 else if (!(fp = IoOFP(io))) {
599cee73 1401 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
2dd78f96 1402 /* integrate with report_evil_fh()? */
cb50131a 1403 if (IoIFP(io)) {
2dd78f96
JH
1404 char *name = NULL;
1405 if (isGV(gv)) {
1406 gv_efullname4(sv, gv, Nullch, FALSE);
1407 name = SvPV_nolen(sv);
1408 }
1409 if (name && *name)
1410 Perl_warner(aTHX_ WARN_IO,
1411 "Filehandle %s opened only for input", name);
1412 else
1413 Perl_warner(aTHX_ WARN_IO,
1414 "Filehandle opened only for input");
cb50131a 1415 }
599cee73 1416 else if (ckWARN(WARN_CLOSED))
bc37a18f 1417 report_evil_fh(gv, io, PL_op->op_type);
a0d0e21e 1418 }
748a9306 1419 SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
a0d0e21e
LW
1420 goto just_say_no;
1421 }
1422 else {
1423 do_sprintf(sv, SP - MARK, MARK + 1);
1424 if (!do_print(sv, fp))
1425 goto just_say_no;
1426
1427 if (IoFLAGS(io) & IOf_FLUSH)
760ac839 1428 if (PerlIO_flush(fp) == EOF)
a0d0e21e
LW
1429 goto just_say_no;
1430 }
1431 SvREFCNT_dec(sv);
1432 SP = ORIGMARK;
3280af22 1433 PUSHs(&PL_sv_yes);
a0d0e21e
LW
1434 RETURN;
1435
1436 just_say_no:
1437 SvREFCNT_dec(sv);
1438 SP = ORIGMARK;
3280af22 1439 PUSHs(&PL_sv_undef);
a0d0e21e
LW
1440 RETURN;
1441}
1442
c07a80fd
PP
1443PP(pp_sysopen)
1444{
4e35701f 1445 djSP;
c07a80fd 1446 GV *gv;
c07a80fd
PP
1447 SV *sv;
1448 char *tmps;
1449 STRLEN len;
1450 int mode, perm;
1451
1452 if (MAXARG > 3)
1453 perm = POPi;
1454 else
1455 perm = 0666;
1456 mode = POPi;
1457 sv = POPs;
1458 gv = (GV *)POPs;
1459
4592e6ca
NIS
1460 /* Need TIEHANDLE method ? */
1461
c07a80fd
PP
1462 tmps = SvPV(sv, len);
1463 if (do_open(gv, tmps, len, TRUE, mode, perm, Nullfp)) {
1464 IoLINES(GvIOp(gv)) = 0;
3280af22 1465 PUSHs(&PL_sv_yes);
c07a80fd
PP
1466 }
1467 else {
3280af22 1468 PUSHs(&PL_sv_undef);
c07a80fd
PP
1469 }
1470 RETURN;
1471}
1472
a0d0e21e
LW
1473PP(pp_sysread)
1474{
4e35701f 1475 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW
1476 int offset;
1477 GV *gv;
1478 IO *io;
1479 char *buffer;
5b54f415 1480 SSize_t length;
1e422769 1481 Sock_size_t bufsize;
748a9306 1482 SV *bufsv;
a0d0e21e 1483 STRLEN blen;
2ae324a7 1484 MAGIC *mg;
a0d0e21e
LW
1485
1486 gv = (GV*)*++MARK;
533c011a 1487 if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD) &&
33c27489 1488 (mg = SvTIED_mg((SV*)gv, 'q')))
137443ea 1489 {
2ae324a7
PP
1490 SV *sv;
1491
1492 PUSHMARK(MARK-1);
33c27489 1493 *MARK = SvTIED_obj((SV*)gv, mg);
2ae324a7 1494 ENTER;
864dbfa3 1495 call_method("READ", G_SCALAR);
2ae324a7
PP
1496 LEAVE;
1497 SPAGAIN;
1498 sv = POPs;
1499 SP = ORIGMARK;
1500 PUSHs(sv);
1501 RETURN;
1502 }
1503
a0d0e21e
LW
1504 if (!gv)
1505 goto say_undef;
748a9306 1506 bufsv = *++MARK;
ff68c719
PP
1507 if (! SvOK(bufsv))
1508 sv_setpvn(bufsv, "", 0);
748a9306 1509 buffer = SvPV_force(bufsv, blen);
a0d0e21e
LW
1510 length = SvIVx(*++MARK);
1511 if (length < 0)
cea2e8a9 1512 DIE(aTHX_ "Negative length");
748a9306 1513 SETERRNO(0,0);
a0d0e21e
LW
1514 if (MARK < SP)
1515 offset = SvIVx(*++MARK);
1516 else
1517 offset = 0;
1518 io = GvIO(gv);
1519 if (!io || !IoIFP(io))
1520 goto say_undef;
1521#ifdef HAS_SOCKET
533c011a 1522 if (PL_op->op_type == OP_RECV) {
46fc3d4c 1523 char namebuf[MAXPATHLEN];
eec2d3df 1524#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE)
490ab354
JH
1525 bufsize = sizeof (struct sockaddr_in);
1526#else
46fc3d4c 1527 bufsize = sizeof namebuf;
490ab354 1528#endif
abf95952
IZ
1529#ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1530 if (bufsize >= 256)
1531 bufsize = 255;
1532#endif
626727d5
GS
1533#ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1534 if (bufsize >= 256)
1535 bufsize = 255;
1536#endif
748a9306 1537 buffer = SvGROW(bufsv, length+1);
bbce6d69 1538 /* 'offset' means 'flags' here */
6ad3d225 1539 length = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
46fc3d4c 1540 (struct sockaddr *)namebuf, &bufsize);
a0d0e21e
LW
1541 if (length < 0)
1542 RETPUSHUNDEF;
748a9306
LW
1543 SvCUR_set(bufsv, length);
1544 *SvEND(bufsv) = '\0';
1545 (void)SvPOK_only(bufsv);
1546 SvSETMAGIC(bufsv);
aac0dd9a 1547 /* This should not be marked tainted if the fp is marked clean */
bbce6d69
PP
1548 if (!(IoFLAGS(io) & IOf_UNTAINT))
1549 SvTAINTED_on(bufsv);
a0d0e21e 1550 SP = ORIGMARK;
46fc3d4c 1551 sv_setpvn(TARG, namebuf, bufsize);
a0d0e21e
LW
1552 PUSHs(TARG);
1553 RETURN;
1554 }
1555#else
911d147d 1556 if (PL_op->op_type == OP_RECV)
cea2e8a9 1557 DIE(aTHX_ PL_no_sock_func, "recv");
a0d0e21e 1558#endif
bbce6d69
PP
1559 if (offset < 0) {
1560 if (-offset > blen)
cea2e8a9 1561 DIE(aTHX_ "Offset outside string");
bbce6d69
PP
1562 offset += blen;
1563 }
cd52b7b2 1564 bufsize = SvCUR(bufsv);
748a9306 1565 buffer = SvGROW(bufsv, length+offset+1);
cd52b7b2
PP
1566 if (offset > bufsize) { /* Zero any newly allocated space */
1567 Zero(buffer+bufsize, offset-bufsize, char);
1568 }
533c011a 1569 if (PL_op->op_type == OP_SYSREAD) {
a7092146 1570#ifdef PERL_SOCK_SYSREAD_IS_RECV
50952442 1571 if (IoTYPE(io) == IoTYPE_SOCKET) {
a7092146
GS
1572 length = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
1573 buffer+offset, length, 0);
1574 }
1575 else
1576#endif
1577 {
1578 length = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
1579 buffer+offset, length);
1580 }
a0d0e21e
LW
1581 }
1582 else
1583#ifdef HAS_SOCKET__bad_code_maybe
50952442 1584 if (IoTYPE(io) == IoTYPE_SOCKET) {
46fc3d4c 1585 char namebuf[MAXPATHLEN];
490ab354
JH
1586#if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
1587 bufsize = sizeof (struct sockaddr_in);
1588#else
46fc3d4c 1589 bufsize = sizeof namebuf;
490ab354 1590#endif
6ad3d225 1591 length = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer+offset, length, 0,
46fc3d4c 1592 (struct sockaddr *)namebuf, &bufsize);
a0d0e21e
LW
1593 }
1594 else
1595#endif
3b02c43c 1596 {
760ac839 1597 length = PerlIO_read(IoIFP(io), buffer+offset, length);
3b02c43c 1598 /* fread() returns 0 on both error and EOF */
5c7a8c78 1599 if (length == 0 && PerlIO_error(IoIFP(io)))
3b02c43c
GS
1600 length = -1;
1601 }
af8c498a 1602 if (length < 0) {
50952442 1603 if ((IoTYPE(io) == IoTYPE_WRONLY || IoIFP(io) == PerlIO_stdout()
c529f79d 1604 || IoIFP(io) == PerlIO_stderr()) && ckWARN(WARN_IO))
af8c498a 1605 {
2dd78f96
JH
1606 /* integrate with report_evil_fh()? */
1607 char *name = NULL;
1608 if (isGV(gv)) {
1609 SV* sv = sv_newmortal();
1610 gv_efullname4(sv, gv, Nullch, FALSE);
1611 name = SvPV_nolen(sv);
1612 }
1613 if (name && *name)
1614 Perl_warner(aTHX_ WARN_IO,
1615 "Filehandle %s opened only for output", name);
1616 else
1617 Perl_warner(aTHX_ WARN_IO,
1618 "Filehandle opened only for output");
af8c498a 1619 }
a0d0e21e 1620 goto say_undef;
af8c498a 1621 }
748a9306
LW
1622 SvCUR_set(bufsv, length+offset);
1623 *SvEND(bufsv) = '\0';
1624 (void)SvPOK_only(bufsv);
1625 SvSETMAGIC(bufsv);
aac0dd9a 1626 /* This should not be marked tainted if the fp is marked clean */
bbce6d69
PP
1627 if (!(IoFLAGS(io) & IOf_UNTAINT))
1628 SvTAINTED_on(bufsv);
a0d0e21e
LW
1629 SP = ORIGMARK;
1630 PUSHi(length);
1631 RETURN;
1632
1633 say_undef:
1634 SP = ORIGMARK;
1635 RETPUSHUNDEF;
1636}
1637
1638PP(pp_syswrite)
1639{
092bebab
JH
1640 djSP;
1641 int items = (SP - PL_stack_base) - TOPMARK;
1642 if (items == 2) {
9f089d78 1643 SV *sv;
092bebab 1644 EXTEND(SP, 1);
9f089d78
SB
1645 sv = sv_2mortal(newSViv(sv_len(*SP)));
1646 PUSHs(sv);
092bebab
JH
1647 PUTBACK;
1648 }
cea2e8a9 1649 return pp_send();
a0d0e21e
LW
1650}
1651
1652PP(pp_send)
1653{
4e35701f 1654 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW
1655 GV *gv;
1656 IO *io;
748a9306 1657 SV *bufsv;
a0d0e21e 1658 char *buffer;
8c99d73e
GS
1659 Size_t length;
1660 SSize_t retval;
1661 IV offset;
a0d0e21e 1662 STRLEN blen;
1d603a67 1663 MAGIC *mg;
a0d0e21e
LW
1664
1665 gv = (GV*)*++MARK;
33c27489 1666 if (PL_op->op_type == OP_SYSWRITE && (mg = SvTIED_mg((SV*)gv, 'q'))) {
1d603a67
GB
1667 SV *sv;
1668
1669 PUSHMARK(MARK-1);
33c27489 1670 *MARK = SvTIED_obj((SV*)gv, mg);
1d603a67 1671 ENTER;
864dbfa3 1672 call_method("WRITE", G_SCALAR);
1d603a67
GB
1673 LEAVE;
1674 SPAGAIN;
1675 sv = POPs;
1676 SP = ORIGMARK;
1677 PUSHs(sv);
1678 RETURN;
1679 }
a0d0e21e
LW
1680 if (!gv)
1681 goto say_undef;
748a9306
LW
1682 bufsv = *++MARK;
1683 buffer = SvPV(bufsv, blen);
8c99d73e 1684#if Size_t_size > IVSIZE
3c001241 1685 length = (Size_t)SvNVx(*++MARK);
146174a9 1686#else
3c001241 1687 length = (Size_t)SvIVx(*++MARK);
146174a9 1688#endif
3c001241 1689 if ((SSize_t)length < 0)
cea2e8a9 1690 DIE(aTHX_ "Negative length");
748a9306 1691 SETERRNO(0,0);
a0d0e21e
LW
1692 io = GvIO(gv);
1693 if (!io || !IoIFP(io)) {
8c99d73e 1694 retval = -1;
bc37a18f
RG
1695 if (ckWARN(WARN_CLOSED))
1696 report_evil_fh(gv, io, PL_op->op_type);
a0d0e21e 1697 }
533c011a 1698 else if (PL_op->op_type == OP_SYSWRITE) {
bbce6d69 1699 if (MARK < SP) {
a0d0e21e 1700 offset = SvIVx(*++MARK);
bbce6d69
PP
1701 if (offset < 0) {
1702 if (-offset > blen)
cea2e8a9 1703 DIE(aTHX_ "Offset outside string");
bbce6d69 1704 offset += blen;
fb73857a 1705 } else if (offset >= blen && blen > 0)
cea2e8a9 1706 DIE(aTHX_ "Offset outside string");
bbce6d69 1707 } else
a0d0e21e
LW
1708 offset = 0;
1709 if (length > blen - offset)
1710 length = blen - offset;
a7092146 1711#ifdef PERL_SOCK_SYSWRITE_IS_SEND
50952442 1712 if (IoTYPE(io) == IoTYPE_SOCKET) {
8c99d73e 1713 retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
a7092146
GS
1714 buffer+offset, length, 0);
1715 }
1716 else
1717#endif
1718 {
94e4c244 1719 /* See the note at doio.c:do_print about filesize limits. --jhi */
8c99d73e 1720 retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
a7092146
GS
1721 buffer+offset, length);
1722 }
a0d0e21e
LW
1723 }
1724#ifdef HAS_SOCKET
1725 else if (SP > MARK) {
1726 char *sockbuf;
1727 STRLEN mlen;
1728 sockbuf = SvPVx(*++MARK, mlen);
8c99d73e
GS
1729 retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
1730 length, (struct sockaddr *)sockbuf, mlen);
a0d0e21e
LW
1731 }
1732 else
8c99d73e 1733 retval = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, length);
490ab354 1734
a0d0e21e
LW
1735#else
1736 else
cea2e8a9 1737 DIE(aTHX_ PL_no_sock_func, "send");
a0d0e21e 1738#endif
8c99d73e 1739 if (retval < 0)
a0d0e21e
LW
1740 goto say_undef;
1741 SP = ORIGMARK;
8c99d73e
GS
1742#if Size_t_size > IVSIZE
1743 PUSHn(retval);
1744#else
1745 PUSHi(retval);
1746#endif
a0d0e21e
LW
1747 RETURN;
1748
1749 say_undef:
1750 SP = ORIGMARK;
1751 RETPUSHUNDEF;
1752}
1753
1754PP(pp_recv)
1755{
cea2e8a9 1756 return pp_sysread();
a0d0e21e
LW
1757}
1758
1759PP(pp_eof)
1760{
4e35701f 1761 djSP;
a0d0e21e 1762 GV *gv;
4592e6ca 1763 MAGIC *mg;
a0d0e21e 1764
32da55ab 1765 if (MAXARG == 0) {
146174a9
CB
1766 if (PL_op->op_flags & OPf_SPECIAL) { /* eof() */
1767 IO *io;
1768 gv = PL_last_in_gv = PL_argvgv;
1769 io = GvIO(gv);
1770 if (io && !IoIFP(io)) {
1771 if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) {
1772 IoLINES(io) = 0;
1773 IoFLAGS(io) &= ~IOf_START;
1774 do_open(gv, "-", 1, FALSE, O_RDONLY, 0, Nullfp);
1775 sv_setpvn(GvSV(gv), "-", 1);
1776 SvSETMAGIC(GvSV(gv));
1777 }
1778 else if (!nextargv(gv))
1779 RETPUSHYES;
1780 }
1781 }
1782 else
1783 gv = PL_last_in_gv; /* eof */
1784 }
a0d0e21e 1785 else
146174a9 1786 gv = PL_last_in_gv = (GV*)POPs; /* eof(FH) */
4592e6ca
NIS
1787
1788 if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
1789 PUSHMARK(SP);
1790 XPUSHs(SvTIED_obj((SV*)gv, mg));
1791 PUTBACK;
1792 ENTER;
864dbfa3 1793 call_method("EOF", G_SCALAR);
4592e6ca
NIS
1794 LEAVE;
1795 SPAGAIN;
1796 RETURN;
1797 }
1798
54310121 1799 PUSHs(boolSV(!gv || do_eof(gv)));
a0d0e21e
LW
1800 RETURN;
1801}
1802
1803PP(pp_tell)
1804{
4e35701f 1805 djSP; dTARGET;
301e8125 1806 GV *gv;
4592e6ca 1807 MAGIC *mg;
a0d0e21e 1808
32da55ab 1809 if (MAXARG == 0)
3280af22 1810 gv = PL_last_in_gv;
a0d0e21e 1811 else
3280af22 1812 gv = PL_last_in_gv = (GV*)POPs;
4592e6ca
NIS
1813
1814 if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
1815 PUSHMARK(SP);
1816 XPUSHs(SvTIED_obj((SV*)gv, mg));
1817 PUTBACK;
1818 ENTER;
864dbfa3 1819 call_method("TELL", G_SCALAR);
4592e6ca
NIS
1820 LEAVE;
1821 SPAGAIN;
1822 RETURN;
1823 }
1824
146174a9
CB
1825#if LSEEKSIZE > IVSIZE
1826 PUSHn( do_tell(gv) );
1827#else
a0d0e21e 1828 PUSHi( do_tell(gv) );
146174a9 1829#endif
a0d0e21e
LW
1830 RETURN;
1831}
1832
1833PP(pp_seek)
1834{
cea2e8a9 1835 return pp_sysseek();
137443ea
PP
1836}
1837
1838PP(pp_sysseek)
1839{
4e35701f 1840 djSP;
a0d0e21e
LW
1841 GV *gv;
1842 int whence = POPi;
146174a9
CB
1843#if LSEEKSIZE > IVSIZE
1844 Off_t offset = (Off_t)SvNVx(POPs);
1845#else
d9b3e12d 1846 Off_t offset = (Off_t)SvIVx(POPs);
146174a9 1847#endif
4592e6ca 1848 MAGIC *mg;
a0d0e21e 1849
3280af22 1850 gv = PL_last_in_gv = (GV*)POPs;
4592e6ca
NIS
1851
1852 if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
1853 PUSHMARK(SP);
1854 XPUSHs(SvTIED_obj((SV*)gv, mg));
cb50131a
CB
1855#if LSEEKSIZE > IVSIZE
1856 XPUSHs(sv_2mortal(newSVnv((NV) offset)));
1857#else
b448e4fe 1858 XPUSHs(sv_2mortal(newSViv(offset)));
cb50131a 1859#endif
b448e4fe 1860 XPUSHs(sv_2mortal(newSViv(whence)));
4592e6ca
NIS
1861 PUTBACK;
1862 ENTER;
864dbfa3 1863 call_method("SEEK", G_SCALAR);
4592e6ca
NIS
1864 LEAVE;
1865 SPAGAIN;
1866 RETURN;
1867 }
1868
533c011a 1869 if (PL_op->op_type == OP_SEEK)
8903cb82
PP
1870 PUSHs(boolSV(do_seek(gv, offset, whence)));
1871 else {
b448e4fe
JH
1872 Off_t sought = do_sysseek(gv, offset, whence);
1873 if (sought < 0)
146174a9
CB
1874 PUSHs(&PL_sv_undef);
1875 else {
b448e4fe 1876 SV* sv = sought ?
146174a9 1877#if LSEEKSIZE > IVSIZE
b448e4fe 1878 newSVnv((NV)sought)
146174a9 1879#else
b448e4fe 1880 newSViv(sought)
146174a9
CB
1881#endif
1882 : newSVpvn(zero_but_true, ZBTLEN);
1883 PUSHs(sv_2mortal(sv));
1884 }
8903cb82 1885 }
a0d0e21e
LW
1886 RETURN;
1887}
1888
1889PP(pp_truncate)
1890{
4e35701f 1891 djSP;
8c99d73e
GS
1892 /* There seems to be no consensus on the length type of truncate()
1893 * and ftruncate(), both off_t and size_t have supporters. In
1894 * general one would think that when using large files, off_t is
1895 * at least as wide as size_t, so using an off_t should be okay. */
1896 /* XXX Configure probe for the length type of *truncate() needed XXX */
1897 Off_t len;
a0d0e21e
LW
1898 int result = 1;
1899 GV *tmpgv;
2d8e6c8d 1900 STRLEN n_a;
a0d0e21e 1901
8c99d73e
GS
1902#if Size_t_size > IVSIZE
1903 len = (Off_t)POPn;
1904#else
1905 len = (Off_t)POPi;
1906#endif
1907 /* Checking for length < 0 is problematic as the type might or
301e8125 1908 * might not be signed: if it is not, clever compilers will moan. */
8c99d73e 1909 /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
748a9306 1910 SETERRNO(0,0);
5d94fbed 1911#if defined(HAS_TRUNCATE) || defined(HAS_CHSIZE) || defined(F_FREESP)
533c011a 1912 if (PL_op->op_flags & OPf_SPECIAL) {
2d8e6c8d 1913 tmpgv = gv_fetchpv(POPpx, FALSE, SVt_PVIO);
cbdc8872 1914 do_ftruncate:
1e422769 1915 TAINT_PROPER("truncate");
cb50131a
CB
1916 if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv)))
1917 result = 0;
1918 else {
1919 PerlIO_flush(IoIFP(GvIOp(tmpgv)));
cbdc8872 1920#ifdef HAS_TRUNCATE
cb50131a 1921 if (ftruncate(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
301e8125 1922#else
cb50131a 1923 if (my_chsize(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
cbdc8872 1924#endif
cb50131a
CB
1925 result = 0;
1926 }
a0d0e21e
LW
1927 }
1928 else {
cbdc8872 1929 SV *sv = POPs;
1e422769 1930 char *name;
2d8e6c8d 1931 STRLEN n_a;
1e422769 1932
cbdc8872
PP
1933 if (SvTYPE(sv) == SVt_PVGV) {
1934 tmpgv = (GV*)sv; /* *main::FRED for example */
1935 goto do_ftruncate;
1936 }
1937 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
1938 tmpgv = (GV*) SvRV(sv); /* \*main::FRED for example */
1939 goto do_ftruncate;
1940 }
1e422769 1941
2d8e6c8d 1942 name = SvPV(sv, n_a);
1e422769 1943 TAINT_PROPER("truncate");
cbdc8872 1944#ifdef HAS_TRUNCATE
1e422769 1945 if (truncate(name, len) < 0)
a0d0e21e 1946 result = 0;
cbdc8872
PP
1947#else
1948 {
1949 int tmpfd;
6ad3d225 1950 if ((tmpfd = PerlLIO_open(name, O_RDWR)) < 0)
bbce6d69 1951 result = 0;
cbdc8872
PP
1952 else {
1953 if (my_chsize(tmpfd, len) < 0)
1954 result = 0;
6ad3d225 1955 PerlLIO_close(tmpfd);
cbdc8872 1956 }
a0d0e21e 1957 }
a0d0e21e 1958#endif
cbdc8872 1959 }
a0d0e21e
LW
1960
1961 if (result)
1962 RETPUSHYES;
1963 if (!errno)
748a9306 1964 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW
1965 RETPUSHUNDEF;
1966#else
cea2e8a9 1967 DIE(aTHX_ "truncate not implemented");
a0d0e21e
LW
1968#endif
1969}
1970
1971PP(pp_fcntl)
1972{
cea2e8a9 1973 return pp_ioctl();
a0d0e21e
LW
1974}
1975
1976PP(pp_ioctl)
1977{
4e35701f 1978 djSP; dTARGET;
748a9306 1979 SV *argsv = POPs;
a0d0e21e 1980 unsigned int func = U_I(POPn);
533c011a 1981 int optype = PL_op->op_type;
a0d0e21e 1982 char *s;
324aa91a 1983 IV retval;
a0d0e21e
LW
1984 GV *gv = (GV*)POPs;
1985 IO *io = GvIOn(gv);
1986
748a9306
LW
1987 if (!io || !argsv || !IoIFP(io)) {
1988 SETERRNO(EBADF,RMS$_IFI); /* well, sort of... */
a0d0e21e
LW
1989 RETPUSHUNDEF;
1990 }
1991
748a9306 1992 if (SvPOK(argsv) || !SvNIOK(argsv)) {
a0d0e21e 1993 STRLEN len;
324aa91a 1994 STRLEN need;
748a9306 1995 s = SvPV_force(argsv, len);
324aa91a
HF
1996 need = IOCPARM_LEN(func);
1997 if (len < need) {
1998 s = Sv_Grow(argsv, need + 1);
1999 SvCUR_set(argsv, need);
a0d0e21e
LW
2000 }
2001
748a9306 2002 s[SvCUR(argsv)] = 17; /* a little sanity check here */
a0d0e21e
LW
2003 }
2004 else {
748a9306 2005 retval = SvIV(argsv);
c529f79d 2006 s = INT2PTR(char*,retval); /* ouch */
a0d0e21e
LW
2007 }
2008
2009 TAINT_PROPER(optype == OP_IOCTL ? "ioctl" : "fcntl");
2010
2011 if (optype == OP_IOCTL)
2012#ifdef HAS_IOCTL
76e3520e 2013 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
a0d0e21e 2014#else
cea2e8a9 2015 DIE(aTHX_ "ioctl is not implemented");
a0d0e21e
LW
2016#endif
2017 else
55497cff
PP
2018#ifdef HAS_FCNTL
2019#if defined(OS2) && defined(__EMX__)
760ac839 2020 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
55497cff 2021#else
760ac839 2022 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
301e8125 2023#endif
55497cff 2024#else
cea2e8a9 2025 DIE(aTHX_ "fcntl is not implemented");
a0d0e21e
LW
2026#endif
2027
748a9306
LW
2028 if (SvPOK(argsv)) {
2029 if (s[SvCUR(argsv)] != 17)
cea2e8a9 2030 DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
22c35a8c 2031 PL_op_name[optype]);
748a9306
LW
2032 s[SvCUR(argsv)] = 0; /* put our null back */
2033 SvSETMAGIC(argsv); /* Assume it has changed */
a0d0e21e
LW
2034 }
2035
2036 if (retval == -1)
2037 RETPUSHUNDEF;
2038 if (retval != 0) {
2039 PUSHi(retval);
2040 }
2041 else {
8903cb82 2042 PUSHp(zero_but_true, ZBTLEN);
a0d0e21e
LW
2043 }
2044 RETURN;
2045}
2046
2047PP(pp_flock)
2048{
4e35701f 2049 djSP; dTARGET;
a0d0e21e
LW
2050 I32 value;
2051 int argtype;
2052 GV *gv;
bc37a18f 2053 IO *io = NULL;
760ac839 2054 PerlIO *fp;
16d20bd9 2055
ff68c719 2056#ifdef FLOCK
a0d0e21e 2057 argtype = POPi;
32da55ab 2058 if (MAXARG == 0)
3280af22 2059 gv = PL_last_in_gv;
a0d0e21e
LW
2060 else
2061 gv = (GV*)POPs;
bc37a18f
RG
2062 if (gv && (io = GvIO(gv)))
2063 fp = IoIFP(io);
2064 else {
a0d0e21e 2065 fp = Nullfp;
bc37a18f
RG
2066 io = NULL;
2067 }
a0d0e21e 2068 if (fp) {
68dc0745 2069 (void)PerlIO_flush(fp);
76e3520e 2070 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
a0d0e21e 2071 }
cb50131a 2072 else {
bc37a18f
RG
2073 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2074 report_evil_fh(gv, io, PL_op->op_type);
a0d0e21e 2075 value = 0;
cb50131a 2076 SETERRNO(EBADF,RMS$_IFI);
cb50131a 2077 }
a0d0e21e
LW
2078 PUSHi(value);
2079 RETURN;
2080#else
cea2e8a9 2081 DIE(aTHX_ PL_no_func, "flock()");
a0d0e21e
LW
2082#endif
2083}
2084
2085/* Sockets. */
2086
2087PP(pp_socket)
2088{
4e35701f 2089 djSP;
a0d0e21e
LW
2090#ifdef HAS_SOCKET
2091 GV *gv;
2092 register IO *io;
2093 int protocol = POPi;
2094 int type = POPi;
2095 int domain = POPi;
2096 int fd;
2097
2098 gv = (GV*)POPs;
2099
2100 if (!gv) {
748a9306 2101 SETERRNO(EBADF,LIB$_INVARG);
a0d0e21e
LW
2102 RETPUSHUNDEF;
2103 }
2104
2105 io = GvIOn(gv);
2106 if (IoIFP(io))
2107 do_close(gv, FALSE);
2108
2109 TAINT_PROPER("socket");
6ad3d225 2110 fd = PerlSock_socket(domain, type, protocol);
a0d0e21e
LW
2111 if (fd < 0)
2112 RETPUSHUNDEF;
760ac839
LW
2113 IoIFP(io) = PerlIO_fdopen(fd, "r"); /* stdio gets confused about sockets */
2114 IoOFP(io) = PerlIO_fdopen(fd, "w");
50952442 2115 IoTYPE(io) = IoTYPE_SOCKET;
a0d0e21e 2116 if (!IoIFP(io) || !IoOFP(io)) {
760ac839
LW
2117 if (IoIFP(io)) PerlIO_close(IoIFP(io));
2118 if (IoOFP(io)) PerlIO_close(IoOFP(io));
6ad3d225 2119 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
a0d0e21e
LW
2120 RETPUSHUNDEF;
2121 }
8d2a6795
GS
2122#if defined(HAS_FCNTL) && defined(F_SETFD)
2123 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2124#endif
a0d0e21e
LW
2125
2126 RETPUSHYES;
2127#else
cea2e8a9 2128 DIE(aTHX_ PL_no_sock_func, "socket");
a0d0e21e
LW
2129#endif
2130}
2131
2132PP(pp_sockpair)
2133{
4e35701f 2134 djSP;
a0d0e21e
LW
2135#ifdef HAS_SOCKETPAIR
2136 GV *gv1;
2137 GV *gv2;
2138 register IO *io1;
2139 register IO *io2;
2140 int protocol = POPi;
2141 int type = POPi;
2142 int domain = POPi;
2143 int fd[2];
2144
2145 gv2 = (GV*)POPs;
2146 gv1 = (GV*)POPs;
2147 if (!gv1 || !gv2)
2148 RETPUSHUNDEF;
2149
2150 io1 = GvIOn(gv1);
2151 io2 = GvIOn(gv2);
2152 if (IoIFP(io1))
2153 do_close(gv1, FALSE);
2154 if (IoIFP(io2))
2155 do_close(gv2, FALSE);
2156
2157 TAINT_PROPER("socketpair");
6ad3d225 2158 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
a0d0e21e 2159 RETPUSHUNDEF;
760ac839
LW
2160 IoIFP(io1) = PerlIO_fdopen(fd[0], "r");
2161 IoOFP(io1) = PerlIO_fdopen(fd[0], "w");
50952442 2162 IoTYPE(io1) = IoTYPE_SOCKET;
760ac839
LW
2163 IoIFP(io2) = PerlIO_fdopen(fd[1], "r");
2164 IoOFP(io2) = PerlIO_fdopen(fd[1], "w");
50952442 2165 IoTYPE(io2) = IoTYPE_SOCKET;
a0d0e21e 2166 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
760ac839
LW
2167 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2168 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
6ad3d225 2169 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
760ac839
LW
2170 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2171 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
6ad3d225 2172 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
a0d0e21e
LW
2173 RETPUSHUNDEF;
2174 }
8d2a6795
GS
2175#if defined(HAS_FCNTL) && defined(F_SETFD)
2176 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
2177 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
2178#endif
a0d0e21e
LW
2179
2180 RETPUSHYES;
2181#else
cea2e8a9 2182 DIE(aTHX_ PL_no_sock_func, "socketpair");
a0d0e21e
LW
2183#endif
2184}
2185
2186PP(pp_bind)
2187{
4e35701f 2188 djSP;
a0d0e21e 2189#ifdef HAS_SOCKET
eec2d3df
GS
2190#ifdef MPE /* Requires PRIV mode to bind() to ports < 1024 */
2191 extern GETPRIVMODE();
2192 extern GETUSERMODE();
2193#endif
748a9306 2194 SV *addrsv = POPs;
a0d0e21e
LW
2195 char *addr;
2196 GV *gv = (GV*)POPs;
2197 register IO *io = GvIOn(gv);
2198 STRLEN len;
eec2d3df
GS
2199 int bind_ok = 0;
2200#ifdef MPE
2201 int mpeprivmode = 0;
2202#endif
a0d0e21e
LW
2203
2204 if (!io || !IoIFP(io))
2205 goto nuts;
2206
748a9306 2207 addr = SvPV(addrsv, len);
a0d0e21e 2208 TAINT_PROPER("bind");
eec2d3df
GS
2209#ifdef MPE /* Deal with MPE bind() peculiarities */
2210 if (((struct sockaddr *)addr)->sa_family == AF_INET) {
2211 /* The address *MUST* stupidly be zero. */
2212 ((struct sockaddr_in *)addr)->sin_addr.s_addr = INADDR_ANY;
2213 /* PRIV mode is required to bind() to ports < 1024. */
2214 if (((struct sockaddr_in *)addr)->sin_port < 1024 &&
2215 ((struct sockaddr_in *)addr)->sin_port > 0) {
2216 GETPRIVMODE(); /* If this fails, we are aborted by MPE/iX. */
2217 mpeprivmode = 1;
2218 }
2219 }
2220#endif /* MPE */
2221 if (PerlSock_bind(PerlIO_fileno(IoIFP(io)),
2222 (struct sockaddr *)addr, len) >= 0)
2223 bind_ok = 1;
2224
2225#ifdef MPE /* Switch back to USER mode */
2226 if (mpeprivmode)
2227 GETUSERMODE();
2228#endif /* MPE */
2229
2230 if (bind_ok)
a0d0e21e
LW
2231 RETPUSHYES;
2232 else
2233 RETPUSHUNDEF;
2234
2235nuts:
599cee73 2236 if (ckWARN(WARN_CLOSED))
bc37a18f 2237 report_evil_fh(gv, io, PL_op->op_type);
748a9306 2238 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW
2239 RETPUSHUNDEF;
2240#else
cea2e8a9 2241 DIE(aTHX_ PL_no_sock_func, "bind");
a0d0e21e
LW
2242#endif
2243}
2244
2245PP(pp_connect)
2246{
4e35701f 2247 djSP;
a0d0e21e 2248#ifdef HAS_SOCKET
748a9306 2249 SV *addrsv = POPs;
a0d0e21e
LW
2250 char *addr;
2251 GV *gv = (GV*)POPs;
2252 register IO *io = GvIOn(gv);
2253 STRLEN len;
2254
2255 if (!io || !IoIFP(io))
2256 goto nuts;
2257
748a9306 2258 addr = SvPV(addrsv, len);
a0d0e21e 2259 TAINT_PROPER("connect");
6ad3d225 2260 if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
a0d0e21e
LW
2261 RETPUSHYES;
2262 else
2263 RETPUSHUNDEF;
2264
2265nuts:
599cee73 2266 if (ckWARN(WARN_CLOSED))
bc37a18f 2267 report_evil_fh(gv, io, PL_op->op_type);
748a9306 2268 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW
2269 RETPUSHUNDEF;
2270#else
cea2e8a9 2271 DIE(aTHX_ PL_no_sock_func, "connect");
a0d0e21e
LW
2272#endif
2273}
2274
2275PP(pp_listen)
2276{
4e35701f 2277 djSP;
a0d0e21e
LW
2278#ifdef HAS_SOCKET
2279 int backlog = POPi;
2280 GV *gv = (GV*)POPs;
2281 register IO *io = GvIOn(gv);
2282
2283 if (!io || !IoIFP(io))
2284 goto nuts;
2285
6ad3d225 2286 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
a0d0e21e
LW
2287 RETPUSHYES;
2288 else
2289 RETPUSHUNDEF;
2290
2291nuts:
599cee73 2292 if (ckWARN(WARN_CLOSED))
bc37a18f 2293 report_evil_fh(gv, io, PL_op->op_type);
748a9306 2294 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW
2295 RETPUSHUNDEF;
2296#else
cea2e8a9 2297 DIE(aTHX_ PL_no_sock_func, "listen");
a0d0e21e
LW
2298#endif
2299}
2300
2301PP(pp_accept)
2302{
4e35701f 2303 djSP; dTARGET;
a0d0e21e
LW
2304#ifdef HAS_SOCKET
2305 GV *ngv;
2306 GV *ggv;
2307 register IO *nstio;
2308 register IO *gstio;
4633a7c4 2309 struct sockaddr saddr; /* use a struct to avoid alignment problems */
1e422769 2310 Sock_size_t len = sizeof saddr;
a0d0e21e
LW
2311 int fd;
2312
2313 ggv = (GV*)POPs;
2314 ngv = (GV*)POPs;
2315
2316 if (!ngv)
2317 goto badexit;
2318 if (!ggv)
2319 goto nuts;
2320
2321 gstio = GvIO(ggv);
2322 if (!gstio || !IoIFP(gstio))
2323 goto nuts;
2324
2325 nstio = GvIOn(ngv);
2326 if (IoIFP(nstio))
2327 do_close(ngv, FALSE);
2328
6ad3d225 2329 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *)&saddr, &len);
a0d0e21e
LW
2330 if (fd < 0)
2331 goto badexit;
760ac839
LW
2332 IoIFP(nstio) = PerlIO_fdopen(fd, "r");
2333 IoOFP(nstio) = PerlIO_fdopen(fd, "w");
50952442 2334 IoTYPE(nstio) = IoTYPE_SOCKET;
a0d0e21e 2335 if (!IoIFP(nstio) || !IoOFP(nstio)) {
760ac839
LW
2336 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2337 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
6ad3d225 2338 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
a0d0e21e
LW
2339 goto badexit;
2340 }
8d2a6795
GS
2341#if defined(HAS_FCNTL) && defined(F_SETFD)
2342 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2343#endif
a0d0e21e 2344
ed79a026
OF
2345#ifdef EPOC
2346 len = sizeof saddr; /* EPOC somehow truncates info */
2347#endif
2348
748a9306 2349 PUSHp((char *)&saddr, len);
a0d0e21e
LW
2350 RETURN;
2351
2352nuts:
599cee73 2353 if (ckWARN(WARN_CLOSED))
bc37a18f 2354 report_evil_fh(ggv, ggv ? GvIO(ggv) : 0, PL_op->op_type);
748a9306 2355 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW
2356
2357badexit:
2358 RETPUSHUNDEF;
2359
2360#else
cea2e8a9 2361 DIE(aTHX_ PL_no_sock_func, "accept");
a0d0e21e
LW
2362#endif
2363}
2364
2365PP(pp_shutdown)
2366{
4e35701f 2367 djSP; dTARGET;
a0d0e21e
LW
2368#ifdef HAS_SOCKET
2369 int how = POPi;
2370 GV *gv = (GV*)POPs;
2371 register IO *io = GvIOn(gv);
2372
2373 if (!io || !IoIFP(io))
2374 goto nuts;
2375
6ad3d225 2376 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
a0d0e21e
LW
2377 RETURN;
2378
2379nuts:
599cee73 2380 if (ckWARN(WARN_CLOSED))
bc37a18f 2381 report_evil_fh(gv, io, PL_op->op_type);
748a9306 2382 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW
2383 RETPUSHUNDEF;
2384#else
cea2e8a9 2385 DIE(aTHX_ PL_no_sock_func, "shutdown");
a0d0e21e
LW
2386#endif
2387}
2388
2389PP(pp_gsockopt)
2390{
2391#ifdef HAS_SOCKET
cea2e8a9 2392 return pp_ssockopt();
a0d0e21e 2393#else
cea2e8a9 2394 DIE(aTHX_ PL_no_sock_func, "getsockopt");
a0d0e21e
LW
2395#endif
2396}
2397
2398PP(pp_ssockopt)
2399{
4e35701f 2400 djSP;
a0d0e21e 2401#ifdef HAS_SOCKET
533c011a 2402 int optype = PL_op->op_type;
a0d0e21e
LW
2403 SV *sv;
2404 int fd;
2405 unsigned int optname;
2406 unsigned int lvl;
2407 GV *gv;
2408 register IO *io;
1e422769 2409 Sock_size_t len;
a0d0e21e
LW
2410
2411 if (optype == OP_GSOCKOPT)
2412 sv = sv_2mortal(NEWSV(22, 257));
2413 else
2414 sv = POPs;
2415 optname = (unsigned int) POPi;
2416 lvl = (unsigned int) POPi;
2417
2418 gv = (GV*)POPs;
2419 io = GvIOn(gv);
2420 if (!io || !IoIFP(io))
2421 goto nuts;
2422
760ac839 2423 fd = PerlIO_fileno(IoIFP(io));
a0d0e21e
LW
2424 switch (optype) {
2425 case OP_GSOCKOPT:
748a9306 2426 SvGROW(sv, 257);
a0d0e21e 2427 (void)SvPOK_only(sv);
748a9306
LW
2428 SvCUR_set(sv,256);
2429 *SvEND(sv) ='\0';
1e422769 2430 len = SvCUR(sv);
6ad3d225 2431 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
a0d0e21e 2432 goto nuts2;
1e422769 2433 SvCUR_set(sv, len);
748a9306 2434 *SvEND(sv) ='\0';
a0d0e21e
LW
2435 PUSHs(sv);
2436 break;
2437 case OP_SSOCKOPT: {
1e422769
PP
2438 char *buf;
2439 int aint;
2440 if (SvPOKp(sv)) {
2d8e6c8d
GS
2441 STRLEN l;
2442 buf = SvPV(sv, l);
2443 len = l;
1e422769 2444 }
56ee1660 2445 else {
a0d0e21e
LW
2446 aint = (int)SvIV(sv);
2447 buf = (char*)&aint;
2448 len = sizeof(int);
2449 }
6ad3d225 2450 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
a0d0e21e 2451 goto nuts2;
3280af22 2452 PUSHs(&PL_sv_yes);
a0d0e21e
LW
2453 }
2454 break;
2455 }
2456 RETURN;
2457
2458nuts:
599cee73 2459 if (ckWARN(WARN_CLOSED))
bc37a18f 2460 report_evil_fh(gv, io, optype);
748a9306 2461 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW
2462nuts2:
2463 RETPUSHUNDEF;
2464
2465#else
cea2e8a9 2466 DIE(aTHX_ PL_no_sock_func, "setsockopt");
a0d0e21e
LW
2467#endif
2468}
2469
2470PP(pp_getsockname)
2471{
2472#ifdef HAS_SOCKET
cea2e8a9 2473 return pp_getpeername();
a0d0e21e 2474#else
cea2e8a9 2475 DIE(aTHX_ PL_no_sock_func, "getsockname");
a0d0e21e
LW
2476#endif
2477}
2478
2479PP(pp_getpeername)
2480{
4e35701f 2481 djSP;
a0d0e21e 2482#ifdef HAS_SOCKET
533c011a 2483 int optype = PL_op->op_type;
a0d0e21e
LW
2484 SV *sv;
2485 int fd;
2486 GV *gv = (GV*)POPs;
2487 register IO *io = GvIOn(gv);
1e422769 2488 Sock_size_t len;
a0d0e21e
LW
2489
2490 if (!io || !IoIFP(io))
2491 goto nuts;
2492
2493 sv = sv_2mortal(NEWSV(22, 257));
748a9306 2494 (void)SvPOK_only(sv);
1e422769
PP
2495 len = 256;
2496 SvCUR_set(sv, len);
748a9306 2497 *SvEND(sv) ='\0';
760ac839 2498 fd = PerlIO_fileno(IoIFP(io));
a0d0e21e
LW
2499 switch (optype) {
2500 case OP_GETSOCKNAME:
6ad3d225 2501 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
a0d0e21e
LW
2502 goto nuts2;
2503 break;
2504 case OP_GETPEERNAME:
6ad3d225 2505 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
a0d0e21e 2506 goto nuts2;
490ab354
JH
2507#if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2508 {
2509 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";
2510 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2511 if (((struct sockaddr *)SvPVX(sv))->sa_family == AF_INET &&
2512 !memcmp((char *)SvPVX(sv) + sizeof(u_short), nowhere,
2513 sizeof(u_short) + sizeof(struct in_addr))) {
301e8125 2514 goto nuts2;
490ab354
JH
2515 }
2516 }
2517#endif
a0d0e21e
LW
2518 break;
2519 }
13826f2c
CS
2520#ifdef BOGUS_GETNAME_RETURN
2521 /* Interactive Unix, getpeername() and getsockname()
2522 does not return valid namelen */
1e422769
PP
2523 if (len == BOGUS_GETNAME_RETURN)
2524 len = sizeof(struct sockaddr);
13826f2c 2525#endif
1e422769 2526 SvCUR_set(sv, len);
748a9306 2527 *SvEND(sv) ='\0';
a0d0e21e
LW
2528 PUSHs(sv);
2529 RETURN;
2530
2531nuts:
599cee73 2532 if (ckWARN(WARN_CLOSED))
bc37a18f 2533 report_evil_fh(gv, io, optype);
748a9306 2534 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW
2535nuts2:
2536 RETPUSHUNDEF;
2537
2538#else
cea2e8a9 2539 DIE(aTHX_ PL_no_sock_func, "getpeername");
a0d0e21e
LW
2540#endif
2541}
2542
2543/* Stat calls. */
2544
2545PP(pp_lstat)
2546{
cea2e8a9 2547 return pp_stat();
a0d0e21e
LW
2548}
2549
2550PP(pp_stat)
2551{
4e35701f 2552 djSP;
2dd78f96 2553 GV *gv;
54310121 2554 I32 gimme;
a0d0e21e 2555 I32 max = 13;
2d8e6c8d 2556 STRLEN n_a;
a0d0e21e 2557
533c011a 2558 if (PL_op->op_flags & OPf_REF) {
2dd78f96 2559 gv = cGVOP_gv;
8a4e5b40
DD
2560 if (PL_op->op_type == OP_LSTAT) {
2561 if (PL_laststype != OP_LSTAT)
2562 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2563 if (ckWARN(WARN_IO) && gv != PL_defgv)
2564 Perl_warner(aTHX_ WARN_IO,
2dd78f96 2565 "lstat() on filehandle %s", GvENAME(gv));
8a4e5b40
DD
2566 /* Perl_my_lstat (-l) croak's on filehandle, why warn here? */
2567 }
2568
748a9306 2569 do_fstat:
2dd78f96 2570 if (gv != PL_defgv) {
3280af22 2571 PL_laststype = OP_STAT;
2dd78f96 2572 PL_statgv = gv;
3280af22 2573 sv_setpv(PL_statname, "");
2dd78f96
JH
2574 PL_laststatval = (GvIO(gv) && IoIFP(GvIOp(gv))
2575 ? PerlLIO_fstat(PerlIO_fileno(IoIFP(GvIOn(gv))), &PL_statcache) : -1);
a0d0e21e 2576 }
9ddeeac9 2577 if (PL_laststatval < 0) {
2dd78f96
JH
2578 dTHR;
2579 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2580 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
a0d0e21e 2581 max = 0;
9ddeeac9 2582 }
a0d0e21e
LW
2583 }
2584 else {
748a9306
LW
2585 SV* sv = POPs;
2586 if (SvTYPE(sv) == SVt_PVGV) {
2dd78f96 2587 gv = (GV*)sv;
748a9306
LW
2588 goto do_fstat;
2589 }
2590 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2dd78f96 2591 gv = (GV*)SvRV(sv);
748a9306
LW
2592 goto do_fstat;
2593 }
2d8e6c8d 2594 sv_setpv(PL_statname, SvPV(sv,n_a));
3280af22 2595 PL_statgv = Nullgv;
a0d0e21e 2596#ifdef HAS_LSTAT
533c011a
NIS
2597 PL_laststype = PL_op->op_type;
2598 if (PL_op->op_type == OP_LSTAT)
2d8e6c8d 2599 PL_laststatval = PerlLIO_lstat(SvPV(PL_statname, n_a), &PL_statcache);
a0d0e21e
LW
2600 else
2601#endif
2d8e6c8d 2602 PL_laststatval = PerlLIO_stat(SvPV(PL_statname, n_a), &PL_statcache);
3280af22 2603 if (PL_laststatval < 0) {
2d8e6c8d 2604 if (ckWARN(WARN_NEWLINE) && strchr(SvPV(PL_statname, n_a), '\n'))
cea2e8a9 2605 Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "stat");
a0d0e21e
LW
2606 max = 0;
2607 }
2608 }
2609
54310121
PP
2610 gimme = GIMME_V;
2611 if (gimme != G_ARRAY) {
2612 if (gimme != G_VOID)
2613 XPUSHs(boolSV(max));
2614 RETURN;
a0d0e21e
LW
2615 }
2616 if (max) {
36477c24
PP
2617 EXTEND(SP, max);
2618 EXTEND_MORTAL(max);
1ff81528
PL
2619 PUSHs(sv_2mortal(newSViv(PL_statcache.st_dev)));
2620 PUSHs(sv_2mortal(newSViv(PL_statcache.st_ino)));
b448e4fe
JH
2621 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_mode)));
2622 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_nlink)));
146174a9
CB
2623#if Uid_t_size > IVSIZE
2624 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_uid)));
2625#else
23dcd6c8 2626# if Uid_t_sign <= 0
1ff81528 2627 PUSHs(sv_2mortal(newSViv(PL_statcache.st_uid)));
23dcd6c8
JH
2628# else
2629 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_uid)));
2630# endif
146174a9 2631#endif
301e8125 2632#if Gid_t_size > IVSIZE
146174a9
CB
2633 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_gid)));
2634#else
23dcd6c8 2635# if Gid_t_sign <= 0
1ff81528 2636 PUSHs(sv_2mortal(newSViv(PL_statcache.st_gid)));
23dcd6c8
JH
2637# else
2638 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_gid)));
2639# endif
146174a9 2640#endif
cbdc8872 2641#ifdef USE_STAT_RDEV
1ff81528 2642 PUSHs(sv_2mortal(newSViv(PL_statcache.st_rdev)));
cbdc8872 2643#else
79cb57f6 2644 PUSHs(sv_2mortal(newSVpvn("", 0)));
cbdc8872 2645#endif
146174a9
CB
2646#if Off_t_size > IVSIZE
2647 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_size)));
2648#else
1ff81528 2649 PUSHs(sv_2mortal(newSViv(PL_statcache.st_size)));
146174a9 2650#endif
cbdc8872 2651#ifdef BIG_TIME
172ae379
JH
2652 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_atime)));
2653 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_mtime)));
2654 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_ctime)));
cbdc8872 2655#else
1ff81528
PL
2656 PUSHs(sv_2mortal(newSViv(PL_statcache.st_atime)));
2657 PUSHs(sv_2mortal(newSViv(PL_statcache.st_mtime)));
2658 PUSHs(sv_2mortal(newSViv(PL_statcache.st_ctime)));
cbdc8872 2659#endif
a0d0e21e 2660#ifdef USE_STAT_BLOCKS
b448e4fe
JH
2661 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blksize)));
2662 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blocks)));
a0d0e21e 2663#else
79cb57f6
GS
2664 PUSHs(sv_2mortal(newSVpvn("", 0)));
2665 PUSHs(sv_2mortal(newSVpvn("", 0)));
a0d0e21e
LW
2666#endif
2667 }
2668 RETURN;
2669}
2670
2671PP(pp_ftrread)
2672{
5ff3f7a4 2673 I32 result;
4e35701f 2674 djSP;
5ff3f7a4 2675#if defined(HAS_ACCESS) && defined(R_OK)
2d8e6c8d 2676 STRLEN n_a;
5ff3f7a4 2677 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2678 result = access(TOPpx, R_OK);
5ff3f7a4
GS
2679 if (result == 0)
2680 RETPUSHYES;
2681 if (result < 0)
2682 RETPUSHUNDEF;
2683 RETPUSHNO;
22865c03
GS
2684 }
2685 else
cea2e8a9 2686 result = my_stat();
5ff3f7a4 2687#else
cea2e8a9 2688 result = my_stat();
5ff3f7a4 2689#endif
22865c03 2690 SPAGAIN;
a0d0e21e
LW
2691 if (result < 0)
2692 RETPUSHUNDEF;
3280af22 2693 if (cando(S_IRUSR, 0, &PL_statcache))
a0d0e21e
LW
2694 RETPUSHYES;
2695 RETPUSHNO;
2696}
2697
2698PP(pp_ftrwrite)
2699{
5ff3f7a4 2700 I32 result;
4e35701f 2701 djSP;
5ff3f7a4 2702#if defined(HAS_ACCESS) && defined(W_OK)
2d8e6c8d 2703 STRLEN n_a;
5ff3f7a4 2704 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2705 result = access(TOPpx, W_OK);
5ff3f7a4
GS
2706 if (result == 0)
2707 RETPUSHYES;
2708 if (result < 0)
2709 RETPUSHUNDEF;
2710 RETPUSHNO;
22865c03
GS
2711 }
2712 else
cea2e8a9 2713 result = my_stat();
5ff3f7a4 2714#else
cea2e8a9 2715 result = my_stat();
5ff3f7a4 2716#endif
22865c03 2717 SPAGAIN;
a0d0e21e
LW
2718 if (result < 0)
2719 RETPUSHUNDEF;
3280af22 2720 if (cando(S_IWUSR, 0, &PL_statcache))
a0d0e21e
LW
2721 RETPUSHYES;
2722 RETPUSHNO;
2723}
2724
2725PP(pp_ftrexec)
2726{
5ff3f7a4 2727 I32 result;
4e35701f 2728 djSP;
5ff3f7a4 2729#if defined(HAS_ACCESS) && defined(X_OK)
2d8e6c8d 2730 STRLEN n_a;
5ff3f7a4 2731 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2732 result = access(TOPpx, X_OK);
5ff3f7a4
GS
2733 if (result == 0)
2734 RETPUSHYES;
2735 if (result < 0)
2736 RETPUSHUNDEF;
2737 RETPUSHNO;
22865c03
GS
2738 }
2739 else
cea2e8a9 2740 result = my_stat();
5ff3f7a4 2741#else
cea2e8a9 2742 result = my_stat();
5ff3f7a4 2743#endif
22865c03 2744 SPAGAIN;
a0d0e21e
LW
2745 if (result < 0)
2746 RETPUSHUNDEF;
3280af22 2747 if (cando(S_IXUSR, 0, &PL_statcache))
a0d0e21e
LW
2748 RETPUSHYES;
2749 RETPUSHNO;
2750}
2751
2752PP(pp_fteread)
2753{
5ff3f7a4 2754 I32 result;
4e35701f 2755 djSP;
5ff3f7a4 2756#ifdef PERL_EFF_ACCESS_R_OK
2d8e6c8d 2757 STRLEN n_a;
5ff3f7a4 2758 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2759 result = PERL_EFF_ACCESS_R_OK(TOPpx);
5ff3f7a4
GS
2760 if (result == 0)
2761 RETPUSHYES;
2762 if (result < 0)
2763 RETPUSHUNDEF;
2764 RETPUSHNO;
22865c03
GS
2765 }
2766 else
cea2e8a9 2767 result = my_stat();
5ff3f7a4 2768#else
cea2e8a9 2769 result = my_stat();
5ff3f7a4 2770#endif
22865c03 2771 SPAGAIN;
a0d0e21e
LW
2772 if (result < 0)
2773 RETPUSHUNDEF;
3280af22 2774 if (cando(S_IRUSR, 1, &PL_statcache))
a0d0e21e
LW
2775 RETPUSHYES;
2776 RETPUSHNO;
2777}
2778
2779PP(pp_ftewrite)
2780{
5ff3f7a4 2781 I32 result;
4e35701f 2782 djSP;
5ff3f7a4 2783#ifdef PERL_EFF_ACCESS_W_OK
2d8e6c8d 2784 STRLEN n_a;
5ff3f7a4 2785 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2786 result = PERL_EFF_ACCESS_W_OK(TOPpx);
5ff3f7a4
GS
2787 if (result == 0)
2788 RETPUSHYES;
2789 if (result < 0)
2790 RETPUSHUNDEF;
2791 RETPUSHNO;
22865c03
GS
2792 }
2793 else
cea2e8a9 2794 result = my_stat();
5ff3f7a4 2795#else
cea2e8a9 2796 result = my_stat();
5ff3f7a4 2797#endif
22865c03 2798 SPAGAIN;
a0d0e21e
LW
2799 if (result < 0)
2800 RETPUSHUNDEF;
3280af22 2801 if (cando(S_IWUSR, 1, &PL_statcache))
a0d0e21e
LW
2802 RETPUSHYES;
2803 RETPUSHNO;
2804}
2805
2806PP(pp_fteexec)
2807{
5ff3f7a4 2808 I32 result;
4e35701f 2809 djSP;
5ff3f7a4 2810#ifdef PERL_EFF_ACCESS_X_OK
2d8e6c8d 2811 STRLEN n_a;
5ff3f7a4 2812 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2813 result = PERL_EFF_ACCESS_X_OK(TOPpx);
5ff3f7a4
GS
2814 if (result == 0)
2815 RETPUSHYES;
2816 if (result < 0)
2817 RETPUSHUNDEF;
2818 RETPUSHNO;
22865c03
GS
2819 }
2820 else
cea2e8a9 2821 result = my_stat();
5ff3f7a4 2822#else
cea2e8a9 2823 result = my_stat();
5ff3f7a4 2824#endif
22865c03 2825 SPAGAIN;
a0d0e21e
LW
2826 if (result < 0)
2827 RETPUSHUNDEF;
3280af22 2828 if (cando(S_IXUSR, 1, &PL_statcache))
a0d0e21e
LW
2829 RETPUSHYES;
2830 RETPUSHNO;
2831}
2832
2833PP(pp_ftis)
2834{
cea2e8a9 2835 I32 result = my_stat();
4e35701f 2836 djSP;
a0d0e21e
LW
2837 if (result < 0)
2838 RETPUSHUNDEF;
2839 RETPUSHYES;
2840}
2841
2842PP(pp_fteowned)
2843{
cea2e8a9 2844 return pp_ftrowned();
a0d0e21e
LW
2845}
2846
2847PP(pp_ftrowned)
2848{
cea2e8a9 2849 I32 result = my_stat();
4e35701f 2850 djSP;
a0d0e21e
LW
2851 if (result < 0)
2852 RETPUSHUNDEF;
146174a9
CB
2853 if (PL_statcache.st_uid == (PL_op->op_type == OP_FTEOWNED ?
2854 PL_euid : PL_uid) )
a0d0e21e
LW
2855 RETPUSHYES;
2856 RETPUSHNO;
2857}
2858
2859PP(pp_ftzero)
2860{
cea2e8a9 2861 I32 result = my_stat();
4e35701f 2862 djSP;
a0d0e21e
LW
2863 if (result < 0)
2864 RETPUSHUNDEF;
146174a9 2865 if (PL_statcache.st_size == 0)
a0d0e21e
LW
2866 RETPUSHYES;
2867 RETPUSHNO;
2868}
2869
2870PP(pp_ftsize)
2871{
cea2e8a9 2872 I32 result = my_stat();
4e35701f 2873 djSP; dTARGET;
a0d0e21e
LW
2874 if (result < 0)
2875 RETPUSHUNDEF;
146174a9
CB
2876#if Off_t_size > IVSIZE
2877 PUSHn(PL_statcache.st_size);
2878#else
3280af22 2879 PUSHi(PL_statcache.st_size);
146174a9 2880#endif
a0d0e21e
LW
2881 RETURN;
2882}
2883
2884PP(pp_ftmtime)
2885{
cea2e8a9 2886 I32 result = my_stat();
4e35701f 2887 djSP; dTARGET;
a0d0e21e
LW
2888 if (result < 0)
2889 RETPUSHUNDEF;
c6419e06 2890 PUSHn( (PL_basetime - PL_statcache.st_mtime) / 86400.0 );
a0d0e21e
LW
2891 RETURN;
2892}
2893
2894PP(pp_ftatime)
2895{
cea2e8a9 2896 I32 result = my_stat();
4e35701f 2897 djSP; dTARGET;
a0d0e21e
LW
2898 if (result < 0)
2899 RETPUSHUNDEF;
c6419e06 2900 PUSHn( (PL_basetime - PL_statcache.st_atime) / 86400.0 );
a0d0e21e
LW
2901 RETURN;
2902}
2903
2904PP(pp_ftctime)
2905{
cea2e8a9 2906 I32 result = my_stat();
4e35701f 2907 djSP; dTARGET;
a0d0e21e
LW
2908 if (result < 0)
2909 RETPUSHUNDEF;
c6419e06 2910 PUSHn( (PL_basetime - PL_statcache.st_ctime) / 86400.0 );
a0d0e21e
LW
2911 RETURN;
2912}
2913
2914PP(pp_ftsock)
2915{
cea2e8a9 2916 I32 result = my_stat();
4e35701f 2917 djSP;
a0d0e21e
LW
2918 if (result < 0)
2919 RETPUSHUNDEF;
3280af22 2920 if (S_ISSOCK(PL_statcache.st_mode))
a0d0e21e
LW
2921 RETPUSHYES;
2922 RETPUSHNO;
2923}
2924
2925PP(pp_ftchr)
2926{
cea2e8a9 2927 I32 result = my_stat();
4e35701f 2928 djSP;
a0d0e21e
LW
2929 if (result < 0)
2930 RETPUSHUNDEF;
3280af22 2931 if (S_ISCHR(PL_statcache.st_mode))
a0d0e21e
LW
2932 RETPUSHYES;
2933 RETPUSHNO;
2934}
2935
2936PP(pp_ftblk)
2937{
cea2e8a9 2938 I32 result = my_stat();
4e35701f 2939 djSP;
a0d0e21e
LW
2940 if (result < 0)
2941 RETPUSHUNDEF;
3280af22 2942 if (S_ISBLK(PL_statcache.st_mode))
a0d0e21e
LW
2943 RETPUSHYES;
2944 RETPUSHNO;
2945}
2946
2947PP(pp_ftfile)
2948{
cea2e8a9 2949 I32 result = my_stat();
4e35701f 2950 djSP;
a0d0e21e
LW
2951 if (result < 0)
2952 RETPUSHUNDEF;
3280af22 2953 if (S_ISREG(PL_statcache.st_mode))
a0d0e21e
LW
2954 RETPUSHYES;
2955 RETPUSHNO;
2956}
2957
2958PP(pp_ftdir)
2959{
cea2e8a9 2960 I32 result = my_stat();
4e35701f 2961 djSP;
a0d0e21e
LW
2962 if (result < 0)
2963 RETPUSHUNDEF;
3280af22 2964 if (S_ISDIR(PL_statcache.st_mode))
a0d0e21e
LW
2965 RETPUSHYES;
2966 RETPUSHNO;
2967}
2968
2969PP(pp_ftpipe)
2970{
cea2e8a9 2971 I32 result = my_stat();
4e35701f 2972 djSP;
a0d0e21e
LW
2973 if (result < 0)
2974 RETPUSHUNDEF;
3280af22 2975 if (S_ISFIFO(PL_statcache.st_mode))
a0d0e21e
LW
2976 RETPUSHYES;
2977 RETPUSHNO;
2978}
2979
2980PP(pp_ftlink)
2981{
cea2e8a9 2982 I32 result = my_lstat();
4e35701f 2983 djSP;
a0d0e21e
LW
2984 if (result < 0)
2985 RETPUSHUNDEF;
3280af22 2986 if (S_ISLNK(PL_statcache.st_mode))
a0d0e21e
LW
2987 RETPUSHYES;
2988 RETPUSHNO;
2989}
2990
2991PP(pp_ftsuid)
2992{
4e35701f 2993 djSP;
a0d0e21e 2994#ifdef S_ISUID
cea2e8a9 2995 I32 result = my_stat();
a0d0e21e
LW
2996 SPAGAIN;
2997 if (result < 0)
2998 RETPUSHUNDEF;
3280af22 2999 if (PL_statcache.st_mode & S_ISUID)
a0d0e21e
LW
3000 RETPUSHYES;
3001#endif
3002 RETPUSHNO;
3003}
3004
3005PP(pp_ftsgid)
3006{
4e35701f 3007 djSP;
a0d0e21e 3008#ifdef S_ISGID
cea2e8a9 3009 I32 result = my_stat();
a0d0e21e
LW
3010 SPAGAIN;
3011 if (result < 0)
3012 RETPUSHUNDEF;
3280af22 3013 if (PL_statcache.st_mode & S_ISGID)
a0d0e21e
LW
3014 RETPUSHYES;
3015#endif
3016 RETPUSHNO;
3017}
3018
3019PP(pp_ftsvtx)
3020{
4e35701f 3021 djSP;
a0d0e21e 3022#ifdef S_ISVTX
cea2e8a9 3023 I32 result = my_stat();
a0d0e21e
LW
3024 SPAGAIN;
3025 if (result < 0)
3026 RETPUSHUNDEF;
3280af22 3027 if (PL_statcache.st_mode & S_ISVTX)
a0d0e21e
LW
3028 RETPUSHYES;
3029#endif
3030 RETPUSHNO;
3031}
3032
3033PP(pp_fttty)
3034{
4e35701f 3035 djSP;
a0d0e21e
LW
3036 int fd;
3037 GV *gv;
fb73857a 3038 char *tmps = Nullch;
2d8e6c8d 3039 STRLEN n_a;
fb73857a 3040
533c011a 3041 if (PL_op->op_flags & OPf_REF)
146174a9 3042 gv = cGVOP_gv;
fb73857a
PP
3043 else if (isGV(TOPs))
3044 gv = (GV*)POPs;
3045 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3046 gv = (GV*)SvRV(POPs);
a0d0e21e 3047 else
2d8e6c8d 3048 gv = gv_fetchpv(tmps = POPpx, FALSE, SVt_PVIO);
fb73857a 3049
a0d0e21e 3050 if (GvIO(gv) && IoIFP(GvIOp(gv)))
760ac839 3051 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
fb73857a 3052 else if (tmps && isDIGIT(*tmps))
a0d0e21e
LW
3053 fd = atoi(tmps);
3054 else
3055 RETPUSHUNDEF;
6ad3d225 3056 if (PerlLIO_isatty(fd))
a0d0e21e
LW
3057 RETPUSHYES;
3058 RETPUSHNO;
3059}
3060
16d20bd9
AD
3061#if defined(atarist) /* this will work with atariST. Configure will
3062 make guesses for other systems. */
3063# define FILE_base(f) ((f)->_base)
3064# define FILE_ptr(f) ((f)->_ptr)
3065# define FILE_cnt(f) ((f)->_cnt)
3066# define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
a0d0e21e
LW
3067#endif
3068
3069PP(pp_fttext)
3070{
4e35701f 3071 djSP;
a0d0e21e
LW
3072 I32 i;
3073 I32 len;
3074 I32 odd = 0;
3075 STDCHAR tbuf[512];
3076 register STDCHAR *s;
3077 register IO *io;
5f05dabc
PP
3078 register SV *sv;
3079 GV *gv;
2d8e6c8d 3080 STRLEN n_a;
146174a9 3081 PerlIO *fp;
a0d0e21e 3082
533c011a 3083 if (PL_op->op_flags & OPf_REF)
146174a9 3084 gv = cGVOP_gv;
5f05dabc
PP
3085 else if (isGV(TOPs))
3086 gv = (GV*)POPs;
3087 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3088 gv = (GV*)SvRV(POPs);
3089 else
3090 gv = Nullgv;
3091
3092 if (gv) {
a0d0e21e 3093 EXTEND(SP, 1);
3280af22
NIS
3094 if (gv == PL_defgv) {
3095 if (PL_statgv)
3096 io = GvIO(PL_statgv);
a0d0e21e 3097 else {
3280af22 3098 sv = PL_statname;
a0d0e21e
LW
3099 goto really_filename;
3100 }
3101 }
3102 else {
3280af22
NIS
3103 PL_statgv = gv;
3104 PL_laststatval = -1;
3105 sv_setpv(PL_statname, "");
3106 io = GvIO(PL_statgv);
a0d0e21e
LW
3107 }
3108 if (io && IoIFP(io)) {
5f05dabc 3109 if (! PerlIO_has_base(IoIFP(io)))
cea2e8a9 3110 DIE(aTHX_ "-T and -B not implemented on filehandles");
3280af22
NIS
3111 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3112 if (PL_laststatval < 0)
5f05dabc 3113 RETPUSHUNDEF;
3280af22 3114 if (S_ISDIR(PL_statcache.st_mode)) /* handle NFS glitch */
533c011a 3115 if (PL_op->op_type == OP_FTTEXT)
a0d0e21e
LW
3116 RETPUSHNO;
3117 else
3118 RETPUSHYES;
a20bf0c3 3119 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
760ac839 3120 i = PerlIO_getc(IoIFP(io));
a0d0e21e 3121 if (i != EOF)
760ac839 3122 (void)PerlIO_ungetc(IoIFP(io),i);
a0d0e21e 3123 }
a20bf0c3 3124 if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
a0d0e21e 3125 RETPUSHYES;
a20bf0c3
JH
3126 len = PerlIO_get_bufsiz(IoIFP(io));
3127 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
760ac839
LW
3128 /* sfio can have large buffers - limit to 512 */
3129 if (len > 512)
3130 len = 512;
a0d0e21e
LW
3131 }
3132 else {
2dd78f96
JH
3133 dTHR;
3134 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
146174a9 3135 gv = cGVOP_gv;
2dd78f96 3136 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
146174a9 3137 }
748a9306 3138 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW
3139 RETPUSHUNDEF;
3140 }
3141 }
3142 else {
3143 sv = POPs;
5f05dabc 3144 really_filename:
3280af22
NIS
3145 PL_statgv = Nullgv;
3146 PL_laststatval = -1;
2d8e6c8d 3147 sv_setpv(PL_statname, SvPV(sv, n_a));
146174a9 3148 if (!(fp = PerlIO_open(SvPVX(PL_statname), "r"))) {
2d8e6c8d 3149 if (ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, n_a), '\n'))
cea2e8a9 3150 Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "open");
a0d0e21e
LW
3151 RETPUSHUNDEF;
3152 }
146174a9
CB
3153 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3154 if (PL_laststatval < 0) {
3155 (void)PerlIO_close(fp);
5f05dabc 3156 RETPUSHUNDEF;
146174a9 3157 }
92d29cee 3158 do_binmode(fp, '<', O_BINARY);
146174a9
CB
3159 len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3160 (void)PerlIO_close(fp);
a0d0e21e 3161 if (len <= 0) {
533c011a 3162 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
a0d0e21e
LW
3163 RETPUSHNO; /* special case NFS directories */
3164 RETPUSHYES; /* null file is anything */
3165 }
3166 s = tbuf;
3167 }
3168
3169 /* now scan s to look for textiness */
4633a7c4 3170 /* XXX ASCII dependent code */
a0d0e21e 3171
146174a9
CB
3172#if defined(DOSISH) || defined(USEMYBINMODE)
3173 /* ignore trailing ^Z on short files */
3174 if (len && len < sizeof(tbuf) && tbuf[len-1] == 26)
3175 --len;
3176#endif
3177
a0d0e21e
LW
3178 for (i = 0; i < len; i++, s++) {
3179 if (!*s) { /* null never allowed in text */
3180 odd += len;
3181 break;
3182 }
9d116dd7 3183#ifdef EBCDIC
301e8125 3184 else if (!(isPRINT(*s) || isSPACE(*s)))
9d116dd7
JH
3185 odd++;
3186#else
146174a9
CB
3187 else if (*s & 128) {
3188#ifdef USE_LOCALE
b3f66c68
GS
3189 if ((PL_op->op_private & OPpLOCALE) && isALPHA_LC(*s))
3190 continue;
3191#endif
3192 /* utf8 characters don't count as odd */
3193 if (*s & 0x40) {
3194 int ulen = UTF8SKIP(s);
3195 if (ulen < len - i) {
3196 int j;
3197 for (j = 1; j < ulen; j++) {
3198 if ((s[j] & 0xc0) != 0x80)
3199 goto not_utf8;
3200 }
3201 --ulen; /* loop does extra increment */
3202 s += ulen;
3203 i += ulen;
3204 continue;
3205 }
3206 }
3207 not_utf8:
3208 odd++;
146174a9 3209 }
a0d0e21e
LW
3210 else if (*s < 32 &&
3211 *s != '\n' && *s != '\r' && *s != '\b' &&
3212 *s != '\t' && *s != '\f' && *s != 27)
3213 odd++;
9d116dd7 3214#endif
a0d0e21e
LW
3215 }
3216
533c011a 3217 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
a0d0e21e
LW
3218 RETPUSHNO;
3219 else
3220 RETPUSHYES;
3221}
3222
3223PP(pp_ftbinary)
3224{
cea2e8a9 3225 return pp_fttext();
a0d0e21e
LW
3226}
3227
3228/* File calls. */
3229
3230PP(pp_chdir)
3231{
4e35701f 3232 djSP; dTARGET;
a0d0e21e
LW
3233 char *tmps;
3234 SV **svp;
2d8e6c8d 3235 STRLEN n_a;
a0d0e21e
LW
3236
3237 if (MAXARG < 1)
3238 tmps = Nullch;
3239 else
2d8e6c8d 3240 tmps = POPpx;
a0d0e21e 3241 if (!tmps || !*tmps) {
3280af22 3242 svp = hv_fetch(GvHVn(PL_envgv), "HOME", 4, FALSE);
a0d0e21e 3243 if (svp)
2d8e6c8d 3244 tmps = SvPV(*svp, n_a);
a0d0e21e
LW
3245 }
3246 if (!tmps || !*tmps) {
3280af22 3247 svp = hv_fetch(GvHVn(PL_envgv), "LOGDIR", 6, FALSE);
a0d0e21e 3248 if (svp)
2d8e6c8d 3249 tmps = SvPV(*svp, n_a);
a0d0e21e 3250 }
491527d0
GS
3251#ifdef VMS
3252 if (!tmps || !*tmps) {
6b88bc9c 3253 svp = hv_fetch(GvHVn(PL_envgv), "SYS$LOGIN", 9, FALSE);
491527d0 3254 if (svp)
2d8e6c8d 3255 tmps = SvPV(*svp, n_a);
491527d0
GS
3256 }
3257#endif
a0d0e21e 3258 TAINT_PROPER("chdir");
6ad3d225 3259 PUSHi( PerlDir_chdir(tmps) >= 0 );
748a9306
LW
3260#ifdef VMS
3261 /* Clear the DEFAULT element of ENV so we'll get the new value
3262 * in the future. */
6b88bc9c 3263 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
748a9306 3264#endif
a0d0e21e
LW
3265 RETURN;
3266}
3267
3268PP(pp_chown)
3269{
4e35701f 3270 djSP; dMARK; dTARGET;
a0d0e21e
LW
3271 I32 value;
3272#ifdef HAS_CHOWN
533c011a 3273 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW
3274 SP = MARK;
3275 PUSHi(value);
3276 RETURN;
3277#else
cea2e8a9 3278 DIE(aTHX_ PL_no_func, "Unsupported function chown");
a0d0e21e
LW
3279#endif
3280}
3281
3282PP(pp_chroot)
3283{
4e35701f 3284 djSP; dTARGET;
a0d0e21e
LW
3285 char *tmps;
3286#ifdef HAS_CHROOT
2d8e6c8d
GS
3287 STRLEN n_a;
3288 tmps = POPpx;
a0d0e21e
LW
3289 TAINT_PROPER("chroot");
3290 PUSHi( chroot(tmps) >= 0 );
3291 RETURN;
3292#else
cea2e8a9 3293 DIE(aTHX_ PL_no_func, "chroot");
a0d0e21e
LW
3294#endif
3295}
3296
3297PP(pp_unlink)
3298{
4e35701f 3299 djSP; dMARK; dTARGET;
a0d0e21e 3300 I32 value;
533c011a 3301 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW
3302 SP = MARK;
3303 PUSHi(value);
3304 RETURN;
3305}
3306
3307PP(pp_chmod)
3308{
4e35701f 3309 djSP; dMARK; dTARGET;
a0d0e21e 3310 I32 value;
533c011a 3311 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW
3312 SP = MARK;
3313 PUSHi(value);
3314 RETURN;
3315}
3316
3317PP(pp_utime)
3318{
4e35701f 3319 djSP; dMARK; dTARGET;
a0d0e21e 3320 I32 value;
533c011a 3321 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW
3322 SP = MARK;
3323 PUSHi(value);
3324 RETURN;
3325}
3326
3327PP(pp_rename)
3328{
4e35701f 3329 djSP; dTARGET;
a0d0e21e 3330 int anum;
2d8e6c8d 3331 STRLEN n_a;
a0d0e21e 3332
2d8e6c8d
GS
3333 char *tmps2 = POPpx;
3334 char *tmps = SvPV(TOPs, n_a);
a0d0e21e
LW
3335 TAINT_PROPER("rename");
3336#ifdef HAS_RENAME
baed7233 3337 anum = PerlLIO_rename(tmps, tmps2);
a0d0e21e 3338#else
6b88bc9c 3339 if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
ed969818
WK
3340 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3341 anum = 1;
3342 else {
3654eb6c 3343 if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
ed969818
WK
3344 (void)UNLINK(tmps2);
3345 if (!(anum = link(tmps, tmps2)))
3346 anum = UNLINK(tmps);
3347 }
a0d0e21e
LW
3348 }
3349#endif
3350 SETi( anum >= 0 );
3351 RETURN;
3352}
3353
3354PP(pp_link)
3355{
4e35701f 3356 djSP; dTARGET;
a0d0e21e 3357#ifdef HAS_LINK
2d8e6c8d
GS
3358 STRLEN n_a;
3359 char *tmps2 = POPpx;
3360 char *tmps = SvPV(TOPs, n_a);
a0d0e21e 3361 TAINT_PROPER("link");
146174a9 3362 SETi( PerlLIO_link(tmps, tmps2) >= 0 );
a0d0e21e 3363#else
cea2e8a9 3364 DIE(aTHX_ PL_no_func, "Unsupported function link");
a0d0e21e
LW
3365#endif
3366 RETURN;
3367}
3368
3369PP(pp_symlink)
3370{
4e35701f 3371 djSP; dTARGET;
a0d0e21e 3372#ifdef HAS_SYMLINK
2d8e6c8d
GS
3373 STRLEN n_a;
3374 char *tmps2 = POPpx;
3375 char *tmps = SvPV(TOPs, n_a);
a0d0e21e
LW
3376 TAINT_PROPER("symlink");
3377 SETi( symlink(tmps, tmps2) >= 0 );
3378 RETURN;
3379#else
cea2e8a9 3380 DIE(aTHX_ PL_no_func, "symlink");
a0d0e21e
LW
3381#endif
3382}
3383
3384PP(pp_readlink)
3385{
4e35701f 3386 djSP; dTARGET;
a0d0e21e
LW
3387#ifdef HAS_SYMLINK
3388 char *tmps;
46fc3d4c 3389 char buf[MAXPATHLEN];
a0d0e21e 3390 int len;
2d8e6c8d 3391 STRLEN n_a;
46fc3d4c 3392
fb73857a
PP
3393#ifndef INCOMPLETE_TAINTS
3394 TAINT;
3395#endif
2d8e6c8d 3396 tmps = POPpx;
a0d0e21e
LW
3397 len = readlink(tmps, buf, sizeof buf);
3398 EXTEND(SP, 1);
3399 if (len < 0)
3400 RETPUSHUNDEF;
3401 PUSHp(buf, len);
3402 RETURN;
3403#else
3404 EXTEND(SP, 1);
3405 RETSETUNDEF; /* just pretend it's a normal file */
3406#endif
3407}
3408
3409#if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
ba106d47 3410STATIC int
cea2e8a9 3411S_dooneliner(pTHX_ char *cmd, char *filename)
a0d0e21e 3412{
1e422769
PP
3413 char *save_filename = filename;
3414 char *cmdline;
3415 char *s;
760ac839 3416 PerlIO *myfp;
1e422769 3417 int anum = 1;
a0d0e21e 3418
1e422769
PP
3419 New(666, cmdline, strlen(cmd) + (strlen(filename) * 2) + 10, char);
3420 strcpy(cmdline, cmd);
3421 strcat(cmdline, " ");
3422 for (s = cmdline + strlen(cmdline); *filename; ) {
a0d0e21e
LW
3423 *s++ = '\\';
3424 *s++ = *filename++;
3425 }
3426 strcpy(s, " 2>&1");
6ad3d225 3427 myfp = PerlProc_popen(cmdline, "r");
1e422769
PP
3428 Safefree(cmdline);
3429
a0d0e21e 3430 if (myfp) {
1e422769 3431 SV *tmpsv = sv_newmortal();
6b88bc9c 3432 /* Need to save/restore 'PL_rs' ?? */
760ac839 3433 s = sv_gets(tmpsv, myfp, 0);
6ad3d225 3434 (void)PerlProc_pclose(myfp);
a0d0e21e 3435 if (s != Nullch) {
1e422769
PP
3436 int e;
3437 for (e = 1;
a0d0e21e 3438#ifdef HAS_SYS_ERRLIST
1e422769
PP
3439 e <= sys_nerr
3440#endif
3441 ; e++)
3442 {
3443 /* you don't see this */
3444 char *errmsg =
3445#ifdef HAS_SYS_ERRLIST
3446 sys_errlist[e]
a0d0e21e 3447#else
1e422769 3448 strerror(e)
a0d0e21e 3449#endif
1e422769
PP
3450 ;
3451 if (!errmsg)
3452 break;
3453 if (instr(s, errmsg)) {
3454 SETERRNO(e,0);
3455 return 0;
3456 }
a0d0e21e 3457 }
748a9306 3458 SETERRNO(0,0);
a0d0e21e
LW
3459#ifndef EACCES
3460#define EACCES EPERM
3461#endif
1e422769 3462 if (instr(s, "cannot make"))
748a9306 3463 SETERRNO(EEXIST,RMS$_FEX);
1e422769 3464 else if (instr(s, "existing file"))
748a9306 3465 SETERRNO(EEXIST,RMS$_FEX);
1e422769 3466 else if (instr(s, "ile exists"))
748a9306 3467 SETERRNO(EEXIST,RMS$_FEX);
1e422769 3468 else if (instr(s, "non-exist"))
748a9306 3469 SETERRNO(ENOENT,RMS$_FNF);
1e422769 3470 else if (instr(s, "does not exist"))
748a9306 3471 SETERRNO(ENOENT,RMS$_FNF);
1e422769 3472 else if (instr(s, "not empty"))
748a9306 3473 SETERRNO(EBUSY,SS$_DEVOFFLINE);
1e422769 3474 else if (instr(s, "cannot access"))
748a9306 3475 SETERRNO(EACCES,RMS$_PRV);
a0d0e21e 3476 else
748a9306 3477 SETERRNO(EPERM,RMS$_PRV);
a0d0e21e
LW
3478 return 0;
3479 }
3480 else { /* some mkdirs return no failure indication */
6b88bc9c 3481 anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
911d147d 3482 if (PL_op->op_type == OP_RMDIR)
a0d0e21e
LW
3483 anum = !anum;
3484 if (anum)
748a9306 3485 SETERRNO(0,0);
a0d0e21e 3486 else
748a9306 3487 SETERRNO(EACCES,RMS$_PRV); /* a guess */
a0d0e21e
LW
3488 }
3489 return anum;
3490 }
3491 else
3492 return 0;
3493}
3494#endif
3495
3496PP(pp_mkdir)
3497{
4e35701f 3498 djSP; dTARGET;
5a211162 3499 int mode;
a0d0e21e
LW
3500#ifndef HAS_MKDIR
3501 int oldumask;
3502#endif
2d8e6c8d 3503 STRLEN n_a;
5a211162
GS
3504 char *tmps;
3505
3506 if (MAXARG > 1)
3507 mode = POPi;
3508 else
3509 mode = 0777;
3510
3511 tmps = SvPV(TOPs, n_a);
a0d0e21e
LW
3512
3513 TAINT_PROPER("mkdir");
3514#ifdef HAS_MKDIR
6ad3d225 3515 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
a0d0e21e
LW
3516#else
3517 SETi( dooneliner("mkdir", tmps) );
6ad3d225
GS
3518 oldumask = PerlLIO_umask(0);
3519 PerlLIO_umask(oldumask);
3520 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
a0d0e21e
LW
3521#endif
3522 RETURN;
3523}
3524
3525PP(pp_rmdir)
3526{
4e35701f 3527 djSP; dTARGET;
a0d0e21e 3528 char *tmps;
2d8e6c8d 3529 STRLEN n_a;
a0d0e21e 3530
2d8e6c8d 3531 tmps = POPpx;
a0d0e21e
LW
3532 TAINT_PROPER("rmdir");
3533#ifdef HAS_RMDIR
6ad3d225 3534 XPUSHi( PerlDir_rmdir(tmps) >= 0 );
a0d0e21e
LW
3535#else
3536 XPUSHi( dooneliner("rmdir", tmps) );
3537#endif
3538 RETURN;
3539}
3540
3541/* Directory calls. */
3542
3543PP(pp_open_dir)
3544{
4e35701f 3545 djSP;
a0d0e21e 3546#if defined(Direntry_t) && defined(HAS_READDIR)
2d8e6c8d
GS
3547 STRLEN n_a;
3548 char *dirname = POPpx;
a0d0e21e
LW
3549 GV *gv = (GV*)POPs;
3550 register IO *io = GvIOn(gv);
3551
3552 if (!io)
3553 goto nope;
3554
3555 if (IoDIRP(io))
6ad3d225
GS
3556 PerlDir_close(IoDIRP(io));
3557 if (!(IoDIRP(io) = PerlDir_open(dirname)))
a0d0e21e
LW
3558 goto nope;
3559
3560 RETPUSHYES;