This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
[ID 19990819.001] Not OK: perl 5.00560 on powerpc-machten 4.1.1
[perl5.git] / pp_sys.c
CommitLineData
a0d0e21e
LW		 1/* pp_sys.c
2 *
4eb8286e 3 * Copyright (c) 1991-1999, 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.
24 * the API is from SysV. --jhi */
8c0bfa08
PB		 25#include <shadow.h>
26#endif
27
76c32331 28/* XXX If this causes problems, set i_unistd=undef in the hint file. */
29#ifdef I_UNISTD
30# include <unistd.h>
31#endif
32
8ac85365
NIS		 33#ifdef HAS_SYSCALL
34#ifdef __cplusplus
35extern "C" int syscall(unsigned long,...);
36#endif
37#endif
38
76c32331 39#ifdef I_SYS_WAIT
40# include <sys/wait.h>
41#endif
42
43#ifdef I_SYS_RESOURCE
44# include <sys/resource.h>
16d20bd9 45#endif
a0d0e21e
LW		 46
47#if defined(HAS_SOCKET) && !defined(VMS) /* VMS handles sockets via vmsish.h */
48# include <sys/socket.h>
29209bc5 49# if defined(USE_SOCKS) && defined(I_SOCKS)
86959918
JH		 50# include <socks.h>
51# endif
3fd537d4
JH		 52# ifdef I_NETDB
53# include <netdb.h>
54# endif
a0d0e21e
LW		 55# ifndef ENOTSOCK
56# ifdef I_NET_ERRNO
57# include <net/errno.h>
58# endif
59# endif
60#endif
61
62#ifdef HAS_SELECT
63#ifdef I_SYS_SELECT
a0d0e21e
LW		 64#include <sys/select.h>
65#endif
66#endif
a0d0e21e 67
dc45a647
MB		 68/* XXX Configure test needed.
69 h_errno might not be a simple 'int', especially for multi-threaded
5ff3f7a4
GS		 70 applications, see "extern int errno in perl.h". Creating such
71 a test requires taking into account the differences between
72 compiling multithreaded and singlethreaded ($ccflags et al).
73 HOST_NOT_FOUND is typically defined in <netdb.h>.
dc45a647
MB		 74*/
75#if defined(HOST_NOT_FOUND) && !defined(h_errno)
a0d0e21e
LW		 76extern int h_errno;
77#endif
78
79#ifdef HAS_PASSWD
80# ifdef I_PWD
81# include <pwd.h>
82# else
20ce7b12
GS		 83 struct passwd *getpwnam (char *);
84 struct passwd *getpwuid (Uid_t);
a0d0e21e 85# endif
28e8609d 86# ifdef HAS_GETPWENT
20ce7b12 87 struct passwd *getpwent (void);
28e8609d 88# endif
a0d0e21e
LW		 89#endif
90
91#ifdef HAS_GROUP
92# ifdef I_GRP
93# include <grp.h>
94# else
20ce7b12
GS		 95 struct group *getgrnam (char *);
96 struct group *getgrgid (Gid_t);
a0d0e21e 97# endif
28e8609d 98# ifdef HAS_GETGRENT
20ce7b12 99 struct group *getgrent (void);
28e8609d 100# endif
a0d0e21e
LW		 101#endif
102
103#ifdef I_UTIME
3730b96e 104# if defined(_MSC_VER) || defined(__MINGW32__)
3fe9a6f1 105# include <sys/utime.h>
106# else
107# include <utime.h>
108# endif
a0d0e21e
LW		 109#endif
110#ifdef I_FCNTL
111#include <fcntl.h>
112#endif
113#ifdef I_SYS_FILE
114#include <sys/file.h>
115#endif
116
54310121 117/* Put this after #includes because fork and vfork prototypes may conflict. */
118#ifndef HAS_VFORK
119# define vfork fork
120#endif
121
d574b85e
CS		 122/* Put this after #includes because <unistd.h> defines _XOPEN_*. */
123#ifndef Sock_size_t
137443ea 124# if _XOPEN_VERSION >= 5 || defined(_XOPEN_SOURCE_EXTENDED) || defined(__GLIBC__)
d574b85e
CS		 125# define Sock_size_t Size_t
126# else
127# define Sock_size_t int
128# endif
54310121 129#endif
130
cbdc8872 131#ifdef HAS_CHSIZE
cd52b7b2 132# ifdef my_chsize /* Probably #defined to Perl_my_chsize in embed.h */
133# undef my_chsize
134# endif
6ad3d225 135# define my_chsize PerlLIO_chsize
cbdc8872 136#endif
137
ff68c719 138#ifdef HAS_FLOCK
139# define FLOCK flock
140#else /* no flock() */
141
36477c24 142 /* fcntl.h might not have been included, even if it exists, because
143 the current Configure only sets I_FCNTL if it's needed to pick up
144 the *_OK constants. Make sure it has been included before testing
145 the fcntl() locking constants. */
146# if defined(HAS_FCNTL) && !defined(I_FCNTL)
147# include <fcntl.h>
148# endif
149
ff68c719 150# if defined(HAS_FCNTL) && defined(F_SETLK) && defined (F_SETLKW)
151# define FLOCK fcntl_emulate_flock
152# define FCNTL_EMULATE_FLOCK
153# else /* no flock() or fcntl(F_SETLK,...) */
154# ifdef HAS_LOCKF
155# define FLOCK lockf_emulate_flock
156# define LOCKF_EMULATE_FLOCK
157# endif /* lockf */
158# endif /* no flock() or fcntl(F_SETLK,...) */
159
160# ifdef FLOCK
20ce7b12 161 static int FLOCK (int, int);
ff68c719 162
163 /*
164 * These are the flock() constants. Since this sytems doesn't have
165 * flock(), the values of the constants are probably not available.
166 */
167# ifndef LOCK_SH
168# define LOCK_SH 1
169# endif
170# ifndef LOCK_EX
171# define LOCK_EX 2
172# endif
173# ifndef LOCK_NB
174# define LOCK_NB 4
175# endif
176# ifndef LOCK_UN
177# define LOCK_UN 8
178# endif
179# endif /* emulating flock() */
180
181#endif /* no flock() */
55497cff 182
85ab1d1d
JH		 183#define ZBTLEN 10
184static char zero_but_true[ZBTLEN + 1] = "0 but true";
185
5ff3f7a4
GS		 186#if defined(I_SYS_ACCESS) && !defined(R_OK)
187# include <sys/access.h>
188#endif
189
190#undef PERL_EFF_ACCESS_R_OK /* EFFective uid/gid ACCESS R_OK */
191#undef PERL_EFF_ACCESS_W_OK
192#undef PERL_EFF_ACCESS_X_OK
193
194/* F_OK unused: if stat() cannot find it... */
195
196#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_ACCESS) && defined(EFF_ONLY_OK) && !defined(NO_EFF_ONLY_OK)
c955f117 197 /* Digital UNIX (when the EFF_ONLY_OK gets fixed), UnixWare */
5ff3f7a4
GS		 198# define PERL_EFF_ACCESS_R_OK(p) (access((p), R_OK | EFF_ONLY_OK))
199# define PERL_EFF_ACCESS_W_OK(p) (access((p), W_OK | EFF_ONLY_OK))
200# define PERL_EFF_ACCESS_X_OK(p) (access((p), X_OK | EFF_ONLY_OK))
201#endif
202
203#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_EACCESS)
5ff3f7a4
GS		 204# if defined(I_SYS_SECURITY)
205# include <sys/security.h>
206# endif
c955f117
JH		 207 /* XXX Configure test needed for eaccess */
208# ifdef ACC_SELF
209 /* HP SecureWare */
210# define PERL_EFF_ACCESS_R_OK(p) (eaccess((p), R_OK, ACC_SELF))
211# define PERL_EFF_ACCESS_W_OK(p) (eaccess((p), W_OK, ACC_SELF))
212# define PERL_EFF_ACCESS_X_OK(p) (eaccess((p), X_OK, ACC_SELF))
213# else
214 /* SCO */
215# define PERL_EFF_ACCESS_R_OK(p) (eaccess((p), R_OK))
216# define PERL_EFF_ACCESS_W_OK(p) (eaccess((p), W_OK))
217# define PERL_EFF_ACCESS_X_OK(p) (eaccess((p), X_OK))
218# endif
5ff3f7a4
GS		 219#endif
220
221#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_ACCESSX) && defined(ACC_SELF)
c955f117 222 /* AIX */
5ff3f7a4
GS		 223# define PERL_EFF_ACCESS_R_OK(p) (accessx((p), R_OK, ACC_SELF))
224# define PERL_EFF_ACCESS_W_OK(p) (accessx((p), W_OK, ACC_SELF))
225# define PERL_EFF_ACCESS_X_OK(p) (accessx((p), X_OK, ACC_SELF))
226#endif
227
327c3667
GS		 228#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_ACCESS) \
229 && (defined(HAS_SETREUID) || defined(HAS_SETRESUID) \
230 || defined(HAS_SETREGID) || defined(HAS_SETRESGID))
5ff3f7a4 231/* The Hard Way. */
327c3667 232STATIC int
7f4774ae 233S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
ba106d47 234{
5ff3f7a4
GS		 235 Uid_t ruid = getuid();
236 Uid_t euid = geteuid();
237 Gid_t rgid = getgid();
238 Gid_t egid = getegid();
239 int res;
240
241 MUTEX_LOCK(&PL_cred_mutex);
242#if !defined(HAS_SETREUID) && !defined(HAS_SETRESUID)
cea2e8a9 243 Perl_croak(aTHX_ "switching effective uid is not implemented");
5ff3f7a4
GS		 244#else
245#ifdef HAS_SETREUID
246 if (setreuid(euid, ruid))
247#else
248#ifdef HAS_SETRESUID
249 if (setresuid(euid, ruid, (Uid_t)-1))
250#endif
251#endif
cea2e8a9 252 Perl_croak(aTHX_ "entering effective uid failed");
5ff3f7a4
GS		 253#endif
254
255#if !defined(HAS_SETREGID) && !defined(HAS_SETRESGID)
cea2e8a9 256 Perl_croak(aTHX_ "switching effective gid is not implemented");
5ff3f7a4
GS		 257#else
258#ifdef HAS_SETREGID
259 if (setregid(egid, rgid))
260#else
261#ifdef HAS_SETRESGID
262 if (setresgid(egid, rgid, (Gid_t)-1))
263#endif
264#endif
cea2e8a9 265 Perl_croak(aTHX_ "entering effective gid failed");
5ff3f7a4
GS		 266#endif
267
268 res = access(path, mode);
269
270#ifdef HAS_SETREUID
271 if (setreuid(ruid, euid))
272#else
273#ifdef HAS_SETRESUID
274 if (setresuid(ruid, euid, (Uid_t)-1))
275#endif
276#endif
cea2e8a9 277 Perl_croak(aTHX_ "leaving effective uid failed");
5ff3f7a4
GS		 278
279#ifdef HAS_SETREGID
280 if (setregid(rgid, egid))
281#else
282#ifdef HAS_SETRESGID
283 if (setresgid(rgid, egid, (Gid_t)-1))
284#endif
285#endif
cea2e8a9 286 Perl_croak(aTHX_ "leaving effective gid failed");
5ff3f7a4
GS		 287 MUTEX_UNLOCK(&PL_cred_mutex);
288
289 return res;
290}
291# define PERL_EFF_ACCESS_R_OK(p) (emulate_eaccess((p), R_OK))
292# define PERL_EFF_ACCESS_W_OK(p) (emulate_eaccess((p), W_OK))
293# define PERL_EFF_ACCESS_X_OK(p) (emulate_eaccess((p), X_OK))
294#endif
295
296#if !defined(PERL_EFF_ACCESS_R_OK)
327c3667 297STATIC int
7f4774ae 298S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
ba106d47 299{
cea2e8a9 300 Perl_croak(aTHX_ "switching effective uid is not implemented");
5ff3f7a4
GS		 301 /*NOTREACHED*/
302 return -1;
303}
304#endif
305
a0d0e21e
LW		 306PP(pp_backtick)
307{
4e35701f 308 djSP; dTARGET;
760ac839 309 PerlIO *fp;
2d8e6c8d
GS		 310 STRLEN n_a;
311 char *tmps = POPpx;
54310121 312 I32 gimme = GIMME_V;
313
a0d0e21e 314 TAINT_PROPER("``");
6ad3d225 315 fp = PerlProc_popen(tmps, "r");
a0d0e21e 316 if (fp) {
54310121 317 if (gimme == G_VOID) {
96827780
MB		 318 char tmpbuf[256];
319 while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0)
54310121 320 /*SUPPRESS 530*/
321 ;
322 }
323 else if (gimme == G_SCALAR) {
aa689395 324 sv_setpv(TARG, ""); /* note that this preserves previous buffer */
a0d0e21e
LW		 325 while (sv_gets(TARG, fp, SvCUR(TARG)) != Nullch)
326 /*SUPPRESS 530*/
327 ;
328 XPUSHs(TARG);
aa689395 329 SvTAINTED_on(TARG);
a0d0e21e
LW		 330 }
331 else {
332 SV *sv;
333
334 for (;;) {
8d6dde3e 335 sv = NEWSV(56, 79);
a0d0e21e
LW		 336 if (sv_gets(sv, fp, 0) == Nullch) {
337 SvREFCNT_dec(sv);
338 break;
339 }
340 XPUSHs(sv_2mortal(sv));
341 if (SvLEN(sv) - SvCUR(sv) > 20) {
342 SvLEN_set(sv, SvCUR(sv)+1);
343 Renew(SvPVX(sv), SvLEN(sv), char);
344 }
aa689395 345 SvTAINTED_on(sv);
a0d0e21e
LW		 346 }
347 }
6ad3d225 348 STATUS_NATIVE_SET(PerlProc_pclose(fp));
aa689395 349 TAINT; /* "I believe that this is not gratuitous!" */
a0d0e21e
LW		 350 }
351 else {
f86702cc 352 STATUS_NATIVE_SET(-1);
54310121 353 if (gimme == G_SCALAR)
a0d0e21e
LW		 354 RETPUSHUNDEF;
355 }
356
357 RETURN;
358}
359
360PP(pp_glob)
361{
362 OP *result;
f5284f61
IZ		 363 tryAMAGICunTARGET(iter, -1);
364
a0d0e21e 365 ENTER;
a0d0e21e 366
c90c0ff4 367#ifndef VMS
3280af22 368 if (PL_tainting) {
7bac28a0 369 /*
370 * The external globbing program may use things we can't control,
371 * so for security reasons we must assume the worst.
372 */
373 TAINT;
22c35a8c 374 taint_proper(PL_no_security, "glob");
7bac28a0 375 }
c90c0ff4 376#endif /* !VMS */
7bac28a0 377
3280af22
NIS		 378 SAVESPTR(PL_last_in_gv); /* We don't want this to be permanent. */
379 PL_last_in_gv = (GV*)*PL_stack_sp--;
a0d0e21e 380
3280af22 381 SAVESPTR(PL_rs); /* This is not permanent, either. */
79cb57f6 382 PL_rs = sv_2mortal(newSVpvn("\000", 1));
c07a80fd 383#ifndef DOSISH
384#ifndef CSH
6b88bc9c 385 *SvPVX(PL_rs) = '\n';
a0d0e21e 386#endif /* !CSH */
55497cff 387#endif /* !DOSISH */
c07a80fd 388
a0d0e21e
LW		 389 result = do_readline();
390 LEAVE;
391 return result;
392}
393
15e52e56 394#if 0 /* XXX never used! */
a0d0e21e
LW		 395PP(pp_indread)
396{
2d8e6c8d
GS		 397 STRLEN n_a;
398 PL_last_in_gv = gv_fetchpv(SvPVx(GvSV((GV*)(*PL_stack_sp--)), n_a), TRUE,SVt_PVIO);
a0d0e21e
LW		 399 return do_readline();
400}
15e52e56 401#endif
a0d0e21e
LW		 402
403PP(pp_rcatline)
404{
3280af22 405 PL_last_in_gv = cGVOP->op_gv;
a0d0e21e
LW		 406 return do_readline();
407}
408
409PP(pp_warn)
410{
4e35701f 411 djSP; dMARK;
06bf62c7 412 SV *tmpsv;
a0d0e21e 413 char *tmps;
06bf62c7 414 STRLEN len;
a0d0e21e
LW		 415 if (SP - MARK != 1) {
416 dTARGET;
3280af22 417 do_join(TARG, &PL_sv_no, MARK, SP);
06bf62c7 418 tmpsv = TARG;
a0d0e21e
LW		 419 SP = MARK + 1;
420 }
421 else {
06bf62c7 422 tmpsv = TOPs;
a0d0e21e 423 }
06bf62c7
GS		 424 tmps = SvPV(tmpsv, len);
425 if (!tmps || !len) {
4e6ea2c3
GS		 426 SV *error = ERRSV;
427 (void)SvUPGRADE(error, SVt_PV);
428 if (SvPOK(error) && SvCUR(error))
429 sv_catpv(error, "\t...caught");
06bf62c7
GS		 430 tmpsv = error;
431 tmps = SvPV(tmpsv, len);
a0d0e21e 432 }
06bf62c7
GS		 433 if (!tmps || !len)
434 tmpsv = sv_2mortal(newSVpvn("Warning: something's wrong", 26));
435
cea2e8a9 436 Perl_warn(aTHX_ "%_", tmpsv);
a0d0e21e
LW		 437 RETSETYES;
438}
439
440PP(pp_die)
441{
4e35701f 442 djSP; dMARK;
a0d0e21e 443 char *tmps;
06bf62c7
GS		 444 SV *tmpsv;
445 STRLEN len;
446 bool multiarg = 0;
a0d0e21e
LW		 447 if (SP - MARK != 1) {
448 dTARGET;
3280af22 449 do_join(TARG, &PL_sv_no, MARK, SP);
06bf62c7
GS		 450 tmpsv = TARG;
451 tmps = SvPV(tmpsv, len);
452 multiarg = 1;
a0d0e21e
LW		 453 SP = MARK + 1;
454 }
455 else {
4e6ea2c3 456 tmpsv = TOPs;
06bf62c7 457 tmps = SvROK(tmpsv) ? Nullch : SvPV(tmpsv, len);
a0d0e21e 458 }
06bf62c7 459 if (!tmps || !len) {
4e6ea2c3
GS		 460 SV *error = ERRSV;
461 (void)SvUPGRADE(error, SVt_PV);
06bf62c7
GS		 462 if (multiarg ? SvROK(error) : SvROK(tmpsv)) {
463 if (!multiarg)
4e6ea2c3 464 SvSetSV(error,tmpsv);
06bf62c7 465 else if (sv_isobject(error)) {
05423cc9
GS		 466 HV *stash = SvSTASH(SvRV(error));
467 GV *gv = gv_fetchmethod(stash, "PROPAGATE");
468 if (gv) {
3280af22
NIS		 469 SV *file = sv_2mortal(newSVsv(GvSV(PL_curcop->cop_filegv)));
470 SV *line = sv_2mortal(newSViv(PL_curcop->cop_line));
05423cc9
GS		 471 EXTEND(SP, 3);
472 PUSHMARK(SP);
473 PUSHs(error);
474 PUSHs(file);
475 PUSHs(line);
476 PUTBACK;
864dbfa3
GS		 477 call_sv((SV*)GvCV(gv),
478 G_SCALAR|G_EVAL|G_KEEPERR);
3280af22 479 sv_setsv(error,*PL_stack_sp--);
05423cc9
GS		 480 }
481 }
cea2e8a9 482 DIE(aTHX_ Nullch);
4e6ea2c3
GS		 483 }
484 else {
485 if (SvPOK(error) && SvCUR(error))
486 sv_catpv(error, "\t...propagated");
06bf62c7
GS		 487 tmpsv = error;
488 tmps = SvPV(tmpsv, len);
4e6ea2c3 489 }
a0d0e21e 490 }
06bf62c7
GS		 491 if (!tmps || !len)
492 tmpsv = sv_2mortal(newSVpvn("Died", 4));
493
cea2e8a9 494 DIE(aTHX_ "%_", tmpsv);
a0d0e21e
LW		 495}
496
497/* I/O. */
498
499PP(pp_open)
500{
4e35701f 501 djSP; dTARGET;
a0d0e21e
LW		 502 GV *gv;
503 SV *sv;
6170680b
IZ		 504 SV *name;
505 I32 have_name = 0;
a0d0e21e
LW		 506 char *tmps;
507 STRLEN len;
4592e6ca 508 MAGIC *mg;
a0d0e21e 509
6170680b
IZ		 510 if (MAXARG > 2) {
511 name = POPs;
512 have_name = 1;
513 }
a0d0e21e
LW		 514 if (MAXARG > 1)
515 sv = POPs;
5f05dabc 516 if (!isGV(TOPs))
cea2e8a9 517 DIE(aTHX_ PL_no_usym, "filehandle");
5f05dabc 518 if (MAXARG <= 1)
519 sv = GvSV(TOPs);
a0d0e21e 520 gv = (GV*)POPs;
5f05dabc 521 if (!isGV(gv))
cea2e8a9 522 DIE(aTHX_ PL_no_usym, "filehandle");
36477c24 523 if (GvIOp(gv))
524 IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
853846ea
NIS		 525
526#if 0 /* no undef means tmpfile() yet */
3eb568f1
NIS		 527 if (sv == &PL_sv_undef) {
528#ifdef PerlIO
529 PerlIO *fp = PerlIO_tmpfile();
530#else
531 PerlIO *fp = tmpfile();
532#endif
533 if (fp != Nullfp && do_open(gv, "+>&", 3, FALSE, 0, 0, fp))
534 PUSHi( (I32)PL_forkprocess );
535 else
536 RETPUSHUNDEF;
537 RETURN;
538 }
853846ea
NIS		 539#endif /* no undef means tmpfile() yet */
540
4592e6ca
NIS		 541
542 if (mg = SvTIED_mg((SV*)gv, 'q')) {
543 PUSHMARK(SP);
544 XPUSHs(SvTIED_obj((SV*)gv, mg));
545 XPUSHs(sv);
6170680b
IZ		 546 if (have_name)
547 XPUSHs(name);
4592e6ca
NIS		 548 PUTBACK;
549 ENTER;
864dbfa3 550 call_method("OPEN", G_SCALAR);
4592e6ca
NIS		 551 LEAVE;
552 SPAGAIN;
553 RETURN;
554 }
555
a0d0e21e 556 tmps = SvPV(sv, len);
6170680b 557 if (do_open9(gv, tmps, len, FALSE, O_RDONLY, 0, Nullfp, name, have_name))
3280af22
NIS		 558 PUSHi( (I32)PL_forkprocess );
559 else if (PL_forkprocess == 0) /* we are a new child */
a0d0e21e
LW		 560 PUSHi(0);
561 else
562 RETPUSHUNDEF;
563 RETURN;
564}
565
566PP(pp_close)
567{
4e35701f 568 djSP;
a0d0e21e 569 GV *gv;
1d603a67 570 MAGIC *mg;
a0d0e21e
LW		 571
572 if (MAXARG == 0)
3280af22 573 gv = PL_defoutgv;
a0d0e21e
LW		 574 else
575 gv = (GV*)POPs;
1d603a67 576
33c27489 577 if (mg = SvTIED_mg((SV*)gv, 'q')) {
1d603a67 578 PUSHMARK(SP);
33c27489 579 XPUSHs(SvTIED_obj((SV*)gv, mg));
1d603a67
GB		 580 PUTBACK;
581 ENTER;
864dbfa3 582 call_method("CLOSE", G_SCALAR);
1d603a67
GB		 583 LEAVE;
584 SPAGAIN;
585 RETURN;
586 }
a0d0e21e 587 EXTEND(SP, 1);
54310121 588 PUSHs(boolSV(do_close(gv, TRUE)));
a0d0e21e
LW		 589 RETURN;
590}
591
592PP(pp_pipe_op)
593{
4e35701f 594 djSP;
a0d0e21e
LW		 595#ifdef HAS_PIPE
596 GV *rgv;
597 GV *wgv;
598 register IO *rstio;
599 register IO *wstio;
600 int fd[2];
601
602 wgv = (GV*)POPs;
603 rgv = (GV*)POPs;
604
605 if (!rgv || !wgv)
606 goto badexit;
607
4633a7c4 608 if (SvTYPE(rgv) != SVt_PVGV || SvTYPE(wgv) != SVt_PVGV)
cea2e8a9 609 DIE(aTHX_ PL_no_usym, "filehandle");
a0d0e21e
LW		 610 rstio = GvIOn(rgv);
611 wstio = GvIOn(wgv);
612
613 if (IoIFP(rstio))
614 do_close(rgv, FALSE);
615 if (IoIFP(wstio))
616 do_close(wgv, FALSE);
617
6ad3d225 618 if (PerlProc_pipe(fd) < 0)
a0d0e21e
LW		 619 goto badexit;
620
760ac839
LW		 621 IoIFP(rstio) = PerlIO_fdopen(fd[0], "r");
622 IoOFP(wstio) = PerlIO_fdopen(fd[1], "w");
a0d0e21e
LW		 623 IoIFP(wstio) = IoOFP(wstio);
624 IoTYPE(rstio) = '<';
625 IoTYPE(wstio) = '>';
626
627 if (!IoIFP(rstio) || !IoOFP(wstio)) {
760ac839 628 if (IoIFP(rstio)) PerlIO_close(IoIFP(rstio));
6ad3d225 629 else PerlLIO_close(fd[0]);
760ac839 630 if (IoOFP(wstio)) PerlIO_close(IoOFP(wstio));
6ad3d225 631 else PerlLIO_close(fd[1]);
a0d0e21e
LW		 632 goto badexit;
633 }
4771b018
GS		 634#if defined(HAS_FCNTL) && defined(F_SETFD)
635 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
636 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
637#endif
a0d0e21e
LW		 638 RETPUSHYES;
639
640badexit:
641 RETPUSHUNDEF;
642#else
cea2e8a9 643 DIE(aTHX_ PL_no_func, "pipe");
a0d0e21e
LW		 644#endif
645}
646
647PP(pp_fileno)
648{
4e35701f 649 djSP; dTARGET;
a0d0e21e
LW		 650 GV *gv;
651 IO *io;
760ac839 652 PerlIO *fp;
4592e6ca
NIS		 653 MAGIC *mg;
654
a0d0e21e
LW		 655 if (MAXARG < 1)
656 RETPUSHUNDEF;
657 gv = (GV*)POPs;
4592e6ca
NIS		 658
659 if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
660 PUSHMARK(SP);
661 XPUSHs(SvTIED_obj((SV*)gv, mg));
662 PUTBACK;
663 ENTER;
864dbfa3 664 call_method("FILENO", G_SCALAR);
4592e6ca
NIS		 665 LEAVE;
666 SPAGAIN;
667 RETURN;
668 }
669
a0d0e21e
LW		 670 if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io)))
671 RETPUSHUNDEF;
760ac839 672 PUSHi(PerlIO_fileno(fp));
a0d0e21e
LW		 673 RETURN;
674}
675
676PP(pp_umask)
677{
4e35701f 678 djSP; dTARGET;
761237fe 679 Mode_t anum;
a0d0e21e
LW		 680
681#ifdef HAS_UMASK
682 if (MAXARG < 1) {
6ad3d225
GS		 683 anum = PerlLIO_umask(0);
684 (void)PerlLIO_umask(anum);
a0d0e21e
LW		 685 }
686 else
6ad3d225 687 anum = PerlLIO_umask(POPi);
a0d0e21e
LW		 688 TAINT_PROPER("umask");
689 XPUSHi(anum);
690#else
eec2d3df
GS		 691 /* Only DIE if trying to restrict permissions on `user' (self).
692 * Otherwise it's harmless and more useful to just return undef
693 * since 'group' and 'other' concepts probably don't exist here. */
694 if (MAXARG >= 1 && (POPi & 0700))
cea2e8a9 695 DIE(aTHX_ "umask not implemented");
6b88bc9c 696 XPUSHs(&PL_sv_undef);
a0d0e21e
LW		 697#endif
698 RETURN;
699}
700
701PP(pp_binmode)
702{
4e35701f 703 djSP;
a0d0e21e
LW		 704 GV *gv;
705 IO *io;
760ac839 706 PerlIO *fp;
4592e6ca 707 MAGIC *mg;
a0d0e21e
LW		 708
709 if (MAXARG < 1)
710 RETPUSHUNDEF;
711
4592e6ca
NIS		 712 gv = (GV*)POPs;
713
714 if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
715 PUSHMARK(SP);
716 XPUSHs(SvTIED_obj((SV*)gv, mg));
717 PUTBACK;
718 ENTER;
864dbfa3 719 call_method("BINMODE", G_SCALAR);
4592e6ca
NIS		 720 LEAVE;
721 SPAGAIN;
722 RETURN;
723 }
a0d0e21e
LW		 724
725 EXTEND(SP, 1);
726 if (!(io = GvIO(gv)) || !(fp = IoIFP(io)))
55497cff 727 RETPUSHUNDEF;
a0d0e21e 728
491527d0 729 if (do_binmode(fp,IoTYPE(io),TRUE))
a0d0e21e
LW		 730 RETPUSHYES;
731 else
732 RETPUSHUNDEF;
a0d0e21e
LW		 733}
734
b8e3bfaf 735
a0d0e21e
LW		 736PP(pp_tie)
737{
4e35701f 738 djSP;
e336de0d 739 dMARK;
a0d0e21e
LW		 740 SV *varsv;
741 HV* stash;
742 GV *gv;
a0d0e21e 743 SV *sv;
3280af22 744 I32 markoff = MARK - PL_stack_base;
a0d0e21e 745 char *methname;
6b05c17a 746 int how = 'P';
e336de0d 747 U32 items;
2d8e6c8d 748 STRLEN n_a;
a0d0e21e 749
e336de0d 750 varsv = *++MARK;
6b05c17a
NIS		 751 switch(SvTYPE(varsv)) {
752 case SVt_PVHV:
753 methname = "TIEHASH";
754 break;
755 case SVt_PVAV:
756 methname = "TIEARRAY";
757 break;
758 case SVt_PVGV:
759 methname = "TIEHANDLE";
760 how = 'q';
761 break;
762 default:
763 methname = "TIESCALAR";
764 how = 'q';
765 break;
766 }
e336de0d
GS		 767 items = SP - MARK++;
768 if (sv_isobject(*MARK)) {
6b05c17a 769 ENTER;
e788e7d3 770 PUSHSTACKi(PERLSI_MAGIC);
e336de0d
GS		 771 PUSHMARK(SP);
772 EXTEND(SP,items);
773 while (items--)
774 PUSHs(*MARK++);
775 PUTBACK;
864dbfa3 776 call_method(methname, G_SCALAR);
6b05c17a
NIS		 777 }
778 else {
864dbfa3 779 /* Not clear why we don't call call_method here too.
6b05c17a
NIS		 780 * perhaps to get different error message ?
781 */
e336de0d 782 stash = gv_stashsv(*MARK, FALSE);
6b05c17a 783 if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
cea2e8a9 784 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%s\"",
2d8e6c8d 785 methname, SvPV(*MARK,n_a));
6b05c17a
NIS		 786 }
787 ENTER;
e788e7d3 788 PUSHSTACKi(PERLSI_MAGIC);
e336de0d
GS		 789 PUSHMARK(SP);
790 EXTEND(SP,items);
791 while (items--)
792 PUSHs(*MARK++);
793 PUTBACK;
864dbfa3 794 call_sv((SV*)GvCV(gv), G_SCALAR);
6b05c17a 795 }
a0d0e21e
LW		 796 SPAGAIN;
797
798 sv = TOPs;
d3acc0f7 799 POPSTACK;
a0d0e21e 800 if (sv_isobject(sv)) {
33c27489
GS		 801 sv_unmagic(varsv, how);
802 sv_magic(varsv, (SvRV(sv) == varsv ? Nullsv : sv), how, Nullch, 0);
a0d0e21e
LW		 803 }
804 LEAVE;
3280af22 805 SP = PL_stack_base + markoff;
a0d0e21e
LW		 806 PUSHs(sv);
807 RETURN;
808}
809
810PP(pp_untie)
811{
4e35701f 812 djSP;
33c27489
GS		 813 SV *sv = POPs;
814 char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) ? 'P' : 'q';
55497cff 815
599cee73 816 if (ckWARN(WARN_UNTIE)) {
cbdc8872 817 MAGIC * mg ;
33c27489 818 if (mg = SvTIED_mg(sv, how)) {
cf2093f6 819#ifdef IV_IS_QUAD
b9c39e73 820 if (mg && SvREFCNT(SvRV(mg->mg_obj)) > 1)
cf2093f6
JH		 821 Perl_warner(aTHX_ WARN_UNTIE,
822 "untie attempted while %" PERL_PRIu64 " inner references still exist",
823 (UV)SvREFCNT(SvRV(mg->mg_obj)) - 1 ) ;
824#else
b9c39e73 825 if (mg && SvREFCNT(SvRV(mg->mg_obj)) > 1)
cea2e8a9 826 Perl_warner(aTHX_ WARN_UNTIE,
599cee73
PM		 827 "untie attempted while %lu inner references still exist",
828 (unsigned long)SvREFCNT(SvRV(mg->mg_obj)) - 1 ) ;
cf2093f6 829#endif
cbdc8872 830 }
831 }
832
33c27489 833 sv_unmagic(sv, how);
55497cff 834 RETPUSHYES;
a0d0e21e
LW		 835}
836
c07a80fd 837PP(pp_tied)
838{
4e35701f 839 djSP;
33c27489
GS		 840 SV *sv = POPs;
841 char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) ? 'P' : 'q';
842 MAGIC *mg;
c07a80fd 843
33c27489
GS		 844 if (mg = SvTIED_mg(sv, how)) {
845 SV *osv = SvTIED_obj(sv, mg);
846 if (osv == mg->mg_obj)
847 osv = sv_mortalcopy(osv);
848 PUSHs(osv);
849 RETURN;
c07a80fd 850 }
c07a80fd 851 RETPUSHUNDEF;
852}
853
a0d0e21e
LW		 854PP(pp_dbmopen)
855{
4e35701f 856 djSP;
a0d0e21e
LW		 857 HV *hv;
858 dPOPPOPssrl;
859 HV* stash;
860 GV *gv;
a0d0e21e
LW		 861 SV *sv;
862
863 hv = (HV*)POPs;
864
3280af22 865 sv = sv_mortalcopy(&PL_sv_no);
a0d0e21e
LW		 866 sv_setpv(sv, "AnyDBM_File");
867 stash = gv_stashsv(sv, FALSE);
8ebc5c01 868 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
a0d0e21e 869 PUTBACK;
864dbfa3 870 require_pv("AnyDBM_File.pm");
a0d0e21e 871 SPAGAIN;
8ebc5c01 872 if (!(gv = gv_fetchmethod(stash, "TIEHASH")))
cea2e8a9 873 DIE(aTHX_ "No dbm on this machine");
a0d0e21e
LW		 874 }
875
57d3b86d 876 ENTER;
924508f0 877 PUSHMARK(SP);
6b05c17a 878
924508f0 879 EXTEND(SP, 5);
a0d0e21e
LW		 880 PUSHs(sv);
881 PUSHs(left);
882 if (SvIV(right))
883 PUSHs(sv_2mortal(newSViv(O_RDWR|O_CREAT)));
884 else
885 PUSHs(sv_2mortal(newSViv(O_RDWR)));
886 PUSHs(right);
57d3b86d 887 PUTBACK;
864dbfa3 888 call_sv((SV*)GvCV(gv), G_SCALAR);
a0d0e21e
LW		 889 SPAGAIN;
890
891 if (!sv_isobject(TOPs)) {
924508f0
GS		 892 SP--;
893 PUSHMARK(SP);
a0d0e21e
LW		 894 PUSHs(sv);
895 PUSHs(left);
896 PUSHs(sv_2mortal(newSViv(O_RDONLY)));
897 PUSHs(right);
a0d0e21e 898 PUTBACK;
864dbfa3 899 call_sv((SV*)GvCV(gv), G_SCALAR);
a0d0e21e
LW		 900 SPAGAIN;
901 }
902
6b05c17a
NIS		 903 if (sv_isobject(TOPs)) {
904 sv_unmagic((SV *) hv, 'P');
a0d0e21e 905 sv_magic((SV*)hv, TOPs, 'P', Nullch, 0);
6b05c17a 906 }
a0d0e21e
LW		 907 LEAVE;
908 RETURN;
909}
910
911PP(pp_dbmclose)
912{
cea2e8a9 913 return pp_untie();
a0d0e21e
LW		 914}
915
916PP(pp_sselect)
917{
4e35701f 918 djSP; dTARGET;
a0d0e21e
LW		 919#ifdef HAS_SELECT
920 register I32 i;
921 register I32 j;
922 register char *s;
923 register SV *sv;
65202027 924 NV value;
a0d0e21e
LW		 925 I32 maxlen = 0;
926 I32 nfound;
927 struct timeval timebuf;
928 struct timeval *tbuf = &timebuf;
929 I32 growsize;
930 char *fd_sets[4];
2d8e6c8d 931 STRLEN n_a;
a0d0e21e
LW		 932#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
933 I32 masksize;
934 I32 offset;
935 I32 k;
936
937# if BYTEORDER & 0xf0000
938# define ORDERBYTE (0x88888888 - BYTEORDER)
939# else
940# define ORDERBYTE (0x4444 - BYTEORDER)
941# endif
942
943#endif
944
945 SP -= 4;
946 for (i = 1; i <= 3; i++) {
947 if (!SvPOK(SP[i]))
948 continue;
949 j = SvCUR(SP[i]);
950 if (maxlen < j)
951 maxlen = j;
952 }
953
5ff3f7a4 954/* little endians can use vecs directly */
a0d0e21e 955#if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
5ff3f7a4 956# if SELECT_MIN_BITS > 1
f2da832e
JH		 957 /* If SELECT_MIN_BITS is greater than one we most probably will want
958 * to align the sizes with SELECT_MIN_BITS/8 because for example
959 * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
8f1f23e8
W		 960 * UNIX, Solaris, NeXT, Rhapsody) the smallest quantum select() operates
961 * on (sets/tests/clears bits) is 32 bits. */
f2da832e 962 growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
5ff3f7a4 963# else
4633a7c4 964 growsize = sizeof(fd_set);
5ff3f7a4
GS		 965# endif
966# else
967# ifdef NFDBITS
a0d0e21e 968
5ff3f7a4
GS		 969# ifndef NBBY
970# define NBBY 8
971# endif
a0d0e21e
LW		 972
973 masksize = NFDBITS / NBBY;
5ff3f7a4 974# else
a0d0e21e 975 masksize = sizeof(long); /* documented int, everyone seems to use long */
5ff3f7a4 976# endif
a0d0e21e
LW		 977 growsize = maxlen + (masksize - (maxlen % masksize));
978 Zero(&fd_sets[0], 4, char*);
979#endif
980
981 sv = SP[4];
982 if (SvOK(sv)) {
983 value = SvNV(sv);
984 if (value < 0.0)
985 value = 0.0;
986 timebuf.tv_sec = (long)value;
65202027 987 value -= (NV)timebuf.tv_sec;
a0d0e21e
LW		 988 timebuf.tv_usec = (long)(value * 1000000.0);
989 }
990 else
991 tbuf = Null(struct timeval*);
992
993 for (i = 1; i <= 3; i++) {
994 sv = SP[i];
995 if (!SvOK(sv)) {
996 fd_sets[i] = 0;
997 continue;
998 }
999 else if (!SvPOK(sv))
2d8e6c8d 1000 SvPV_force(sv,n_a); /* force string conversion */
a0d0e21e
LW		 1001 j = SvLEN(sv);
1002 if (j < growsize) {
1003 Sv_Grow(sv, growsize);
a0d0e21e 1004 }
c07a80fd 1005 j = SvCUR(sv);
1006 s = SvPVX(sv) + j;
1007 while (++j <= growsize) {
1008 *s++ = '\0';
1009 }
1010
a0d0e21e
LW		 1011#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1012 s = SvPVX(sv);
1013 New(403, fd_sets[i], growsize, char);
1014 for (offset = 0; offset < growsize; offset += masksize) {
1015 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1016 fd_sets[i][j+offset] = s[(k % masksize) + offset];
1017 }
1018#else
1019 fd_sets[i] = SvPVX(sv);
1020#endif
1021 }
1022
6ad3d225 1023 nfound = PerlSock_select(
a0d0e21e
LW		 1024 maxlen * 8,
1025 (Select_fd_set_t) fd_sets[1],
1026 (Select_fd_set_t) fd_sets[2],
1027 (Select_fd_set_t) fd_sets[3],
1028 tbuf);
1029 for (i = 1; i <= 3; i++) {
1030 if (fd_sets[i]) {
1031 sv = SP[i];
1032#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1033 s = SvPVX(sv);
1034 for (offset = 0; offset < growsize; offset += masksize) {
1035 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1036 s[(k % masksize) + offset] = fd_sets[i][j+offset];
1037 }
1038 Safefree(fd_sets[i]);
1039#endif
1040 SvSETMAGIC(sv);
1041 }
1042 }
1043
1044 PUSHi(nfound);
1045 if (GIMME == G_ARRAY && tbuf) {
65202027
DS		 1046 value = (NV)(timebuf.tv_sec) +
1047 (NV)(timebuf.tv_usec) / 1000000.0;
3280af22 1048 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 1049 sv_setnv(sv, value);
1050 }
1051 RETURN;
1052#else
cea2e8a9 1053 DIE(aTHX_ "select not implemented");
a0d0e21e
LW		 1054#endif
1055}
1056
4633a7c4 1057void
864dbfa3 1058Perl_setdefout(pTHX_ GV *gv)
4633a7c4 1059{
11343788 1060 dTHR;
4633a7c4
LW		 1061 if (gv)
1062 (void)SvREFCNT_inc(gv);
3280af22
NIS		 1063 if (PL_defoutgv)
1064 SvREFCNT_dec(PL_defoutgv);
1065 PL_defoutgv = gv;
4633a7c4
LW		 1066}
1067
a0d0e21e
LW		 1068PP(pp_select)
1069{
4e35701f 1070 djSP; dTARGET;
4633a7c4
LW		 1071 GV *newdefout, *egv;
1072 HV *hv;
1073
533c011a 1074 newdefout = (PL_op->op_private > 0) ? ((GV *) POPs) : (GV *) NULL;
4633a7c4 1075
3280af22 1076 egv = GvEGV(PL_defoutgv);
4633a7c4 1077 if (!egv)
3280af22 1078 egv = PL_defoutgv;
4633a7c4
LW		 1079 hv = GvSTASH(egv);
1080 if (! hv)
3280af22 1081 XPUSHs(&PL_sv_undef);
4633a7c4 1082 else {
cbdc8872 1083 GV **gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
f86702cc 1084 if (gvp && *gvp == egv) {
3280af22 1085 gv_efullname3(TARG, PL_defoutgv, Nullch);
f86702cc 1086 XPUSHTARG;
1087 }
1088 else {
1089 XPUSHs(sv_2mortal(newRV((SV*)egv)));
1090 }
4633a7c4
LW		 1091 }
1092
1093 if (newdefout) {
ded8aa31
GS		 1094 if (!GvIO(newdefout))
1095 gv_IOadd(newdefout);
4633a7c4
LW		 1096 setdefout(newdefout);
1097 }
1098
a0d0e21e
LW		 1099 RETURN;
1100}
1101
1102PP(pp_getc)
1103{
4e35701f 1104 djSP; dTARGET;
a0d0e21e 1105 GV *gv;
2ae324a7 1106 MAGIC *mg;
a0d0e21e
LW		 1107
1108 if (MAXARG <= 0)
3280af22 1109 gv = PL_stdingv;
a0d0e21e
LW		 1110 else
1111 gv = (GV*)POPs;
1112 if (!gv)
3280af22 1113 gv = PL_argvgv;
2ae324a7 1114
33c27489 1115 if (mg = SvTIED_mg((SV*)gv, 'q')) {
54310121 1116 I32 gimme = GIMME_V;
2ae324a7 1117 PUSHMARK(SP);
33c27489 1118 XPUSHs(SvTIED_obj((SV*)gv, mg));
2ae324a7 1119 PUTBACK;
1120 ENTER;
864dbfa3 1121 call_method("GETC", gimme);
2ae324a7 1122 LEAVE;
1123 SPAGAIN;
54310121 1124 if (gimme == G_SCALAR)
1125 SvSetMagicSV_nosteal(TARG, TOPs);
2ae324a7 1126 RETURN;
1127 }
9bc64814 1128 if (!gv || do_eof(gv)) /* make sure we have fp with something */
a0d0e21e 1129 RETPUSHUNDEF;
bbce6d69 1130 TAINT;
a0d0e21e 1131 sv_setpv(TARG, " ");
9bc64814 1132 *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
a0d0e21e
LW		 1133 PUSHTARG;
1134 RETURN;
1135}
1136
1137PP(pp_read)
1138{
cea2e8a9 1139 return pp_sysread();
a0d0e21e
LW		 1140}
1141
76e3520e 1142STATIC OP *
cea2e8a9 1143S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
a0d0e21e 1144{
11343788 1145 dTHR;
c09156bb 1146 register PERL_CONTEXT *cx;
54310121 1147 I32 gimme = GIMME_V;
a0d0e21e
LW		 1148 AV* padlist = CvPADLIST(cv);
1149 SV** svp = AvARRAY(padlist);
1150
1151 ENTER;
1152 SAVETMPS;
1153
1154 push_return(retop);
3280af22 1155 PUSHBLOCK(cx, CXt_SUB, PL_stack_sp);
a0d0e21e 1156 PUSHFORMAT(cx);
3280af22
NIS		 1157 SAVESPTR(PL_curpad);
1158 PL_curpad = AvARRAY((AV*)svp[1]);
a0d0e21e 1159
4633a7c4 1160 setdefout(gv); /* locally select filehandle so $% et al work */
a0d0e21e
LW		 1161 return CvSTART(cv);
1162}
1163
1164PP(pp_enterwrite)
1165{
4e35701f 1166 djSP;
a0d0e21e
LW		 1167 register GV *gv;
1168 register IO *io;
1169 GV *fgv;
1170 CV *cv;
1171
1172 if (MAXARG == 0)
3280af22 1173 gv = PL_defoutgv;
a0d0e21e
LW		 1174 else {
1175 gv = (GV*)POPs;
1176 if (!gv)
3280af22 1177 gv = PL_defoutgv;
a0d0e21e
LW		 1178 }
1179 EXTEND(SP, 1);
1180 io = GvIO(gv);
1181 if (!io) {
1182 RETPUSHNO;
1183 }
1184 if (IoFMT_GV(io))
1185 fgv = IoFMT_GV(io);
1186 else
1187 fgv = gv;
1188
1189 cv = GvFORM(fgv);
a0d0e21e
LW		 1190 if (!cv) {
1191 if (fgv) {
748a9306 1192 SV *tmpsv = sv_newmortal();
aac0dd9a 1193 gv_efullname3(tmpsv, fgv, Nullch);
cea2e8a9 1194 DIE(aTHX_ "Undefined format \"%s\" called",SvPVX(tmpsv));
a0d0e21e 1195 }
cea2e8a9 1196 DIE(aTHX_ "Not a format reference");
a0d0e21e 1197 }
44a8e56a 1198 if (CvCLONE(cv))
1199 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
a0d0e21e 1200
44a8e56a 1201 IoFLAGS(io) &= ~IOf_DIDTOP;
533c011a 1202 return doform(cv,gv,PL_op->op_next);
a0d0e21e
LW		 1203}
1204
1205PP(pp_leavewrite)
1206{
4e35701f 1207 djSP;
a0d0e21e
LW		 1208 GV *gv = cxstack[cxstack_ix].blk_sub.gv;
1209 register IO *io = GvIOp(gv);
760ac839
LW		 1210 PerlIO *ofp = IoOFP(io);
1211 PerlIO *fp;
a0d0e21e
LW		 1212 SV **newsp;
1213 I32 gimme;
c09156bb 1214 register PERL_CONTEXT *cx;
a0d0e21e 1215
760ac839 1216 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
3280af22
NIS		 1217 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1218 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1219 PL_formtarget != PL_toptarget)
a0d0e21e 1220 {
4633a7c4
LW		 1221 GV *fgv;
1222 CV *cv;
a0d0e21e
LW		 1223 if (!IoTOP_GV(io)) {
1224 GV *topgv;
46fc3d4c 1225 SV *topname;
a0d0e21e
LW		 1226
1227 if (!IoTOP_NAME(io)) {
1228 if (!IoFMT_NAME(io))
1229 IoFMT_NAME(io) = savepv(GvNAME(gv));
cea2e8a9 1230 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%s_TOP", IoFMT_NAME(io)));
46fc3d4c 1231 topgv = gv_fetchpv(SvPVX(topname), FALSE, SVt_PVFM);
748a9306 1232 if ((topgv && GvFORM(topgv)) ||
a0d0e21e 1233 !gv_fetchpv("top",FALSE,SVt_PVFM))
46fc3d4c 1234 IoTOP_NAME(io) = savepv(SvPVX(topname));
a0d0e21e
LW		 1235 else
1236 IoTOP_NAME(io) = savepv("top");
1237 }
1238 topgv = gv_fetchpv(IoTOP_NAME(io),FALSE, SVt_PVFM);
1239 if (!topgv || !GvFORM(topgv)) {
1240 IoLINES_LEFT(io) = 100000000;
1241 goto forget_top;
1242 }
1243 IoTOP_GV(io) = topgv;
1244 }
748a9306
LW		 1245 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1246 I32 lines = IoLINES_LEFT(io);
3280af22 1247 char *s = SvPVX(PL_formtarget);
8e07c86e
AD		 1248 if (lines <= 0) /* Yow, header didn't even fit!!! */
1249 goto forget_top;
748a9306
LW		 1250 while (lines-- > 0) {
1251 s = strchr(s, '\n');
1252 if (!s)
1253 break;
1254 s++;
1255 }
1256 if (s) {
3280af22
NIS		 1257 PerlIO_write(ofp, SvPVX(PL_formtarget), s - SvPVX(PL_formtarget));
1258 sv_chop(PL_formtarget, s);
1259 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
748a9306
LW		 1260 }
1261 }
a0d0e21e 1262 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
3280af22 1263 PerlIO_write(ofp, SvPVX(PL_formfeed), SvCUR(PL_formfeed));
a0d0e21e
LW		 1264 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1265 IoPAGE(io)++;
3280af22 1266 PL_formtarget = PL_toptarget;
748a9306 1267 IoFLAGS(io) |= IOf_DIDTOP;
4633a7c4
LW		 1268 fgv = IoTOP_GV(io);
1269 if (!fgv)
cea2e8a9 1270 DIE(aTHX_ "bad top format reference");
4633a7c4
LW		 1271 cv = GvFORM(fgv);
1272 if (!cv) {
1273 SV *tmpsv = sv_newmortal();
aac0dd9a 1274 gv_efullname3(tmpsv, fgv, Nullch);
cea2e8a9 1275 DIE(aTHX_ "Undefined top format \"%s\" called",SvPVX(tmpsv));
4633a7c4 1276 }
44a8e56a 1277 if (CvCLONE(cv))
1278 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
533c011a 1279 return doform(cv,gv,PL_op);
a0d0e21e
LW		 1280 }
1281
1282 forget_top:
3280af22 1283 POPBLOCK(cx,PL_curpm);
a0d0e21e
LW		 1284 POPFORMAT(cx);
1285 LEAVE;
1286
1287 fp = IoOFP(io);
1288 if (!fp) {
599cee73 1289 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
af8c498a
GS		 1290 SV* sv = sv_newmortal();
1291 gv_efullname3(sv, gv, Nullch);
a0d0e21e 1292 if (IoIFP(io))
af8c498a
GS		 1293 Perl_warner(aTHX_ WARN_IO,
1294 "Filehandle %s opened only for input",
1295 SvPV_nolen(sv));
599cee73 1296 else if (ckWARN(WARN_CLOSED))
af8c498a
GS		 1297 Perl_warner(aTHX_ WARN_CLOSED,
1298 "Write on closed filehandle %s", SvPV_nolen(sv));
a0d0e21e 1299 }
3280af22 1300 PUSHs(&PL_sv_no);
a0d0e21e
LW		 1301 }
1302 else {
3280af22 1303 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
599cee73 1304 if (ckWARN(WARN_IO))
cea2e8a9 1305 Perl_warner(aTHX_ WARN_IO, "page overflow");
a0d0e21e 1306 }
3280af22 1307 if (!PerlIO_write(ofp, SvPVX(PL_formtarget), SvCUR(PL_formtarget)) ||
760ac839 1308 PerlIO_error(fp))
3280af22 1309 PUSHs(&PL_sv_no);
a0d0e21e 1310 else {
3280af22
NIS		 1311 FmLINES(PL_formtarget) = 0;
1312 SvCUR_set(PL_formtarget, 0);
1313 *SvEND(PL_formtarget) = '\0';
a0d0e21e 1314 if (IoFLAGS(io) & IOf_FLUSH)
760ac839 1315 (void)PerlIO_flush(fp);
3280af22 1316 PUSHs(&PL_sv_yes);
a0d0e21e
LW		 1317 }
1318 }
3280af22 1319 PL_formtarget = PL_bodytarget;
a0d0e21e
LW		 1320 PUTBACK;
1321 return pop_return();
1322}
1323
1324PP(pp_prtf)
1325{
4e35701f 1326 djSP; dMARK; dORIGMARK;
a0d0e21e
LW		 1327 GV *gv;
1328 IO *io;
760ac839 1329 PerlIO *fp;
26db47c4 1330 SV *sv;
46fc3d4c 1331 MAGIC *mg;
2d8e6c8d 1332 STRLEN n_a;
a0d0e21e 1333
533c011a 1334 if (PL_op->op_flags & OPf_STACKED)
a0d0e21e
LW		 1335 gv = (GV*)*++MARK;
1336 else
3280af22 1337 gv = PL_defoutgv;
46fc3d4c 1338
33c27489 1339 if (mg = SvTIED_mg((SV*)gv, 'q')) {
46fc3d4c 1340 if (MARK == ORIGMARK) {
4352c267 1341 MEXTEND(SP, 1);
46fc3d4c 1342 ++MARK;
1343 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1344 ++SP;
1345 }
1346 PUSHMARK(MARK - 1);
33c27489 1347 *MARK = SvTIED_obj((SV*)gv, mg);
46fc3d4c 1348 PUTBACK;
1349 ENTER;
864dbfa3 1350 call_method("PRINTF", G_SCALAR);
46fc3d4c 1351 LEAVE;
1352 SPAGAIN;
1353 MARK = ORIGMARK + 1;
1354 *MARK = *SP;
1355 SP = MARK;
1356 RETURN;
1357 }
1358
26db47c4 1359 sv = NEWSV(0,0);
a0d0e21e 1360 if (!(io = GvIO(gv))) {
599cee73 1361 if (ckWARN(WARN_UNOPENED)) {
af8c498a
GS		 1362 gv_efullname3(sv, gv, Nullch);
1363 Perl_warner(aTHX_ WARN_UNOPENED,
1364 "Filehandle %s never opened", SvPV(sv,n_a));
748a9306
LW		 1365 }
1366 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW		 1367 goto just_say_no;
1368 }
1369 else if (!(fp = IoOFP(io))) {
599cee73 1370 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
af8c498a 1371 gv_efullname3(sv, gv, Nullch);
a0d0e21e 1372 if (IoIFP(io))
af8c498a
GS		 1373 Perl_warner(aTHX_ WARN_IO,
1374 "Filehandle %s opened only for input",
1375 SvPV(sv,n_a));
599cee73 1376 else if (ckWARN(WARN_CLOSED))
af8c498a
GS		 1377 Perl_warner(aTHX_ WARN_CLOSED,
1378 "printf on closed filehandle %s", SvPV(sv,n_a));
a0d0e21e 1379 }
748a9306 1380 SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
a0d0e21e
LW		 1381 goto just_say_no;
1382 }
1383 else {
1384 do_sprintf(sv, SP - MARK, MARK + 1);
1385 if (!do_print(sv, fp))
1386 goto just_say_no;
1387
1388 if (IoFLAGS(io) & IOf_FLUSH)
760ac839 1389 if (PerlIO_flush(fp) == EOF)
a0d0e21e
LW		 1390 goto just_say_no;
1391 }
1392 SvREFCNT_dec(sv);
1393 SP = ORIGMARK;
3280af22 1394 PUSHs(&PL_sv_yes);
a0d0e21e
LW		 1395 RETURN;
1396
1397 just_say_no:
1398 SvREFCNT_dec(sv);
1399 SP = ORIGMARK;
3280af22 1400 PUSHs(&PL_sv_undef);
a0d0e21e
LW		 1401 RETURN;
1402}
1403
c07a80fd 1404PP(pp_sysopen)
1405{
4e35701f 1406 djSP;
c07a80fd 1407 GV *gv;
c07a80fd 1408 SV *sv;
1409 char *tmps;
1410 STRLEN len;
1411 int mode, perm;
1412
1413 if (MAXARG > 3)
1414 perm = POPi;
1415 else
1416 perm = 0666;
1417 mode = POPi;
1418 sv = POPs;
1419 gv = (GV *)POPs;
1420
4592e6ca
NIS		 1421 /* Need TIEHANDLE method ? */
1422
c07a80fd 1423 tmps = SvPV(sv, len);
1424 if (do_open(gv, tmps, len, TRUE, mode, perm, Nullfp)) {
1425 IoLINES(GvIOp(gv)) = 0;
3280af22 1426 PUSHs(&PL_sv_yes);
c07a80fd 1427 }
1428 else {
3280af22 1429 PUSHs(&PL_sv_undef);
c07a80fd 1430 }
1431 RETURN;
1432}
1433
a0d0e21e
LW		 1434PP(pp_sysread)
1435{
4e35701f 1436 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW		 1437 int offset;
1438 GV *gv;
1439 IO *io;
1440 char *buffer;
5b54f415 1441 SSize_t length;
1e422769 1442 Sock_size_t bufsize;
748a9306 1443 SV *bufsv;
a0d0e21e 1444 STRLEN blen;
2ae324a7 1445 MAGIC *mg;
a0d0e21e
LW		 1446
1447 gv = (GV*)*++MARK;
533c011a 1448 if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD) &&
33c27489 1449 (mg = SvTIED_mg((SV*)gv, 'q')))
137443ea 1450 {
2ae324a7 1451 SV *sv;
1452
1453 PUSHMARK(MARK-1);
33c27489 1454 *MARK = SvTIED_obj((SV*)gv, mg);
2ae324a7 1455 ENTER;
864dbfa3 1456 call_method("READ", G_SCALAR);
2ae324a7 1457 LEAVE;
1458 SPAGAIN;
1459 sv = POPs;
1460 SP = ORIGMARK;
1461 PUSHs(sv);
1462 RETURN;
1463 }
1464
a0d0e21e
LW		 1465 if (!gv)
1466 goto say_undef;
748a9306 1467 bufsv = *++MARK;
ff68c719 1468 if (! SvOK(bufsv))
1469 sv_setpvn(bufsv, "", 0);
748a9306 1470 buffer = SvPV_force(bufsv, blen);
a0d0e21e
LW		 1471 length = SvIVx(*++MARK);
1472 if (length < 0)
cea2e8a9 1473 DIE(aTHX_ "Negative length");
748a9306 1474 SETERRNO(0,0);
a0d0e21e
LW		 1475 if (MARK < SP)
1476 offset = SvIVx(*++MARK);
1477 else
1478 offset = 0;
1479 io = GvIO(gv);
1480 if (!io || !IoIFP(io))
1481 goto say_undef;
1482#ifdef HAS_SOCKET
533c011a 1483 if (PL_op->op_type == OP_RECV) {
46fc3d4c 1484 char namebuf[MAXPATHLEN];
eec2d3df 1485#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE)
490ab354
JH		 1486 bufsize = sizeof (struct sockaddr_in);
1487#else
46fc3d4c 1488 bufsize = sizeof namebuf;
490ab354 1489#endif
abf95952
IZ		 1490#ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1491 if (bufsize >= 256)
1492 bufsize = 255;
1493#endif
626727d5
GS		 1494#ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1495 if (bufsize >= 256)
1496 bufsize = 255;
1497#endif
748a9306 1498 buffer = SvGROW(bufsv, length+1);
bbce6d69 1499 /* 'offset' means 'flags' here */
6ad3d225 1500 length = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
46fc3d4c 1501 (struct sockaddr *)namebuf, &bufsize);
a0d0e21e
LW		 1502 if (length < 0)
1503 RETPUSHUNDEF;
748a9306
LW		 1504 SvCUR_set(bufsv, length);
1505 *SvEND(bufsv) = '\0';
1506 (void)SvPOK_only(bufsv);
1507 SvSETMAGIC(bufsv);
aac0dd9a 1508 /* This should not be marked tainted if the fp is marked clean */
bbce6d69 1509 if (!(IoFLAGS(io) & IOf_UNTAINT))
1510 SvTAINTED_on(bufsv);
a0d0e21e 1511 SP = ORIGMARK;
46fc3d4c 1512 sv_setpvn(TARG, namebuf, bufsize);
a0d0e21e
LW		 1513 PUSHs(TARG);
1514 RETURN;
1515 }
1516#else
911d147d 1517 if (PL_op->op_type == OP_RECV)
cea2e8a9 1518 DIE(aTHX_ PL_no_sock_func, "recv");
a0d0e21e 1519#endif
bbce6d69 1520 if (offset < 0) {
1521 if (-offset > blen)
cea2e8a9 1522 DIE(aTHX_ "Offset outside string");
bbce6d69 1523 offset += blen;
1524 }
cd52b7b2 1525 bufsize = SvCUR(bufsv);
748a9306 1526 buffer = SvGROW(bufsv, length+offset+1);
cd52b7b2 1527 if (offset > bufsize) { /* Zero any newly allocated space */
1528 Zero(buffer+bufsize, offset-bufsize, char);
1529 }
533c011a 1530 if (PL_op->op_type == OP_SYSREAD) {
a7092146
GS		 1531#ifdef PERL_SOCK_SYSREAD_IS_RECV
1532 if (IoTYPE(io) == 's') {
1533 length = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
1534 buffer+offset, length, 0);
1535 }
1536 else
1537#endif
1538 {
1539 length = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
1540 buffer+offset, length);
1541 }
a0d0e21e
LW		 1542 }
1543 else
1544#ifdef HAS_SOCKET__bad_code_maybe
1545 if (IoTYPE(io) == 's') {
46fc3d4c 1546 char namebuf[MAXPATHLEN];
490ab354
JH		 1547#if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
1548 bufsize = sizeof (struct sockaddr_in);
1549#else
46fc3d4c 1550 bufsize = sizeof namebuf;
490ab354 1551#endif
6ad3d225 1552 length = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer+offset, length, 0,
46fc3d4c 1553 (struct sockaddr *)namebuf, &bufsize);
a0d0e21e
LW		 1554 }
1555 else
1556#endif
3b02c43c 1557 {
760ac839 1558 length = PerlIO_read(IoIFP(io), buffer+offset, length);
3b02c43c 1559 /* fread() returns 0 on both error and EOF */
5c7a8c78 1560 if (length == 0 && PerlIO_error(IoIFP(io)))
3b02c43c
GS		 1561 length = -1;
1562 }
af8c498a
GS		 1563 if (length < 0) {
1564 if (IoTYPE(io) == '>' || IoIFP(io) == PerlIO_stdout()
1565 || IoIFP(io) == PerlIO_stderr())
1566 {
1567 SV* sv = sv_newmortal();
1568 gv_efullname3(sv, gv, Nullch);
1569 Perl_warner(aTHX_ WARN_IO, "Filehandle %s opened only for output",
1570 SvPV_nolen(sv));
1571 }
a0d0e21e 1572 goto say_undef;
af8c498a 1573 }
748a9306
LW		 1574 SvCUR_set(bufsv, length+offset);
1575 *SvEND(bufsv) = '\0';
1576 (void)SvPOK_only(bufsv);
1577 SvSETMAGIC(bufsv);
aac0dd9a 1578 /* This should not be marked tainted if the fp is marked clean */
bbce6d69 1579 if (!(IoFLAGS(io) & IOf_UNTAINT))
1580 SvTAINTED_on(bufsv);
a0d0e21e
LW		 1581 SP = ORIGMARK;
1582 PUSHi(length);
1583 RETURN;
1584
1585 say_undef:
1586 SP = ORIGMARK;
1587 RETPUSHUNDEF;
1588}
1589
1590PP(pp_syswrite)
1591{
092bebab
JH		 1592 djSP;
1593 int items = (SP - PL_stack_base) - TOPMARK;
1594 if (items == 2) {
9f089d78 1595 SV *sv;
092bebab 1596 EXTEND(SP, 1);
9f089d78
SB		 1597 sv = sv_2mortal(newSViv(sv_len(*SP)));
1598 PUSHs(sv);
092bebab
JH		 1599 PUTBACK;
1600 }
cea2e8a9 1601 return pp_send();
a0d0e21e
LW		 1602}
1603
1604PP(pp_send)
1605{
4e35701f 1606 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW		 1607 GV *gv;
1608 IO *io;
1609 int offset;
748a9306 1610 SV *bufsv;
a0d0e21e
LW		 1611 char *buffer;
1612 int length;
1613 STRLEN blen;
1d603a67 1614 MAGIC *mg;
a0d0e21e
LW		 1615
1616 gv = (GV*)*++MARK;
33c27489 1617 if (PL_op->op_type == OP_SYSWRITE && (mg = SvTIED_mg((SV*)gv, 'q'))) {
1d603a67
GB		 1618 SV *sv;
1619
1620 PUSHMARK(MARK-1);
33c27489 1621 *MARK = SvTIED_obj((SV*)gv, mg);
1d603a67 1622 ENTER;
864dbfa3 1623 call_method("WRITE", G_SCALAR);
1d603a67
GB		 1624 LEAVE;
1625 SPAGAIN;
1626 sv = POPs;
1627 SP = ORIGMARK;
1628 PUSHs(sv);
1629 RETURN;
1630 }
a0d0e21e
LW		 1631 if (!gv)
1632 goto say_undef;
748a9306
LW		 1633 bufsv = *++MARK;
1634 buffer = SvPV(bufsv, blen);
a0d0e21e
LW		 1635 length = SvIVx(*++MARK);
1636 if (length < 0)
cea2e8a9 1637 DIE(aTHX_ "Negative length");
748a9306 1638 SETERRNO(0,0);
a0d0e21e
LW		 1639 io = GvIO(gv);
1640 if (!io || !IoIFP(io)) {
1641 length = -1;
599cee73 1642 if (ckWARN(WARN_CLOSED)) {
533c011a 1643 if (PL_op->op_type == OP_SYSWRITE)
cea2e8a9 1644 Perl_warner(aTHX_ WARN_CLOSED, "Syswrite on closed filehandle");
a0d0e21e 1645 else
cea2e8a9 1646 Perl_warner(aTHX_ WARN_CLOSED, "Send on closed socket");
a0d0e21e
LW		 1647 }
1648 }
533c011a 1649 else if (PL_op->op_type == OP_SYSWRITE) {
bbce6d69 1650 if (MARK < SP) {
a0d0e21e 1651 offset = SvIVx(*++MARK);
bbce6d69 1652 if (offset < 0) {
1653 if (-offset > blen)
cea2e8a9 1654 DIE(aTHX_ "Offset outside string");
bbce6d69 1655 offset += blen;
fb73857a 1656 } else if (offset >= blen && blen > 0)
cea2e8a9 1657 DIE(aTHX_ "Offset outside string");
bbce6d69 1658 } else
a0d0e21e
LW		 1659 offset = 0;
1660 if (length > blen - offset)
1661 length = blen - offset;
a7092146
GS		 1662#ifdef PERL_SOCK_SYSWRITE_IS_SEND
1663 if (IoTYPE(io) == 's') {
1664 length = PerlSock_send(PerlIO_fileno(IoIFP(io)),
1665 buffer+offset, length, 0);
1666 }
1667 else
1668#endif
1669 {
94e4c244 1670 /* See the note at doio.c:do_print about filesize limits. --jhi */
a7092146
GS		 1671 length = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
1672 buffer+offset, length);
1673 }
a0d0e21e
LW		 1674 }
1675#ifdef HAS_SOCKET
1676 else if (SP > MARK) {
1677 char *sockbuf;
1678 STRLEN mlen;
1679 sockbuf = SvPVx(*++MARK, mlen);
6ad3d225 1680 length = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen, length,
a0d0e21e
LW		 1681 (struct sockaddr *)sockbuf, mlen);
1682 }
1683 else
6ad3d225 1684 length = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, length);
490ab354 1685
a0d0e21e
LW		 1686#else
1687 else
cea2e8a9 1688 DIE(aTHX_ PL_no_sock_func, "send");
a0d0e21e
LW		 1689#endif
1690 if (length < 0)
1691 goto say_undef;
1692 SP = ORIGMARK;
1693 PUSHi(length);
1694 RETURN;
1695
1696 say_undef:
1697 SP = ORIGMARK;
1698 RETPUSHUNDEF;
1699}
1700
1701PP(pp_recv)
1702{
cea2e8a9 1703 return pp_sysread();
a0d0e21e
LW		 1704}
1705
1706PP(pp_eof)
1707{
4e35701f 1708 djSP;
a0d0e21e 1709 GV *gv;
4592e6ca 1710 MAGIC *mg;
a0d0e21e
LW		 1711
1712 if (MAXARG <= 0)
3280af22 1713 gv = PL_last_in_gv;
a0d0e21e 1714 else
3280af22 1715 gv = PL_last_in_gv = (GV*)POPs;
4592e6ca
NIS		 1716
1717 if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
1718 PUSHMARK(SP);
1719 XPUSHs(SvTIED_obj((SV*)gv, mg));
1720 PUTBACK;
1721 ENTER;
864dbfa3 1722 call_method("EOF", G_SCALAR);
4592e6ca
NIS		 1723 LEAVE;
1724 SPAGAIN;
1725 RETURN;
1726 }
1727
54310121 1728 PUSHs(boolSV(!gv || do_eof(gv)));
a0d0e21e
LW		 1729 RETURN;
1730}
1731
1732PP(pp_tell)
1733{
4e35701f 1734 djSP; dTARGET;
4592e6ca
NIS		 1735 GV *gv;
1736 MAGIC *mg;
a0d0e21e
LW		 1737
1738 if (MAXARG <= 0)
3280af22 1739 gv = PL_last_in_gv;
a0d0e21e 1740 else
3280af22 1741 gv = PL_last_in_gv = (GV*)POPs;
4592e6ca
NIS		 1742
1743 if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
1744 PUSHMARK(SP);
1745 XPUSHs(SvTIED_obj((SV*)gv, mg));
1746 PUTBACK;
1747 ENTER;
864dbfa3 1748 call_method("TELL", G_SCALAR);
4592e6ca
NIS		 1749 LEAVE;
1750 SPAGAIN;
1751 RETURN;
1752 }
1753
a0d0e21e
LW		 1754 PUSHi( do_tell(gv) );
1755 RETURN;
1756}
1757
1758PP(pp_seek)
1759{
cea2e8a9 1760 return pp_sysseek();
137443ea 1761}
1762
1763PP(pp_sysseek)
1764{
4e35701f 1765 djSP;
a0d0e21e
LW		 1766 GV *gv;
1767 int whence = POPi;
d9b3e12d 1768 Off_t offset = (Off_t)SvIVx(POPs);
4592e6ca 1769 MAGIC *mg;
a0d0e21e 1770
3280af22 1771 gv = PL_last_in_gv = (GV*)POPs;
4592e6ca
NIS		 1772
1773 if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
1774 PUSHMARK(SP);
1775 XPUSHs(SvTIED_obj((SV*)gv, mg));
1776 XPUSHs(sv_2mortal(newSViv((IV) offset)));
1777 XPUSHs(sv_2mortal(newSViv((IV) whence)));
1778 PUTBACK;
1779 ENTER;
864dbfa3 1780 call_method("SEEK", G_SCALAR);
4592e6ca
NIS		 1781 LEAVE;
1782 SPAGAIN;
1783 RETURN;
1784 }
1785
533c011a 1786 if (PL_op->op_type == OP_SEEK)
8903cb82 1787 PUSHs(boolSV(do_seek(gv, offset, whence)));
1788 else {
97cc44eb 1789 Off_t n = do_sysseek(gv, offset, whence);
3280af22 1790 PUSHs((n < 0) ? &PL_sv_undef
8903cb82 1791 : sv_2mortal(n ? newSViv((IV)n)
79cb57f6 1792 : newSVpvn(zero_but_true, ZBTLEN)));
8903cb82 1793 }
a0d0e21e
LW		 1794 RETURN;
1795}
1796
1797PP(pp_truncate)
1798{
4e35701f 1799 djSP;
a0d0e21e
LW		 1800 Off_t len = (Off_t)POPn;
1801 int result = 1;
1802 GV *tmpgv;
2d8e6c8d 1803 STRLEN n_a;
a0d0e21e 1804
748a9306 1805 SETERRNO(0,0);
5d94fbed 1806#if defined(HAS_TRUNCATE) || defined(HAS_CHSIZE) || defined(F_FREESP)
533c011a 1807 if (PL_op->op_flags & OPf_SPECIAL) {
2d8e6c8d 1808 tmpgv = gv_fetchpv(POPpx, FALSE, SVt_PVIO);
cbdc8872 1809 do_ftruncate:
1e422769 1810 TAINT_PROPER("truncate");
a0d0e21e 1811 if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv)) ||
cbdc8872 1812#ifdef HAS_TRUNCATE
760ac839 1813 ftruncate(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
cbdc8872 1814#else
760ac839 1815 my_chsize(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
cbdc8872 1816#endif
a0d0e21e
LW		 1817 result = 0;
1818 }
1819 else {
cbdc8872 1820 SV *sv = POPs;
1e422769 1821 char *name;
2d8e6c8d 1822 STRLEN n_a;
1e422769 1823
cbdc8872 1824 if (SvTYPE(sv) == SVt_PVGV) {
1825 tmpgv = (GV*)sv; /* *main::FRED for example */
1826 goto do_ftruncate;
1827 }
1828 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
1829 tmpgv = (GV*) SvRV(sv); /* \*main::FRED for example */
1830 goto do_ftruncate;
1831 }
1e422769 1832
2d8e6c8d 1833 name = SvPV(sv, n_a);
1e422769 1834 TAINT_PROPER("truncate");
cbdc8872 1835#ifdef HAS_TRUNCATE
1e422769 1836 if (truncate(name, len) < 0)
a0d0e21e 1837 result = 0;
cbdc8872 1838#else
1839 {
1840 int tmpfd;
6ad3d225 1841 if ((tmpfd = PerlLIO_open(name, O_RDWR)) < 0)
bbce6d69 1842 result = 0;
cbdc8872 1843 else {
1844 if (my_chsize(tmpfd, len) < 0)
1845 result = 0;
6ad3d225 1846 PerlLIO_close(tmpfd);
cbdc8872 1847 }
a0d0e21e 1848 }
a0d0e21e 1849#endif
cbdc8872 1850 }
a0d0e21e
LW		 1851
1852 if (result)
1853 RETPUSHYES;
1854 if (!errno)
748a9306 1855 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW		 1856 RETPUSHUNDEF;
1857#else
cea2e8a9 1858 DIE(aTHX_ "truncate not implemented");
a0d0e21e
LW		 1859#endif
1860}
1861
1862PP(pp_fcntl)
1863{
cea2e8a9 1864 return pp_ioctl();
a0d0e21e
LW		 1865}
1866
1867PP(pp_ioctl)
1868{
4e35701f 1869 djSP; dTARGET;
748a9306 1870 SV *argsv = POPs;
a0d0e21e 1871 unsigned int func = U_I(POPn);
533c011a 1872 int optype = PL_op->op_type;
a0d0e21e 1873 char *s;
324aa91a 1874 IV retval;
a0d0e21e
LW		 1875 GV *gv = (GV*)POPs;
1876 IO *io = GvIOn(gv);
1877
748a9306
LW		 1878 if (!io || !argsv || !IoIFP(io)) {
1879 SETERRNO(EBADF,RMS$_IFI); /* well, sort of... */
a0d0e21e
LW		 1880 RETPUSHUNDEF;
1881 }
1882
748a9306 1883 if (SvPOK(argsv) || !SvNIOK(argsv)) {
a0d0e21e 1884 STRLEN len;
324aa91a 1885 STRLEN need;
748a9306 1886 s = SvPV_force(argsv, len);
324aa91a
HF		 1887 need = IOCPARM_LEN(func);
1888 if (len < need) {
1889 s = Sv_Grow(argsv, need + 1);
1890 SvCUR_set(argsv, need);
a0d0e21e
LW		 1891 }
1892
748a9306 1893 s[SvCUR(argsv)] = 17; /* a little sanity check here */
a0d0e21e
LW		 1894 }
1895 else {
748a9306 1896 retval = SvIV(argsv);
a0d0e21e 1897 s = (char*)retval; /* ouch */
a0d0e21e
LW		 1898 }
1899
1900 TAINT_PROPER(optype == OP_IOCTL ? "ioctl" : "fcntl");
1901
1902 if (optype == OP_IOCTL)
1903#ifdef HAS_IOCTL
76e3520e 1904 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
a0d0e21e 1905#else
cea2e8a9 1906 DIE(aTHX_ "ioctl is not implemented");
a0d0e21e
LW		 1907#endif
1908 else
55497cff 1909#ifdef HAS_FCNTL
1910#if defined(OS2) && defined(__EMX__)
760ac839 1911 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
55497cff 1912#else
760ac839 1913 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
55497cff 1914#endif
1915#else
cea2e8a9 1916 DIE(aTHX_ "fcntl is not implemented");
a0d0e21e
LW		 1917#endif
1918
748a9306
LW		 1919 if (SvPOK(argsv)) {
1920 if (s[SvCUR(argsv)] != 17)
cea2e8a9 1921 DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
22c35a8c 1922 PL_op_name[optype]);
748a9306
LW		 1923 s[SvCUR(argsv)] = 0; /* put our null back */
1924 SvSETMAGIC(argsv); /* Assume it has changed */
a0d0e21e
LW		 1925 }
1926
1927 if (retval == -1)
1928 RETPUSHUNDEF;
1929 if (retval != 0) {
1930 PUSHi(retval);
1931 }
1932 else {
8903cb82 1933 PUSHp(zero_but_true, ZBTLEN);
a0d0e21e
LW		 1934 }
1935 RETURN;
1936}
1937
1938PP(pp_flock)
1939{
4e35701f 1940 djSP; dTARGET;
a0d0e21e
LW		 1941 I32 value;
1942 int argtype;
1943 GV *gv;
760ac839 1944 PerlIO *fp;
16d20bd9 1945
ff68c719 1946#ifdef FLOCK
a0d0e21e
LW		 1947 argtype = POPi;
1948 if (MAXARG <= 0)
3280af22 1949 gv = PL_last_in_gv;
a0d0e21e
LW		 1950 else
1951 gv = (GV*)POPs;
1952 if (gv && GvIO(gv))
1953 fp = IoIFP(GvIOp(gv));
1954 else
1955 fp = Nullfp;
1956 if (fp) {
68dc0745 1957 (void)PerlIO_flush(fp);
76e3520e 1958 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
a0d0e21e
LW		 1959 }
1960 else
1961 value = 0;
1962 PUSHi(value);
1963 RETURN;
1964#else
cea2e8a9 1965 DIE(aTHX_ PL_no_func, "flock()");
a0d0e21e
LW		 1966#endif
1967}
1968
1969/* Sockets. */
1970
1971PP(pp_socket)
1972{
4e35701f 1973 djSP;
a0d0e21e
LW		 1974#ifdef HAS_SOCKET
1975 GV *gv;
1976 register IO *io;
1977 int protocol = POPi;
1978 int type = POPi;
1979 int domain = POPi;
1980 int fd;
1981
1982 gv = (GV*)POPs;
1983
1984 if (!gv) {
748a9306 1985 SETERRNO(EBADF,LIB$_INVARG);
a0d0e21e
LW		 1986 RETPUSHUNDEF;
1987 }
1988
1989 io = GvIOn(gv);
1990 if (IoIFP(io))
1991 do_close(gv, FALSE);
1992
1993 TAINT_PROPER("socket");
6ad3d225 1994 fd = PerlSock_socket(domain, type, protocol);
a0d0e21e
LW		 1995 if (fd < 0)
1996 RETPUSHUNDEF;
760ac839
LW		 1997 IoIFP(io) = PerlIO_fdopen(fd, "r"); /* stdio gets confused about sockets */
1998 IoOFP(io) = PerlIO_fdopen(fd, "w");
a0d0e21e
LW		 1999 IoTYPE(io) = 's';
2000 if (!IoIFP(io) || !IoOFP(io)) {
760ac839
LW		 2001 if (IoIFP(io)) PerlIO_close(IoIFP(io));
2002 if (IoOFP(io)) PerlIO_close(IoOFP(io));
6ad3d225 2003 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
a0d0e21e
LW		 2004 RETPUSHUNDEF;
2005 }
2006
2007 RETPUSHYES;
2008#else
cea2e8a9 2009 DIE(aTHX_ PL_no_sock_func, "socket");
a0d0e21e
LW		 2010#endif
2011}
2012
2013PP(pp_sockpair)
2014{
4e35701f 2015 djSP;
a0d0e21e
LW		 2016#ifdef HAS_SOCKETPAIR
2017 GV *gv1;
2018 GV *gv2;
2019 register IO *io1;
2020 register IO *io2;
2021 int protocol = POPi;
2022 int type = POPi;
2023 int domain = POPi;
2024 int fd[2];
2025
2026 gv2 = (GV*)POPs;
2027 gv1 = (GV*)POPs;
2028 if (!gv1 || !gv2)
2029 RETPUSHUNDEF;
2030
2031 io1 = GvIOn(gv1);
2032 io2 = GvIOn(gv2);
2033 if (IoIFP(io1))
2034 do_close(gv1, FALSE);
2035 if (IoIFP(io2))
2036 do_close(gv2, FALSE);
2037
2038 TAINT_PROPER("socketpair");
6ad3d225 2039 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
a0d0e21e 2040 RETPUSHUNDEF;
760ac839
LW		 2041 IoIFP(io1) = PerlIO_fdopen(fd[0], "r");
2042 IoOFP(io1) = PerlIO_fdopen(fd[0], "w");
a0d0e21e 2043 IoTYPE(io1) = 's';
760ac839
LW		 2044 IoIFP(io2) = PerlIO_fdopen(fd[1], "r");
2045 IoOFP(io2) = PerlIO_fdopen(fd[1], "w");
a0d0e21e
LW		 2046 IoTYPE(io2) = 's';
2047 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
760ac839
LW		 2048 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2049 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
6ad3d225 2050 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
760ac839
LW		 2051 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2052 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
6ad3d225 2053 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
a0d0e21e
LW		 2054 RETPUSHUNDEF;
2055 }
2056
2057 RETPUSHYES;
2058#else
cea2e8a9 2059 DIE(aTHX_ PL_no_sock_func, "socketpair");
a0d0e21e
LW		 2060#endif
2061}
2062
2063PP(pp_bind)
2064{
4e35701f 2065 djSP;
a0d0e21e 2066#ifdef HAS_SOCKET
eec2d3df
GS		 2067#ifdef MPE /* Requires PRIV mode to bind() to ports < 1024 */
2068 extern GETPRIVMODE();
2069 extern GETUSERMODE();
2070#endif
748a9306 2071 SV *addrsv = POPs;
a0d0e21e
LW		 2072 char *addr;
2073 GV *gv = (GV*)POPs;
2074 register IO *io = GvIOn(gv);
2075 STRLEN len;
eec2d3df
GS		 2076 int bind_ok = 0;
2077#ifdef MPE
2078 int mpeprivmode = 0;
2079#endif
a0d0e21e
LW		 2080
2081 if (!io || !IoIFP(io))
2082 goto nuts;
2083
748a9306 2084 addr = SvPV(addrsv, len);
a0d0e21e 2085 TAINT_PROPER("bind");
eec2d3df
GS		 2086#ifdef MPE /* Deal with MPE bind() peculiarities */
2087 if (((struct sockaddr *)addr)->sa_family == AF_INET) {
2088 /* The address *MUST* stupidly be zero. */
2089 ((struct sockaddr_in *)addr)->sin_addr.s_addr = INADDR_ANY;
2090 /* PRIV mode is required to bind() to ports < 1024. */
2091 if (((struct sockaddr_in *)addr)->sin_port < 1024 &&
2092 ((struct sockaddr_in *)addr)->sin_port > 0) {
2093 GETPRIVMODE(); /* If this fails, we are aborted by MPE/iX. */
2094 mpeprivmode = 1;
2095 }
2096 }
2097#endif /* MPE */
2098 if (PerlSock_bind(PerlIO_fileno(IoIFP(io)),
2099 (struct sockaddr *)addr, len) >= 0)
2100 bind_ok = 1;
2101
2102#ifdef MPE /* Switch back to USER mode */
2103 if (mpeprivmode)
2104 GETUSERMODE();
2105#endif /* MPE */
2106
2107 if (bind_ok)
a0d0e21e
LW		 2108 RETPUSHYES;
2109 else
2110 RETPUSHUNDEF;
2111
2112nuts:
599cee73 2113 if (ckWARN(WARN_CLOSED))
cea2e8a9 2114 Perl_warner(aTHX_ WARN_CLOSED, "bind() on closed fd");
748a9306 2115 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2116 RETPUSHUNDEF;
2117#else
cea2e8a9 2118 DIE(aTHX_ PL_no_sock_func, "bind");
a0d0e21e
LW		 2119#endif
2120}
2121
2122PP(pp_connect)
2123{
4e35701f 2124 djSP;
a0d0e21e 2125#ifdef HAS_SOCKET
748a9306 2126 SV *addrsv = POPs;
a0d0e21e
LW		 2127 char *addr;
2128 GV *gv = (GV*)POPs;
2129 register IO *io = GvIOn(gv);
2130 STRLEN len;
2131
2132 if (!io || !IoIFP(io))
2133 goto nuts;
2134
748a9306 2135 addr = SvPV(addrsv, len);
a0d0e21e 2136 TAINT_PROPER("connect");
6ad3d225 2137 if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
a0d0e21e
LW		 2138 RETPUSHYES;
2139 else
2140 RETPUSHUNDEF;
2141
2142nuts:
599cee73 2143 if (ckWARN(WARN_CLOSED))
cea2e8a9 2144 Perl_warner(aTHX_ WARN_CLOSED, "connect() on closed fd");
748a9306 2145 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2146 RETPUSHUNDEF;
2147#else
cea2e8a9 2148 DIE(aTHX_ PL_no_sock_func, "connect");
a0d0e21e
LW		 2149#endif
2150}
2151
2152PP(pp_listen)
2153{
4e35701f 2154 djSP;
a0d0e21e
LW		 2155#ifdef HAS_SOCKET
2156 int backlog = POPi;
2157 GV *gv = (GV*)POPs;
2158 register IO *io = GvIOn(gv);
2159
2160 if (!io || !IoIFP(io))
2161 goto nuts;
2162
6ad3d225 2163 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
a0d0e21e
LW		 2164 RETPUSHYES;
2165 else
2166 RETPUSHUNDEF;
2167
2168nuts:
599cee73 2169 if (ckWARN(WARN_CLOSED))
cea2e8a9 2170 Perl_warner(aTHX_ WARN_CLOSED, "listen() on closed fd");
748a9306 2171 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2172 RETPUSHUNDEF;
2173#else
cea2e8a9 2174 DIE(aTHX_ PL_no_sock_func, "listen");
a0d0e21e
LW		 2175#endif
2176}
2177
2178PP(pp_accept)
2179{
4e35701f 2180 djSP; dTARGET;
a0d0e21e
LW		 2181#ifdef HAS_SOCKET
2182 GV *ngv;
2183 GV *ggv;
2184 register IO *nstio;
2185 register IO *gstio;
4633a7c4 2186 struct sockaddr saddr; /* use a struct to avoid alignment problems */
1e422769 2187 Sock_size_t len = sizeof saddr;
a0d0e21e
LW		 2188 int fd;
2189
2190 ggv = (GV*)POPs;
2191 ngv = (GV*)POPs;
2192
2193 if (!ngv)
2194 goto badexit;
2195 if (!ggv)
2196 goto nuts;
2197
2198 gstio = GvIO(ggv);
2199 if (!gstio || !IoIFP(gstio))
2200 goto nuts;
2201
2202 nstio = GvIOn(ngv);
2203 if (IoIFP(nstio))
2204 do_close(ngv, FALSE);
2205
6ad3d225 2206 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *)&saddr, &len);
a0d0e21e
LW		 2207 if (fd < 0)
2208 goto badexit;
760ac839
LW		 2209 IoIFP(nstio) = PerlIO_fdopen(fd, "r");
2210 IoOFP(nstio) = PerlIO_fdopen(fd, "w");
a0d0e21e
LW		 2211 IoTYPE(nstio) = 's';
2212 if (!IoIFP(nstio) || !IoOFP(nstio)) {
760ac839
LW		 2213 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2214 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
6ad3d225 2215 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
a0d0e21e
LW		 2216 goto badexit;
2217 }
2218
748a9306 2219 PUSHp((char *)&saddr, len);
a0d0e21e
LW		 2220 RETURN;
2221
2222nuts:
599cee73 2223 if (ckWARN(WARN_CLOSED))
cea2e8a9 2224 Perl_warner(aTHX_ WARN_CLOSED, "accept() on closed fd");
748a9306 2225 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2226
2227badexit:
2228 RETPUSHUNDEF;
2229
2230#else
cea2e8a9 2231 DIE(aTHX_ PL_no_sock_func, "accept");
a0d0e21e
LW		 2232#endif
2233}
2234
2235PP(pp_shutdown)
2236{
4e35701f 2237 djSP; dTARGET;
a0d0e21e
LW		 2238#ifdef HAS_SOCKET
2239 int how = POPi;
2240 GV *gv = (GV*)POPs;
2241 register IO *io = GvIOn(gv);
2242
2243 if (!io || !IoIFP(io))
2244 goto nuts;
2245
6ad3d225 2246 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
a0d0e21e
LW		 2247 RETURN;
2248
2249nuts:
599cee73 2250 if (ckWARN(WARN_CLOSED))
cea2e8a9 2251 Perl_warner(aTHX_ WARN_CLOSED, "shutdown() on closed fd");
748a9306 2252 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2253 RETPUSHUNDEF;
2254#else
cea2e8a9 2255 DIE(aTHX_ PL_no_sock_func, "shutdown");
a0d0e21e
LW		 2256#endif
2257}
2258
2259PP(pp_gsockopt)
2260{
2261#ifdef HAS_SOCKET
cea2e8a9 2262 return pp_ssockopt();
a0d0e21e 2263#else
cea2e8a9 2264 DIE(aTHX_ PL_no_sock_func, "getsockopt");
a0d0e21e
LW		 2265#endif
2266}
2267
2268PP(pp_ssockopt)
2269{
4e35701f 2270 djSP;
a0d0e21e 2271#ifdef HAS_SOCKET
533c011a 2272 int optype = PL_op->op_type;
a0d0e21e
LW		 2273 SV *sv;
2274 int fd;
2275 unsigned int optname;
2276 unsigned int lvl;
2277 GV *gv;
2278 register IO *io;
1e422769 2279 Sock_size_t len;
a0d0e21e
LW		 2280
2281 if (optype == OP_GSOCKOPT)
2282 sv = sv_2mortal(NEWSV(22, 257));
2283 else
2284 sv = POPs;
2285 optname = (unsigned int) POPi;
2286 lvl = (unsigned int) POPi;
2287
2288 gv = (GV*)POPs;
2289 io = GvIOn(gv);
2290 if (!io || !IoIFP(io))
2291 goto nuts;
2292
760ac839 2293 fd = PerlIO_fileno(IoIFP(io));
a0d0e21e
LW		 2294 switch (optype) {
2295 case OP_GSOCKOPT:
748a9306 2296 SvGROW(sv, 257);
a0d0e21e 2297 (void)SvPOK_only(sv);
748a9306
LW		 2298 SvCUR_set(sv,256);
2299 *SvEND(sv) ='\0';
1e422769 2300 len = SvCUR(sv);
6ad3d225 2301 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
a0d0e21e 2302 goto nuts2;
1e422769 2303 SvCUR_set(sv, len);
748a9306 2304 *SvEND(sv) ='\0';
a0d0e21e
LW		 2305 PUSHs(sv);
2306 break;
2307 case OP_SSOCKOPT: {
1e422769 2308 char *buf;
2309 int aint;
2310 if (SvPOKp(sv)) {
2d8e6c8d
GS		 2311 STRLEN l;
2312 buf = SvPV(sv, l);
2313 len = l;
1e422769 2314 }
56ee1660 2315 else {
a0d0e21e
LW		 2316 aint = (int)SvIV(sv);
2317 buf = (char*)&aint;
2318 len = sizeof(int);
2319 }
6ad3d225 2320 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
a0d0e21e 2321 goto nuts2;
3280af22 2322 PUSHs(&PL_sv_yes);
a0d0e21e
LW		 2323 }
2324 break;
2325 }
2326 RETURN;
2327
2328nuts:
599cee73 2329 if (ckWARN(WARN_CLOSED))
cea2e8a9 2330 Perl_warner(aTHX_ WARN_CLOSED, "[gs]etsockopt() on closed fd");
748a9306 2331 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2332nuts2:
2333 RETPUSHUNDEF;
2334
2335#else
cea2e8a9 2336 DIE(aTHX_ PL_no_sock_func, "setsockopt");
a0d0e21e
LW		 2337#endif
2338}
2339
2340PP(pp_getsockname)
2341{
2342#ifdef HAS_SOCKET
cea2e8a9 2343 return pp_getpeername();
a0d0e21e 2344#else
cea2e8a9 2345 DIE(aTHX_ PL_no_sock_func, "getsockname");
a0d0e21e
LW		 2346#endif
2347}
2348
2349PP(pp_getpeername)
2350{
4e35701f 2351 djSP;
a0d0e21e 2352#ifdef HAS_SOCKET
533c011a 2353 int optype = PL_op->op_type;
a0d0e21e
LW		 2354 SV *sv;
2355 int fd;
2356 GV *gv = (GV*)POPs;
2357 register IO *io = GvIOn(gv);
1e422769 2358 Sock_size_t len;
a0d0e21e
LW		 2359
2360 if (!io || !IoIFP(io))
2361 goto nuts;
2362
2363 sv = sv_2mortal(NEWSV(22, 257));
748a9306 2364 (void)SvPOK_only(sv);
1e422769 2365 len = 256;
2366 SvCUR_set(sv, len);
748a9306 2367 *SvEND(sv) ='\0';
760ac839 2368 fd = PerlIO_fileno(IoIFP(io));
a0d0e21e
LW		 2369 switch (optype) {
2370 case OP_GETSOCKNAME:
6ad3d225 2371 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
a0d0e21e
LW		 2372 goto nuts2;
2373 break;
2374 case OP_GETPEERNAME:
6ad3d225 2375 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
a0d0e21e 2376 goto nuts2;
490ab354
JH		 2377#if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2378 {
2379 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";
2380 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2381 if (((struct sockaddr *)SvPVX(sv))->sa_family == AF_INET &&
2382 !memcmp((char *)SvPVX(sv) + sizeof(u_short), nowhere,
2383 sizeof(u_short) + sizeof(struct in_addr))) {
2384 goto nuts2;
2385 }
2386 }
2387#endif
a0d0e21e
LW		 2388 break;
2389 }
13826f2c
CS		 2390#ifdef BOGUS_GETNAME_RETURN
2391 /* Interactive Unix, getpeername() and getsockname()
2392 does not return valid namelen */
1e422769 2393 if (len == BOGUS_GETNAME_RETURN)
2394 len = sizeof(struct sockaddr);
13826f2c 2395#endif
1e422769 2396 SvCUR_set(sv, len);
748a9306 2397 *SvEND(sv) ='\0';
a0d0e21e
LW		 2398 PUSHs(sv);
2399 RETURN;
2400
2401nuts:
599cee73 2402 if (ckWARN(WARN_CLOSED))
cea2e8a9 2403 Perl_warner(aTHX_ WARN_CLOSED, "get{sock, peer}name() on closed fd");
748a9306 2404 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2405nuts2:
2406 RETPUSHUNDEF;
2407
2408#else
cea2e8a9 2409 DIE(aTHX_ PL_no_sock_func, "getpeername");
a0d0e21e
LW		 2410#endif
2411}
2412
2413/* Stat calls. */
2414
2415PP(pp_lstat)
2416{
cea2e8a9 2417 return pp_stat();
a0d0e21e
LW		 2418}
2419
2420PP(pp_stat)
2421{
4e35701f 2422 djSP;
a0d0e21e 2423 GV *tmpgv;
54310121 2424 I32 gimme;
a0d0e21e 2425 I32 max = 13;
2d8e6c8d 2426 STRLEN n_a;
a0d0e21e 2427
533c011a 2428 if (PL_op->op_flags & OPf_REF) {
a0d0e21e 2429 tmpgv = cGVOP->op_gv;
748a9306 2430 do_fstat:
3280af22
NIS		 2431 if (tmpgv != PL_defgv) {
2432 PL_laststype = OP_STAT;
2433 PL_statgv = tmpgv;
2434 sv_setpv(PL_statname, "");
2435 PL_laststatval = (GvIO(tmpgv) && IoIFP(GvIOp(tmpgv))
2436 ? PerlLIO_fstat(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), &PL_statcache) : -1);
a0d0e21e 2437 }
3280af22 2438 if (PL_laststatval < 0)
a0d0e21e
LW		 2439 max = 0;
2440 }
2441 else {
748a9306
LW		 2442 SV* sv = POPs;
2443 if (SvTYPE(sv) == SVt_PVGV) {
2444 tmpgv = (GV*)sv;
2445 goto do_fstat;
2446 }
2447 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2448 tmpgv = (GV*)SvRV(sv);
2449 goto do_fstat;
2450 }
2d8e6c8d 2451 sv_setpv(PL_statname, SvPV(sv,n_a));
3280af22 2452 PL_statgv = Nullgv;
a0d0e21e 2453#ifdef HAS_LSTAT
533c011a
NIS		 2454 PL_laststype = PL_op->op_type;
2455 if (PL_op->op_type == OP_LSTAT)
2d8e6c8d 2456 PL_laststatval = PerlLIO_lstat(SvPV(PL_statname, n_a), &PL_statcache);
a0d0e21e
LW		 2457 else
2458#endif
2d8e6c8d 2459 PL_laststatval = PerlLIO_stat(SvPV(PL_statname, n_a), &PL_statcache);
3280af22 2460 if (PL_laststatval < 0) {
2d8e6c8d 2461 if (ckWARN(WARN_NEWLINE) && strchr(SvPV(PL_statname, n_a), '\n'))
cea2e8a9 2462 Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "stat");
a0d0e21e
LW		 2463 max = 0;
2464 }
2465 }
2466
54310121 2467 gimme = GIMME_V;
2468 if (gimme != G_ARRAY) {
2469 if (gimme != G_VOID)
2470 XPUSHs(boolSV(max));
2471 RETURN;
a0d0e21e
LW		 2472 }
2473 if (max) {
36477c24 2474 EXTEND(SP, max);
2475 EXTEND_MORTAL(max);
1ff81528
PL		 2476 PUSHs(sv_2mortal(newSViv(PL_statcache.st_dev)));
2477 PUSHs(sv_2mortal(newSViv(PL_statcache.st_ino)));
2478 PUSHs(sv_2mortal(newSViv(PL_statcache.st_mode)));
2479 PUSHs(sv_2mortal(newSViv(PL_statcache.st_nlink)));
2480 PUSHs(sv_2mortal(newSViv(PL_statcache.st_uid)));
2481 PUSHs(sv_2mortal(newSViv(PL_statcache.st_gid)));
cbdc8872 2482#ifdef USE_STAT_RDEV
1ff81528 2483 PUSHs(sv_2mortal(newSViv(PL_statcache.st_rdev)));
cbdc8872 2484#else
79cb57f6 2485 PUSHs(sv_2mortal(newSVpvn("", 0)));
cbdc8872 2486#endif
1ff81528 2487 PUSHs(sv_2mortal(newSViv(PL_statcache.st_size)));
cbdc8872 2488#ifdef BIG_TIME
172ae379
JH		 2489 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_atime)));
2490 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_mtime)));
2491 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_ctime)));
cbdc8872 2492#else
1ff81528
PL		 2493 PUSHs(sv_2mortal(newSViv(PL_statcache.st_atime)));
2494 PUSHs(sv_2mortal(newSViv(PL_statcache.st_mtime)));
2495 PUSHs(sv_2mortal(newSViv(PL_statcache.st_ctime)));
cbdc8872 2496#endif
a0d0e21e 2497#ifdef USE_STAT_BLOCKS
1ff81528
PL		 2498 PUSHs(sv_2mortal(newSViv(PL_statcache.st_blksize)));
2499 PUSHs(sv_2mortal(newSViv(PL_statcache.st_blocks)));
a0d0e21e 2500#else
79cb57f6
GS		 2501 PUSHs(sv_2mortal(newSVpvn("", 0)));
2502 PUSHs(sv_2mortal(newSVpvn("", 0)));
a0d0e21e
LW		 2503#endif
2504 }
2505 RETURN;
2506}
2507
2508PP(pp_ftrread)
2509{
5ff3f7a4 2510 I32 result;
4e35701f 2511 djSP;
5ff3f7a4 2512#if defined(HAS_ACCESS) && defined(R_OK)
2d8e6c8d 2513 STRLEN n_a;
5ff3f7a4 2514 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2515 result = access(TOPpx, R_OK);
5ff3f7a4
GS		 2516 if (result == 0)
2517 RETPUSHYES;
2518 if (result < 0)
2519 RETPUSHUNDEF;
2520 RETPUSHNO;
22865c03
GS		 2521 }
2522 else
cea2e8a9 2523 result = my_stat();
5ff3f7a4 2524#else
cea2e8a9 2525 result = my_stat();
5ff3f7a4 2526#endif
22865c03 2527 SPAGAIN;
a0d0e21e
LW		 2528 if (result < 0)
2529 RETPUSHUNDEF;
3280af22 2530 if (cando(S_IRUSR, 0, &PL_statcache))
a0d0e21e
LW		 2531 RETPUSHYES;
2532 RETPUSHNO;
2533}
2534
2535PP(pp_ftrwrite)
2536{
5ff3f7a4 2537 I32 result;
4e35701f 2538 djSP;
5ff3f7a4 2539#if defined(HAS_ACCESS) && defined(W_OK)
2d8e6c8d 2540 STRLEN n_a;
5ff3f7a4 2541 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2542 result = access(TOPpx, W_OK);
5ff3f7a4
GS		 2543 if (result == 0)
2544 RETPUSHYES;
2545 if (result < 0)
2546 RETPUSHUNDEF;
2547 RETPUSHNO;
22865c03
GS		 2548 }
2549 else
cea2e8a9 2550 result = my_stat();
5ff3f7a4 2551#else
cea2e8a9 2552 result = my_stat();
5ff3f7a4 2553#endif
22865c03 2554 SPAGAIN;
a0d0e21e
LW		 2555 if (result < 0)
2556 RETPUSHUNDEF;
3280af22 2557 if (cando(S_IWUSR, 0, &PL_statcache))
a0d0e21e
LW		 2558 RETPUSHYES;
2559 RETPUSHNO;
2560}
2561
2562PP(pp_ftrexec)
2563{
5ff3f7a4 2564 I32 result;
4e35701f 2565 djSP;
5ff3f7a4 2566#if defined(HAS_ACCESS) && defined(X_OK)
2d8e6c8d 2567 STRLEN n_a;
5ff3f7a4 2568 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2569 result = access(TOPpx, X_OK);
5ff3f7a4
GS		 2570 if (result == 0)
2571 RETPUSHYES;
2572 if (result < 0)
2573 RETPUSHUNDEF;
2574 RETPUSHNO;
22865c03
GS		 2575 }
2576 else
cea2e8a9 2577 result = my_stat();
5ff3f7a4 2578#else
cea2e8a9 2579 result = my_stat();
5ff3f7a4 2580#endif
22865c03 2581 SPAGAIN;
a0d0e21e
LW		 2582 if (result < 0)
2583 RETPUSHUNDEF;
3280af22 2584 if (cando(S_IXUSR, 0, &PL_statcache))
a0d0e21e
LW		 2585 RETPUSHYES;
2586 RETPUSHNO;
2587}
2588
2589PP(pp_fteread)
2590{
5ff3f7a4 2591 I32 result;
4e35701f 2592 djSP;
5ff3f7a4 2593#ifdef PERL_EFF_ACCESS_R_OK
2d8e6c8d 2594 STRLEN n_a;
5ff3f7a4 2595 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2596 result = PERL_EFF_ACCESS_R_OK(TOPpx);
5ff3f7a4
GS		 2597 if (result == 0)
2598 RETPUSHYES;
2599 if (result < 0)
2600 RETPUSHUNDEF;
2601 RETPUSHNO;
22865c03
GS		 2602 }
2603 else
cea2e8a9 2604 result = my_stat();
5ff3f7a4 2605#else
cea2e8a9 2606 result = my_stat();
5ff3f7a4 2607#endif
22865c03 2608 SPAGAIN;
a0d0e21e
LW		 2609 if (result < 0)
2610 RETPUSHUNDEF;
3280af22 2611 if (cando(S_IRUSR, 1, &PL_statcache))
a0d0e21e
LW		 2612 RETPUSHYES;
2613 RETPUSHNO;
2614}
2615
2616PP(pp_ftewrite)
2617{
5ff3f7a4 2618 I32 result;
4e35701f 2619 djSP;
5ff3f7a4 2620#ifdef PERL_EFF_ACCESS_W_OK
2d8e6c8d 2621 STRLEN n_a;
5ff3f7a4 2622 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2623 result = PERL_EFF_ACCESS_W_OK(TOPpx);
5ff3f7a4
GS		 2624 if (result == 0)
2625 RETPUSHYES;
2626 if (result < 0)
2627 RETPUSHUNDEF;
2628 RETPUSHNO;
22865c03
GS		 2629 }
2630 else
cea2e8a9 2631 result = my_stat();
5ff3f7a4 2632#else
cea2e8a9 2633 result = my_stat();
5ff3f7a4 2634#endif
22865c03 2635 SPAGAIN;
a0d0e21e
LW		 2636 if (result < 0)
2637 RETPUSHUNDEF;
3280af22 2638 if (cando(S_IWUSR, 1, &PL_statcache))
a0d0e21e
LW		 2639 RETPUSHYES;
2640 RETPUSHNO;
2641}
2642
2643PP(pp_fteexec)
2644{
5ff3f7a4 2645 I32 result;
4e35701f 2646 djSP;
5ff3f7a4 2647#ifdef PERL_EFF_ACCESS_X_OK
2d8e6c8d 2648 STRLEN n_a;
5ff3f7a4 2649 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2650 result = PERL_EFF_ACCESS_X_OK(TOPpx);
5ff3f7a4
GS		 2651 if (result == 0)
2652 RETPUSHYES;
2653 if (result < 0)
2654 RETPUSHUNDEF;
2655 RETPUSHNO;
22865c03
GS		 2656 }
2657 else
cea2e8a9 2658 result = my_stat();
5ff3f7a4 2659#else
cea2e8a9 2660 result = my_stat();
5ff3f7a4 2661#endif
22865c03 2662 SPAGAIN;
a0d0e21e
LW		 2663 if (result < 0)
2664 RETPUSHUNDEF;
3280af22 2665 if (cando(S_IXUSR, 1, &PL_statcache))
a0d0e21e
LW		 2666 RETPUSHYES;
2667 RETPUSHNO;
2668}
2669
2670PP(pp_ftis)
2671{
cea2e8a9 2672 I32 result = my_stat();
4e35701f 2673 djSP;
a0d0e21e
LW		 2674 if (result < 0)
2675 RETPUSHUNDEF;
2676 RETPUSHYES;
2677}
2678
2679PP(pp_fteowned)
2680{
cea2e8a9 2681 return pp_ftrowned();
a0d0e21e
LW		 2682}
2683
2684PP(pp_ftrowned)
2685{
cea2e8a9 2686 I32 result = my_stat();
4e35701f 2687 djSP;
a0d0e21e
LW		 2688 if (result < 0)
2689 RETPUSHUNDEF;
533c011a 2690 if (PL_statcache.st_uid == (PL_op->op_type == OP_FTEOWNED ? PL_euid : PL_uid) )
a0d0e21e
LW		 2691 RETPUSHYES;
2692 RETPUSHNO;
2693}
2694
2695PP(pp_ftzero)
2696{
cea2e8a9 2697 I32 result = my_stat();
4e35701f 2698 djSP;
a0d0e21e
LW		 2699 if (result < 0)
2700 RETPUSHUNDEF;
3280af22 2701 if (!PL_statcache.st_size)
a0d0e21e
LW		 2702 RETPUSHYES;
2703 RETPUSHNO;
2704}
2705
2706PP(pp_ftsize)
2707{
cea2e8a9 2708 I32 result = my_stat();
4e35701f 2709 djSP; dTARGET;
a0d0e21e
LW		 2710 if (result < 0)
2711 RETPUSHUNDEF;
3280af22 2712 PUSHi(PL_statcache.st_size);
a0d0e21e
LW		 2713 RETURN;
2714}
2715
2716PP(pp_ftmtime)
2717{
cea2e8a9 2718 I32 result = my_stat();
4e35701f 2719 djSP; dTARGET;
a0d0e21e
LW		 2720 if (result < 0)
2721 RETPUSHUNDEF;
c6419e06 2722 PUSHn( (PL_basetime - PL_statcache.st_mtime) / 86400.0 );
a0d0e21e
LW		 2723 RETURN;
2724}
2725
2726PP(pp_ftatime)
2727{
cea2e8a9 2728 I32 result = my_stat();
4e35701f 2729 djSP; dTARGET;
a0d0e21e
LW		 2730 if (result < 0)
2731 RETPUSHUNDEF;
c6419e06 2732 PUSHn( (PL_basetime - PL_statcache.st_atime) / 86400.0 );
a0d0e21e
LW		 2733 RETURN;
2734}
2735
2736PP(pp_ftctime)
2737{
cea2e8a9 2738 I32 result = my_stat();
4e35701f 2739 djSP; dTARGET;
a0d0e21e
LW		 2740 if (result < 0)
2741 RETPUSHUNDEF;
c6419e06 2742 PUSHn( (PL_basetime - PL_statcache.st_ctime) / 86400.0 );
a0d0e21e
LW		 2743 RETURN;
2744}
2745
2746PP(pp_ftsock)
2747{
cea2e8a9 2748 I32 result = my_stat();
4e35701f 2749 djSP;
a0d0e21e
LW		 2750 if (result < 0)
2751 RETPUSHUNDEF;
3280af22 2752 if (S_ISSOCK(PL_statcache.st_mode))
a0d0e21e
LW		 2753 RETPUSHYES;
2754 RETPUSHNO;
2755}
2756
2757PP(pp_ftchr)
2758{
cea2e8a9 2759 I32 result = my_stat();
4e35701f 2760 djSP;
a0d0e21e
LW		 2761 if (result < 0)
2762 RETPUSHUNDEF;
3280af22 2763 if (S_ISCHR(PL_statcache.st_mode))
a0d0e21e
LW		 2764 RETPUSHYES;
2765 RETPUSHNO;
2766}
2767
2768PP(pp_ftblk)
2769{
cea2e8a9 2770 I32 result = my_stat();
4e35701f 2771 djSP;
a0d0e21e
LW		 2772 if (result < 0)
2773 RETPUSHUNDEF;
3280af22 2774 if (S_ISBLK(PL_statcache.st_mode))
a0d0e21e
LW		 2775 RETPUSHYES;
2776 RETPUSHNO;
2777}
2778
2779PP(pp_ftfile)
2780{
cea2e8a9 2781 I32 result = my_stat();
4e35701f 2782 djSP;
a0d0e21e
LW		 2783 if (result < 0)
2784 RETPUSHUNDEF;
3280af22 2785 if (S_ISREG(PL_statcache.st_mode))
a0d0e21e
LW		 2786 RETPUSHYES;
2787 RETPUSHNO;
2788}
2789
2790PP(pp_ftdir)
2791{
cea2e8a9 2792 I32 result = my_stat();
4e35701f 2793 djSP;
a0d0e21e
LW		 2794 if (result < 0)
2795 RETPUSHUNDEF;
3280af22 2796 if (S_ISDIR(PL_statcache.st_mode))
a0d0e21e
LW		 2797 RETPUSHYES;
2798 RETPUSHNO;
2799}
2800
2801PP(pp_ftpipe)
2802{
cea2e8a9 2803 I32 result = my_stat();
4e35701f 2804 djSP;
a0d0e21e
LW		 2805 if (result < 0)
2806 RETPUSHUNDEF;
3280af22 2807 if (S_ISFIFO(PL_statcache.st_mode))
a0d0e21e
LW		 2808 RETPUSHYES;
2809 RETPUSHNO;
2810}
2811
2812PP(pp_ftlink)
2813{
cea2e8a9 2814 I32 result = my_lstat();
4e35701f 2815 djSP;
a0d0e21e
LW		 2816 if (result < 0)
2817 RETPUSHUNDEF;
3280af22 2818 if (S_ISLNK(PL_statcache.st_mode))
a0d0e21e
LW		 2819 RETPUSHYES;
2820 RETPUSHNO;
2821}
2822
2823PP(pp_ftsuid)
2824{
4e35701f 2825 djSP;
a0d0e21e 2826#ifdef S_ISUID
cea2e8a9 2827 I32 result = my_stat();
a0d0e21e
LW		 2828 SPAGAIN;
2829 if (result < 0)
2830 RETPUSHUNDEF;
3280af22 2831 if (PL_statcache.st_mode & S_ISUID)
a0d0e21e
LW		 2832 RETPUSHYES;
2833#endif
2834 RETPUSHNO;
2835}
2836
2837PP(pp_ftsgid)
2838{
4e35701f 2839 djSP;
a0d0e21e 2840#ifdef S_ISGID
cea2e8a9 2841 I32 result = my_stat();
a0d0e21e
LW		 2842 SPAGAIN;
2843 if (result < 0)
2844 RETPUSHUNDEF;
3280af22 2845 if (PL_statcache.st_mode & S_ISGID)
a0d0e21e
LW		 2846 RETPUSHYES;
2847#endif
2848 RETPUSHNO;
2849}
2850
2851PP(pp_ftsvtx)
2852{
4e35701f 2853 djSP;
a0d0e21e 2854#ifdef S_ISVTX
cea2e8a9 2855 I32 result = my_stat();
a0d0e21e
LW		 2856 SPAGAIN;
2857 if (result < 0)
2858 RETPUSHUNDEF;
3280af22 2859 if (PL_statcache.st_mode & S_ISVTX)
a0d0e21e
LW		 2860 RETPUSHYES;
2861#endif
2862 RETPUSHNO;
2863}
2864
2865PP(pp_fttty)
2866{
4e35701f 2867 djSP;
a0d0e21e
LW		 2868 int fd;
2869 GV *gv;
fb73857a 2870 char *tmps = Nullch;
2d8e6c8d 2871 STRLEN n_a;
fb73857a 2872
533c011a 2873 if (PL_op->op_flags & OPf_REF)
a0d0e21e 2874 gv = cGVOP->op_gv;
fb73857a 2875 else if (isGV(TOPs))
2876 gv = (GV*)POPs;
2877 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
2878 gv = (GV*)SvRV(POPs);
a0d0e21e 2879 else
2d8e6c8d 2880 gv = gv_fetchpv(tmps = POPpx, FALSE, SVt_PVIO);
fb73857a 2881
a0d0e21e 2882 if (GvIO(gv) && IoIFP(GvIOp(gv)))
760ac839 2883 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
fb73857a 2884 else if (tmps && isDIGIT(*tmps))
a0d0e21e
LW		 2885 fd = atoi(tmps);
2886 else
2887 RETPUSHUNDEF;
6ad3d225 2888 if (PerlLIO_isatty(fd))
a0d0e21e
LW		 2889 RETPUSHYES;
2890 RETPUSHNO;
2891}
2892
16d20bd9
AD		 2893#if defined(atarist) /* this will work with atariST. Configure will
2894 make guesses for other systems. */
2895# define FILE_base(f) ((f)->_base)
2896# define FILE_ptr(f) ((f)->_ptr)
2897# define FILE_cnt(f) ((f)->_cnt)
2898# define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
a0d0e21e
LW		 2899#endif
2900
2901PP(pp_fttext)
2902{
4e35701f 2903 djSP;
a0d0e21e
LW		 2904 I32 i;
2905 I32 len;
2906 I32 odd = 0;
2907 STDCHAR tbuf[512];
2908 register STDCHAR *s;
2909 register IO *io;
5f05dabc 2910 register SV *sv;
2911 GV *gv;
2d8e6c8d 2912 STRLEN n_a;
a0d0e21e 2913
533c011a 2914 if (PL_op->op_flags & OPf_REF)
5f05dabc 2915 gv = cGVOP->op_gv;
2916 else if (isGV(TOPs))
2917 gv = (GV*)POPs;
2918 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
2919 gv = (GV*)SvRV(POPs);
2920 else
2921 gv = Nullgv;
2922
2923 if (gv) {
a0d0e21e 2924 EXTEND(SP, 1);
3280af22
NIS		 2925 if (gv == PL_defgv) {
2926 if (PL_statgv)
2927 io = GvIO(PL_statgv);
a0d0e21e 2928 else {
3280af22 2929 sv = PL_statname;
a0d0e21e
LW		 2930 goto really_filename;
2931 }
2932 }
2933 else {
3280af22
NIS		 2934 PL_statgv = gv;
2935 PL_laststatval = -1;
2936 sv_setpv(PL_statname, "");
2937 io = GvIO(PL_statgv);
a0d0e21e
LW		 2938 }
2939 if (io && IoIFP(io)) {
5f05dabc 2940 if (! PerlIO_has_base(IoIFP(io)))
cea2e8a9 2941 DIE(aTHX_ "-T and -B not implemented on filehandles");
3280af22
NIS		 2942 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
2943 if (PL_laststatval < 0)
5f05dabc 2944 RETPUSHUNDEF;
3280af22 2945 if (S_ISDIR(PL_statcache.st_mode)) /* handle NFS glitch */
533c011a 2946 if (PL_op->op_type == OP_FTTEXT)
a0d0e21e
LW		 2947 RETPUSHNO;
2948 else
2949 RETPUSHYES;
a20bf0c3 2950 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
760ac839 2951 i = PerlIO_getc(IoIFP(io));
a0d0e21e 2952 if (i != EOF)
760ac839 2953 (void)PerlIO_ungetc(IoIFP(io),i);
a0d0e21e 2954 }
a20bf0c3 2955 if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
a0d0e21e 2956 RETPUSHYES;
a20bf0c3
JH		 2957 len = PerlIO_get_bufsiz(IoIFP(io));
2958 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
760ac839
LW		 2959 /* sfio can have large buffers - limit to 512 */
2960 if (len > 512)
2961 len = 512;
a0d0e21e
LW		 2962 }
2963 else {
599cee73 2964 if (ckWARN(WARN_UNOPENED))
cea2e8a9 2965 Perl_warner(aTHX_ WARN_UNOPENED, "Test on unopened file <%s>",
a0d0e21e 2966 GvENAME(cGVOP->op_gv));
748a9306 2967 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW		 2968 RETPUSHUNDEF;
2969 }
2970 }
2971 else {
2972 sv = POPs;
5f05dabc 2973 really_filename:
3280af22
NIS		 2974 PL_statgv = Nullgv;
2975 PL_laststatval = -1;
2d8e6c8d 2976 sv_setpv(PL_statname, SvPV(sv, n_a));
a0d0e21e 2977#ifdef HAS_OPEN3
2d8e6c8d 2978 i = PerlLIO_open3(SvPV(sv, n_a), O_RDONLY, 0);
a0d0e21e 2979#else
2d8e6c8d 2980 i = PerlLIO_open(SvPV(sv, n_a), 0);
a0d0e21e
LW		 2981#endif
2982 if (i < 0) {
2d8e6c8d 2983 if (ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, n_a), '\n'))
cea2e8a9 2984 Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "open");
a0d0e21e
LW		 2985 RETPUSHUNDEF;
2986 }
3280af22
NIS		 2987 PL_laststatval = PerlLIO_fstat(i, &PL_statcache);
2988 if (PL_laststatval < 0)
5f05dabc 2989 RETPUSHUNDEF;
6ad3d225
GS		 2990 len = PerlLIO_read(i, tbuf, 512);
2991 (void)PerlLIO_close(i);
a0d0e21e 2992 if (len <= 0) {
533c011a 2993 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
a0d0e21e
LW		 2994 RETPUSHNO; /* special case NFS directories */
2995 RETPUSHYES; /* null file is anything */
2996 }
2997 s = tbuf;
2998 }
2999
3000 /* now scan s to look for textiness */
4633a7c4 3001 /* XXX ASCII dependent code */
a0d0e21e
LW		 3002
3003 for (i = 0; i < len; i++, s++) {
3004 if (!*s) { /* null never allowed in text */
3005 odd += len;
3006 break;
3007 }
9d116dd7
JH		 3008#ifdef EBCDIC
3009 else if (!(isPRINT(*s) || isSPACE(*s)))
3010 odd++;
3011#else
a0d0e21e
LW		 3012 else if (*s & 128)
3013 odd++;
3014 else if (*s < 32 &&
3015 *s != '\n' && *s != '\r' && *s != '\b' &&
3016 *s != '\t' && *s != '\f' && *s != 27)
3017 odd++;
9d116dd7 3018#endif
a0d0e21e
LW		 3019 }
3020
533c011a 3021 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
a0d0e21e
LW		 3022 RETPUSHNO;
3023 else
3024 RETPUSHYES;
3025}
3026
3027PP(pp_ftbinary)
3028{
cea2e8a9 3029 return pp_fttext();
a0d0e21e
LW		 3030}
3031
3032/* File calls. */
3033
3034PP(pp_chdir)
3035{
4e35701f 3036 djSP; dTARGET;
a0d0e21e
LW		 3037 char *tmps;
3038 SV **svp;
2d8e6c8d 3039 STRLEN n_a;
a0d0e21e
LW		 3040
3041 if (MAXARG < 1)
3042 tmps = Nullch;
3043 else
2d8e6c8d 3044 tmps = POPpx;
a0d0e21e 3045 if (!tmps || !*tmps) {
3280af22 3046 svp = hv_fetch(GvHVn(PL_envgv), "HOME", 4, FALSE);
a0d0e21e 3047 if (svp)
2d8e6c8d 3048 tmps = SvPV(*svp, n_a);
a0d0e21e
LW		 3049 }
3050 if (!tmps || !*tmps) {
3280af22 3051 svp = hv_fetch(GvHVn(PL_envgv), "LOGDIR", 6, FALSE);
a0d0e21e 3052 if (svp)
2d8e6c8d 3053 tmps = SvPV(*svp, n_a);
a0d0e21e 3054 }
491527d0
GS		 3055#ifdef VMS
3056 if (!tmps || !*tmps) {
6b88bc9c 3057 svp = hv_fetch(GvHVn(PL_envgv), "SYS$LOGIN", 9, FALSE);
491527d0 3058 if (svp)
2d8e6c8d 3059 tmps = SvPV(*svp, n_a);
491527d0
GS		 3060 }
3061#endif
a0d0e21e 3062 TAINT_PROPER("chdir");
6ad3d225 3063 PUSHi( PerlDir_chdir(tmps) >= 0 );
748a9306
LW		 3064#ifdef VMS
3065 /* Clear the DEFAULT element of ENV so we'll get the new value
3066 * in the future. */
6b88bc9c 3067 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
748a9306 3068#endif
a0d0e21e
LW		 3069 RETURN;
3070}
3071
3072PP(pp_chown)
3073{
4e35701f 3074 djSP; dMARK; dTARGET;
a0d0e21e
LW		 3075 I32 value;
3076#ifdef HAS_CHOWN
533c011a 3077 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 3078 SP = MARK;
3079 PUSHi(value);
3080 RETURN;
3081#else
cea2e8a9 3082 DIE(aTHX_ PL_no_func, "Unsupported function chown");
a0d0e21e
LW		 3083#endif
3084}
3085
3086PP(pp_chroot)
3087{
4e35701f 3088 djSP; dTARGET;
a0d0e21e
LW		 3089 char *tmps;
3090#ifdef HAS_CHROOT
2d8e6c8d
GS		 3091 STRLEN n_a;
3092 tmps = POPpx;
a0d0e21e
LW		 3093 TAINT_PROPER("chroot");
3094 PUSHi( chroot(tmps) >= 0 );
3095 RETURN;
3096#else
cea2e8a9 3097 DIE(aTHX_ PL_no_func, "chroot");
a0d0e21e
LW		 3098#endif
3099}
3100
3101PP(pp_unlink)
3102{
4e35701f 3103 djSP; dMARK; dTARGET;
a0d0e21e 3104 I32 value;
533c011a 3105 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 3106 SP = MARK;
3107 PUSHi(value);
3108 RETURN;
3109}
3110
3111PP(pp_chmod)
3112{
4e35701f 3113 djSP; dMARK; dTARGET;
a0d0e21e 3114 I32 value;
533c011a 3115 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 3116 SP = MARK;
3117 PUSHi(value);
3118 RETURN;
3119}
3120
3121PP(pp_utime)
3122{
4e35701f 3123 djSP; dMARK; dTARGET;
a0d0e21e 3124 I32 value;
533c011a 3125 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 3126 SP = MARK;
3127 PUSHi(value);
3128 RETURN;
3129}
3130
3131PP(pp_rename)
3132{
4e35701f 3133 djSP; dTARGET;
a0d0e21e 3134 int anum;
2d8e6c8d 3135 STRLEN n_a;
a0d0e21e 3136
2d8e6c8d
GS		 3137 char *tmps2 = POPpx;
3138 char *tmps = SvPV(TOPs, n_a);
a0d0e21e
LW		 3139 TAINT_PROPER("rename");
3140#ifdef HAS_RENAME
baed7233 3141 anum = PerlLIO_rename(tmps, tmps2);
a0d0e21e 3142#else
6b88bc9c 3143 if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
ed969818
W		 3144 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3145 anum = 1;
3146 else {
3654eb6c 3147 if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
ed969818
W		 3148 (void)UNLINK(tmps2);
3149 if (!(anum = link(tmps, tmps2)))
3150 anum = UNLINK(tmps);
3151 }
a0d0e21e
LW		 3152 }
3153#endif
3154 SETi( anum >= 0 );
3155 RETURN;
3156}
3157
3158PP(pp_link)
3159{
4e35701f 3160 djSP; dTARGET;
a0d0e21e 3161#ifdef HAS_LINK
2d8e6c8d
GS		 3162 STRLEN n_a;
3163 char *tmps2 = POPpx;
3164 char *tmps = SvPV(TOPs, n_a);
a0d0e21e
LW		 3165 TAINT_PROPER("link");
3166 SETi( link(tmps, tmps2) >= 0 );
3167#else
cea2e8a9 3168 DIE(aTHX_ PL_no_func, "Unsupported function link");
a0d0e21e
LW		 3169#endif
3170 RETURN;
3171}
3172
3173PP(pp_symlink)
3174{
4e35701f 3175 djSP; dTARGET;
a0d0e21e 3176#ifdef HAS_SYMLINK
2d8e6c8d
GS		 3177 STRLEN n_a;
3178 char *tmps2 = POPpx;
3179 char *tmps = SvPV(TOPs, n_a);
a0d0e21e
LW		 3180 TAINT_PROPER("symlink");
3181 SETi( symlink(tmps, tmps2) >= 0 );
3182 RETURN;
3183#else
cea2e8a9 3184 DIE(aTHX_ PL_no_func, "symlink");
a0d0e21e
LW		 3185#endif
3186}
3187
3188PP(pp_readlink)
3189{
4e35701f 3190 djSP; dTARGET;
a0d0e21e
LW		 3191#ifdef HAS_SYMLINK
3192 char *tmps;
46fc3d4c 3193 char buf[MAXPATHLEN];
a0d0e21e 3194 int len;
2d8e6c8d 3195 STRLEN n_a;
46fc3d4c 3196
fb73857a 3197#ifndef INCOMPLETE_TAINTS
3198 TAINT;
3199#endif
2d8e6c8d 3200 tmps = POPpx;
a0d0e21e
LW		 3201 len = readlink(tmps, buf, sizeof buf);
3202 EXTEND(SP, 1);
3203 if (len < 0)
3204 RETPUSHUNDEF;
3205 PUSHp(buf, len);
3206 RETURN;
3207#else
3208 EXTEND(SP, 1);
3209 RETSETUNDEF; /* just pretend it's a normal file */
3210#endif
3211}
3212
3213#if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
ba106d47 3214STATIC int
cea2e8a9 3215S_dooneliner(pTHX_ char *cmd, char *filename)
a0d0e21e 3216{
1e422769 3217 char *save_filename = filename;
3218 char *cmdline;
3219 char *s;
760ac839 3220 PerlIO *myfp;
1e422769 3221 int anum = 1;
a0d0e21e 3222
1e422769 3223 New(666, cmdline, strlen(cmd) + (strlen(filename) * 2) + 10, char);
3224 strcpy(cmdline, cmd);
3225 strcat(cmdline, " ");
3226 for (s = cmdline + strlen(cmdline); *filename; ) {
a0d0e21e
LW		 3227 *s++ = '\\';
3228 *s++ = *filename++;
3229 }
3230 strcpy(s, " 2>&1");
6ad3d225 3231 myfp = PerlProc_popen(cmdline, "r");
1e422769 3232 Safefree(cmdline);
3233
a0d0e21e 3234 if (myfp) {
1e422769 3235 SV *tmpsv = sv_newmortal();
6b88bc9c 3236 /* Need to save/restore 'PL_rs' ?? */
760ac839 3237 s = sv_gets(tmpsv, myfp, 0);
6ad3d225 3238 (void)PerlProc_pclose(myfp);
a0d0e21e 3239 if (s != Nullch) {
1e422769 3240 int e;
3241 for (e = 1;
a0d0e21e 3242#ifdef HAS_SYS_ERRLIST
1e422769 3243 e <= sys_nerr
3244#endif
3245 ; e++)
3246 {
3247 /* you don't see this */
3248 char *errmsg =
3249#ifdef HAS_SYS_ERRLIST
3250 sys_errlist[e]
a0d0e21e 3251#else
1e422769 3252 strerror(e)
a0d0e21e 3253#endif
1e422769 3254 ;
3255 if (!errmsg)
3256 break;
3257 if (instr(s, errmsg)) {
3258 SETERRNO(e,0);
3259 return 0;
3260 }
a0d0e21e 3261 }
748a9306 3262 SETERRNO(0,0);
a0d0e21e
LW		 3263#ifndef EACCES
3264#define EACCES EPERM
3265#endif
1e422769 3266 if (instr(s, "cannot make"))
748a9306 3267 SETERRNO(EEXIST,RMS$_FEX);
1e422769 3268 else if (instr(s, "existing file"))
748a9306 3269 SETERRNO(EEXIST,RMS$_FEX);
1e422769 3270 else if (instr(s, "ile exists"))
748a9306 3271 SETERRNO(EEXIST,RMS$_FEX);
1e422769 3272 else if (instr(s, "non-exist"))
748a9306 3273 SETERRNO(ENOENT,RMS$_FNF);
1e422769 3274 else if (instr(s, "does not exist"))
748a9306 3275 SETERRNO(ENOENT,RMS$_FNF);
1e422769 3276 else if (instr(s, "not empty"))
748a9306 3277 SETERRNO(EBUSY,SS$_DEVOFFLINE);
1e422769 3278 else if (instr(s, "cannot access"))
748a9306 3279 SETERRNO(EACCES,RMS$_PRV);
a0d0e21e 3280 else
748a9306 3281 SETERRNO(EPERM,RMS$_PRV);
a0d0e21e
LW		 3282 return 0;
3283 }
3284 else { /* some mkdirs return no failure indication */
6b88bc9c 3285 anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
911d147d 3286 if (PL_op->op_type == OP_RMDIR)
a0d0e21e
LW		 3287 anum = !anum;
3288 if (anum)
748a9306 3289 SETERRNO(0,0);
a0d0e21e 3290 else
748a9306 3291 SETERRNO(EACCES,RMS$_PRV); /* a guess */
a0d0e21e
LW		 3292 }
3293 return anum;
3294 }
3295 else
3296 return 0;
3297}
3298#endif
3299
3300PP(pp_mkdir)
3301{
4e35701f 3302 djSP; dTARGET;
a0d0e21e
LW		 3303 int mode = POPi;
3304#ifndef HAS_MKDIR
3305 int oldumask;
3306#endif
2d8e6c8d
GS		 3307 STRLEN n_a;
3308 char *tmps = SvPV(TOPs, n_a);
a0d0e21e
LW		 3309
3310 TAINT_PROPER("mkdir");
3311#ifdef HAS_MKDIR
6ad3d225 3312 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
a0d0e21e
LW		 3313#else
3314 SETi( dooneliner("mkdir", tmps) );
6ad3d225
GS		 3315 oldumask = PerlLIO_umask(0);
3316 PerlLIO_umask(oldumask);
3317 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
a0d0e21e
LW		 3318#endif
3319 RETURN;
3320}
3321
3322PP(pp_rmdir)
3323{
4e35701f 3324 djSP; dTARGET;
a0d0e21e 3325 char *tmps;
2d8e6c8d 3326 STRLEN n_a;
a0d0e21e 3327
2d8e6c8d 3328 tmps = POPpx;
a0d0e21e
LW		 3329 TAINT_PROPER("rmdir");
3330#ifdef HAS_RMDIR
6ad3d225 3331 XPUSHi( PerlDir_rmdir(tmps) >= 0 );
a0d0e21e
LW		 3332#else
3333 XPUSHi( dooneliner("rmdir", tmps) );
3334#endif
3335 RETURN;
3336}
3337
3338/* Directory calls. */
3339
3340PP(pp_open_dir)
3341{
4e35701f 3342 djSP;
a0d0e21e 3343#if defined(Direntry_t) && defined(HAS_READDIR)
2d8e6c8d
GS		 3344 STRLEN n_a;
3345 char *dirname = POPpx;
a0d0e21e
LW		 3346 GV *gv = (GV*)POPs;
3347 register IO *io = GvIOn(gv);
3348
3349 if (!io)
3350 goto nope;
3351
3352 if (IoDIRP(io))
6ad3d225
GS		 3353 PerlDir_close(IoDIRP(io));
3354 if (!(IoDIRP(io) = PerlDir_open(dirname)))
a0d0e21e
LW		 3355 goto nope;
3356
3357 RETPUSHYES;
3358nope:
3359 if (!errno)
748a9306 3360 SETERRNO(EBADF,RMS$_DIR);
a0d0e21e
LW		 3361 RETPUSHUNDEF;
3362#else
cea2e8a9 3363 DIE(aTHX_ PL_no_dir_func, "opendir");
a0d0e21e
LW		 3364#endif
3365}
3366
3367PP(pp_readdir)
3368{
4e35701f 3369 djSP;
a0d0e21e
LW		 3370#if defined(Direntry_t) && defined(HAS_READDIR)
3371#ifndef I_DIRENT
20ce7b12 3372 Direntry_t *readdir (DIR *);
a0d0e21e
LW		 3373#endif
3374 register Direntry_t *dp;
3375 GV *gv = (GV*)POPs;
3376 register IO *io = GvIOn(gv);
fb73857a 3377 SV *sv;
a0d0e21e
LW		 3378
3379 if (!io || !IoDIRP(io))
3380 goto nope;
3381
3382 if (GIMME == G_ARRAY) {
3383 /*SUPPRESS 560*/
6ad3d225 3384 while (dp = (Direntry_t *)PerlDir_read(IoDIRP(io))) {
a0d0e21e 3385#ifdef DIRNAMLEN
79cb57f6 3386 sv = newSVpvn(dp->d_name, dp->d_namlen);
a0d0e21e 3387#else
fb73857a 3388 sv = newSVpv(dp->d_name, 0);
3389#endif
3390#ifndef INCOMPLETE_TAINTS
3391 SvTAINTED_on(sv);
a0d0e21e 3392#endif
fb73857a 3393 XPUSHs(sv_2mortal(sv));
a0d0e21e
LW		 3394 }
3395 }
3396 else {
6ad3d225 3397 if (!(dp = (Direntry_t *)PerlDir_read(IoDIRP(io))))
a0d0e21e
LW		 3398 goto nope;
3399#ifdef DIRNAMLEN
79cb57f6 3400 sv = newSVpvn(dp->d_name, dp->d_namlen);
a0d0e21e 3401#else
fb73857a 3402 sv = newSVpv(dp->d_name, 0);
a0d0e21e 3403#endif
fb73857a 3404#ifndef INCOMPLETE_TAINTS
3405 SvTAINTED_on(sv);
3406#endif
3407 XPUSHs(sv_2mortal(sv));
a0d0e21e
LW		 3408 }
3409 RETURN;
3410
3411nope:
3412 if (!errno)
748a9306 3413 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 3414 if (GIMME == G_ARRAY)
3415 RETURN;
3416 else
3417 RETPUSHUNDEF;
3418#else
cea2e8a9 3419 DIE(aTHX_ PL_no_dir_func, "readdir");
a0d0e21e
LW		 3420#endif
3421}
3422
3423PP(pp_telldir)
3424{
4e35701f 3425 djSP; dTARGET;
a0d0e21e 3426#if defined(HAS_TELLDIR) || defined(telldir)
968dcd91
JH		 3427 /* XXX does _anyone_ need this? --AD 2/20/1998 */
3428 /* XXX netbsd still seemed to.
3429 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3430 --JHI 1999-Feb-02 */
3431# if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
20ce7b12 3432 long telldir (DIR *);
dfe9444c 3433# endif
a0d0e21e
LW		 3434 GV *gv = (GV*)POPs;
3435 register IO *io = GvIOn(gv);
3436
3437 if (!io || !IoDIRP(io))
3438 goto nope;
3439
6ad3d225 3440 PUSHi( PerlDir_tell(IoDIRP(io)) );
a0d0e21e
LW		 3441 RETURN;
3442nope:
3443 if (!errno)
748a9306 3444 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 3445 RETPUSHUNDEF;
3446#else
cea2e8a9 3447 DIE(aTHX_ PL_no_dir_func, "telldir");
a0d0e21e
LW		 3448#endif
3449}
3450
3451PP(pp_seekdir)
3452{
4e35701f 3453 djSP;
a0d0e21e
LW		 3454#if defined(HAS_SEEKDIR) || defined(seekdir)
3455 long along = POPl;
3456 GV *gv = (GV*)POPs;
3457 register IO *io = GvIOn(gv);
3458
3459 if (!io || !IoDIRP(io))
3460 goto nope;
3461
6ad3d225 3462 (void)PerlDir_seek(IoDIRP(io), along);
a0d0e21e
LW		 3463
3464 RETPUSHYES;
3465nope:
3466 if (!errno)
748a9306 3467 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 3468 RETPUSHUNDEF;
3469#else
cea2e8a9 3470 DIE(aTHX_ PL_no_dir_func, "seekdir");
a0d0e21e
LW		 3471#endif
3472}
3473
3474PP(pp_rewinddir)
3475{
4e35701f 3476 djSP;
a0d0e21e
LW		 3477#if defined(HAS_REWINDDIR) || defined(rewinddir)
3478 GV *gv = (GV*)POPs;
3479 register IO *io = GvIOn(gv);
3480
3481 if (!io || !IoDIRP(io))
3482 goto nope;
3483
6ad3d225 3484 (void)PerlDir_rewind(IoDIRP(io));
a0d0e21e
LW		 3485 RETPUSHYES;
3486nope:
3487 if (!errno)
748a9306 3488 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 3489 RETPUSHUNDEF;
3490#else
cea2e8a9 3491 DIE(aTHX_ PL_no_dir_func, "rewinddir");
a0d0e21e
LW		 3492#endif
3493}
3494
3495PP(pp_closedir)
3496{
4e35701f 3497 djSP;
a0d0e21e
LW		 3498#if defined(Direntry_t) && defined(HAS_READDIR)
3499 GV *gv = (GV*)POPs;
3500 register IO *io = GvIOn(gv);
3501
3502 if (!io || !IoDIRP(io))
3503 goto nope;
3504
3505#ifdef VOID_CLOSEDIR
6ad3d225 3506 PerlDir_close(IoDIRP(io));
a0d0e21e 3507#else
6ad3d225 3508 if (PerlDir_close(IoDIRP(io)) < 0) {
748a9306 3509 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
a0d0e21e 3510 goto nope;
748a9306 3511 }
a0d0e21e
LW		 3512#endif
3513 IoDIRP(io) = 0;
3514
3515 RETPUSHYES;
3516nope:
3517 if (!errno)
748a9306 3518 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW		 3519 RETPUSHUNDEF;
3520#else
cea2e8a9 3521 DIE(aTHX_ PL_no_dir_func, "closedir");
a0d0e21e
LW		 3522#endif
3523}
3524
3525/* Process control. */
3526
3527PP(pp_fork)
3528{
44a8e56a 3529#ifdef HAS_FORK
4e35701f 3530 djSP; dTARGET;
761237fe 3531 Pid_t childpid;
a0d0e21e
LW		 3532 GV *tmpgv;
3533
3534 EXTEND(SP, 1);
45bc9206 3535 PERL_FLUSHALL_FOR_CHILD;
a0d0e21e
LW		 3536 childpid = fork();
3537 if (childpid < 0)
3538 RETSETUNDEF;
3539 if (!childpid) {
3540 /*SUPPRESS 560*/
3541 if (tmpgv = gv_fetchpv("$", TRUE, SVt_PV))
1e422769 3542 sv_setiv(GvSV(tmpgv), (IV)getpid());
3280af22 3543 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
a0d0e21e
LW		 3544 }
3545 PUSHi(childpid);
3546 RETURN;
3547#else
cea2e8a9 3548 DIE(aTHX_ PL_no_func, "Unsupported function fork");
a0d0e21e
LW		 3549#endif
3550}
3551
3552PP(pp_wait)
3553{
2c2d71f5 3554#if !defined(DOSISH) || defined(OS2) || defined(WIN32)
4e35701f 3555 djSP; dTARGET;
761237fe 3556 Pid_t childpid;
a0d0e21e 3557 int argflags;
a0d0e21e 3558
44a8e56a 3559 childpid = wait4pid(-1, &argflags, 0);
f86702cc 3560 STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
44a8e56a 3561 XPUSHi(childpid);
a0d0e21e
LW		 3562 RETURN;
3563#else
cea2e8a9 3564 DIE(aTHX_ PL_no_func, "Unsupported function wait");
a0d0e21e
LW		 3565#endif
3566}
3567
3568PP(pp_waitpid)
3569{
2c2d71f5 3570#if !defined(DOSISH) || defined(OS2) || defined(WIN32)
4e35701f 3571 djSP; dTARGET;
761237fe 3572 Pid_t childpid;
a0d0e21e
LW		 3573 int optype;
3574 int argflags;
a0d0e21e 3575
a0d0e21e
LW		 3576 optype = POPi;
3577 childpid = TOPi;
3578 childpid = wait4pid(childpid, &argflags, optype);
f86702cc 3579 STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
44a8e56a 3580 SETi(childpid);
a0d0e21e
LW		 3581 RETURN;
3582#else
cea2e8a9 3583 DIE(aTHX_ PL_no_func, "Unsupported function waitpid");
a0d0e21e
LW		 3584#endif
3585}
3586
3587PP(pp_system)
3588{
4e35701f 3589 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e 3590 I32 value;
761237fe 3591 Pid_t childpid;
a0d0e21e
LW		 3592 int result;
3593 int status;
ff68c719 3594 Sigsave_t ihand,qhand; /* place to save signals during system() */
2d8e6c8d 3595 STRLEN n_a;
d5a9bfb0
IZ		 3596 I32 did_pipes = 0;
3597 int pp[2];
a0d0e21e 3598
a0d0e21e 3599 if (SP - MARK == 1) {
3280af22 3600 if (PL_tainting) {
2d8e6c8d 3601 char *junk = SvPV(TOPs, n_a);
a0d0e21e
LW		 3602 TAINT_ENV();
3603 TAINT_PROPER("system");
3604 }
3605 }
45bc9206 3606 PERL_FLUSHALL_FOR_CHILD;
1e422769 3607#if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2)
d5a9bfb0
IZ		 3608 if (PerlProc_pipe(pp) >= 0)
3609 did_pipes = 1;
a0d0e21e
LW		 3610 while ((childpid = vfork()) == -1) {
3611 if (errno != EAGAIN) {
3612 value = -1;
3613 SP = ORIGMARK;
3614 PUSHi(value);
d5a9bfb0
IZ		 3615 if (did_pipes) {
3616 PerlLIO_close(pp[0]);
3617 PerlLIO_close(pp[1]);
3618 }
a0d0e21e
LW		 3619 RETURN;
3620 }
3621 sleep(5);
3622 }
3623 if (childpid > 0) {
d5a9bfb0
IZ		 3624 if (did_pipes)
3625 PerlLIO_close(pp[1]);
ff68c719 3626 rsignal_save(SIGINT, SIG_IGN, &ihand);
3627 rsignal_save(SIGQUIT, SIG_IGN, &qhand);
748a9306
LW		 3628 do {
3629 result = wait4pid(childpid, &status, 0);
3630 } while (result == -1 && errno == EINTR);
ff68c719 3631 (void)rsignal_restore(SIGINT, &ihand);
3632 (void)rsignal_restore(SIGQUIT, &qhand);
91e9c03f 3633 STATUS_NATIVE_SET(result == -1 ? -1 : status);
a0d0e21e
LW		 3634 do_execfree(); /* free any memory child malloced on vfork */
3635 SP = ORIGMARK;
d5a9bfb0
IZ		 3636 if (did_pipes) {
3637 int errkid;
3638 int n = 0, n1;
3639
3640 while (n < sizeof(int)) {
3641 n1 = PerlLIO_read(pp[0],
3642 (void*)(((char*)&errkid)+n),
3643 (sizeof(int)) - n);
3644 if (n1 <= 0)
3645 break;
3646 n += n1;
3647 }
3648 PerlLIO_close(pp[0]);
3649 if (n) { /* Error */
3650 if (n != sizeof(int))
3651 Perl_croak(aTHX_ "panic: kid popen errno read");
3652 errno = errkid; /* Propagate errno from kid */
3653 STATUS_CURRENT = -1;
3654 }
3655 }
ff0cee69 3656 PUSHi(STATUS_CURRENT);
a0d0e21e
LW		 3657 RETURN;
3658 }
d5a9bfb0
IZ		 3659 if (did_pipes) {
3660 PerlLIO_close(pp[0]);
3661#if defined(HAS_FCNTL) && defined(F_SETFD)
3662 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
3663#endif
3664 }
533c011a 3665 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e 3666 SV *really = *++MARK;
d5a9bfb0 3667 value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
a0d0e21e
LW		 3668 }
3669 else if (SP - MARK != 1)
d5a9bfb0 3670 value = (I32)do_aexec5(Nullsv, MARK, SP, pp[1], did_pipes);
a0d0e21e 3671 else {
d5a9bfb0 3672 value = (I32)do_exec3(SvPVx(sv_mortalcopy(*SP), n_a), pp[1], did_pipes);
a0d0e21e 3673 }
6ad3d225 3674 PerlProc__exit(-1);
c3293030 3675#else /* ! FORK or VMS or OS/2 */
911d147d 3676 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e 3677 SV *really = *++MARK;
c5be433b 3678 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
a0d0e21e
LW		 3679 }
3680 else if (SP - MARK != 1)
c5be433b 3681 value = (I32)do_aspawn(Nullsv, (void **)MARK, (void **)SP);
a0d0e21e 3682 else {
c5be433b 3683 value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
a0d0e21e 3684 }
f86702cc 3685 STATUS_NATIVE_SET(value);
a0d0e21e
LW		 3686 do_execfree();
3687 SP = ORIGMARK;
ff0cee69 3688 PUSHi(STATUS_CURRENT);
a0d0e21e
LW		 3689#endif /* !FORK or VMS */
3690 RETURN;
3691}
3692
3693PP(pp_exec)
3694{
4e35701f 3695 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e 3696 I32 value;
2d8e6c8d 3697 STRLEN n_a;
a0d0e21e 3698
45bc9206 3699 PERL_FLUSHALL_FOR_CHILD;
533c011a 3700 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e
LW		 3701 SV *really = *++MARK;
3702 value = (I32)do_aexec(really, MARK, SP);
3703 }
3704 else if (SP - MARK != 1)
3705#ifdef VMS
3706 value = (I32)vms_do_aexec(Nullsv, MARK, SP);
3707#else
092bebab
JH		 3708# ifdef __OPEN_VM
3709 {
c5be433b 3710 (void ) do_aspawn(Nullsv, MARK, SP);
092bebab
JH		 3711 value = 0;
3712 }
3713# else
a0d0e21e 3714 value = (I32)do_aexec(Nullsv, MARK, SP);
092bebab 3715# endif
a0d0e21e
LW		 3716#endif
3717 else {
3280af22 3718 if (PL_tainting) {
2d8e6c8d 3719 char *junk = SvPV(*SP, n_a);
a0d0e21e
LW		 3720 TAINT_ENV();
3721 TAINT_PROPER("exec");
3722 }
3723#ifdef VMS
2d8e6c8d 3724 value = (I32)vms_do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
a0d0e21e 3725#else
092bebab 3726# ifdef __OPEN_VM
c5be433b 3727 (void) do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
092bebab
JH		 3728 value = 0;
3729# else
2d8e6c8d 3730 value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
092bebab 3731# endif
a0d0e21e
LW		 3732#endif
3733 }
3734 SP = ORIGMARK;
3735 PUSHi(value);
3736 RETURN;
3737}
3738
3739PP(pp_kill)
3740{
4e35701f 3741 djSP; dMARK; dTARGET;
a0d0e21e
LW		 3742 I32 value;
3743#ifdef HAS_KILL
533c011a 3744 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 3745 SP = MARK;
3746 PUSHi(value);
3747 RETURN;
3748#else
cea2e8a9 3749 DIE(aTHX_ PL_no_func, "Unsupported function kill");
a0d0e21e
LW		 3750#endif
3751}
3752
3753PP(pp_getppid)
3754{
3755#ifdef HAS_GETPPID
4e35701f 3756 djSP; dTARGET;
a0d0e21e
LW		 3757 XPUSHi( getppid() );
3758 RETURN;
3759#else
cea2e8a9 3760 DIE(aTHX_ PL_no_func, "getppid");
a0d0e21e
LW		 3761#endif
3762}
3763
3764PP(pp_getpgrp)
3765{
3766#ifdef HAS_GETPGRP
4e35701f 3767 djSP; dTARGET;
d8a83dd3 3768 Pid_t pid;
9853a804 3769 Pid_t pgrp;
a0d0e21e
LW		 3770
3771 if (MAXARG < 1)
3772 pid = 0;
3773 else
3774 pid = SvIVx(POPs);
c3293030 3775#ifdef BSD_GETPGRP
9853a804 3776 pgrp = (I32)BSD_GETPGRP(pid);
a0d0e21e 3777#else
aa689395 3778 if (pid != 0 && pid != getpid())
cea2e8a9 3779 DIE(aTHX_ "POSIX getpgrp can't take an argument");
9853a804 3780 pgrp = getpgrp();
a0d0e21e 3781#endif
9853a804 3782 XPUSHi(pgrp);
a0d0e21e
LW		 3783 RETURN;
3784#else
cea2e8a9 3785 DIE(aTHX_ PL_no_func, "getpgrp()");
a0d0e21e
LW		 3786#endif
3787}
3788
3789PP(pp_setpgrp)
3790{
3791#ifdef HAS_SETPGRP
4e35701f 3792 djSP; dTARGET;
d8a83dd3
JH		 3793 Pid_t pgrp;
3794 Pid_t pid;
a0d0e21e
LW		 3795 if (MAXARG < 2) {
3796 pgrp = 0;
3797 pid = 0;
3798 }
3799 else {
3800 pgrp = POPi;
3801 pid = TOPi;
3802 }
3803
3804 TAINT_PROPER("setpgrp");
c3293030
IZ		 3805#ifdef BSD_SETPGRP
3806 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
a0d0e21e 3807#else
c90c0ff4 3808 if ((pgrp != 0 && pgrp != getpid()) || (pid != 0 && pid != getpid()))
cea2e8a9 3809 DIE(aTHX_ "POSIX setpgrp can't take an argument");
a0d0e21e
LW		 3810 SETi( setpgrp() >= 0 );
3811#endif /* USE_BSDPGRP */
3812 RETURN;
3813#else
cea2e8a9 3814 DIE(aTHX_ PL_no_func, "setpgrp()");
a0d0e21e
LW		 3815#endif
3816}
3817
3818PP(pp_getpriority)
3819{
4e35701f 3820 djSP; dTARGET;
a0d0e21e
LW		 3821 int which;
3822 int who;
3823#ifdef HAS_GETPRIORITY
3824 who = POPi;
3825 which = TOPi;
3826 SETi( getpriority(which, who) );
3827 RETURN;
3828#else
cea2e8a9 3829 DIE(aTHX_ PL_no_func, "getpriority()");
a0d0e21e
LW		 3830#endif
3831}
3832
3833PP(pp_setpriority)
3834{
4e35701f 3835 djSP; dTARGET;
a0d0e21e
LW		 3836 int which;
3837 int who;
3838 int niceval;
3839#ifdef HAS_SETPRIORITY
3840 niceval = POPi;
3841 who = POPi;
3842 which = TOPi;
3843 TAINT_PROPER("setpriority");
3844 SETi( setpriority(which, who, niceval) >= 0 );
3845 RETURN;
3846#else
cea2e8a9 3847 DIE(aTHX_ PL_no_func, "setpriority()");
a0d0e21e
LW		 3848#endif
3849}
3850
3851/* Time calls. */
3852
3853PP(pp_time)
3854{
4e35701f 3855 djSP; dTARGET;
cbdc8872 3856#ifdef BIG_TIME
3857 XPUSHn( time(Null(Time_t*)) );
3858#else
a0d0e21e 3859 XPUSHi( time(Null(Time_t*)) );
cbdc8872 3860#endif
a0d0e21e
LW		 3861 RETURN;
3862}
3863
cd52b7b2 3864/* XXX The POSIX name is CLK_TCK; it is to be preferred
3865 to HZ. Probably. For now, assume that if the system
3866 defines HZ, it does so correctly. (Will this break
3867 on VMS?)
3868 Probably we ought to use _sysconf(_SC_CLK_TCK), if
3869 it's supported. --AD 9/96.
3870*/
3871
a0d0e21e 3872#ifndef HZ
cd52b7b2 3873# ifdef CLK_TCK
3874# define HZ CLK_TCK
3875# else
3876# define HZ 60
3877# endif
a0d0e21e
LW		 3878#endif
3879
3880PP(pp_tms)
3881{
4e35701f 3882 djSP;
a0d0e21e 3883
55497cff 3884#ifndef HAS_TIMES
cea2e8a9 3885 DIE(aTHX_ "times not implemented");
a0d0e21e
LW		 3886#else
3887 EXTEND(SP, 4);
3888
3889#ifndef VMS
3280af22 3890 (void)PerlProc_times(&PL_timesbuf);
a0d0e21e 3891#else
6b88bc9c 3892 (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */
76e3520e
GS		 3893 /* struct tms, though same data */
3894 /* is returned. */
a0d0e21e
LW		 3895#endif
3896
65202027 3897 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_utime)/HZ)));
a0d0e21e 3898 if (GIMME == G_ARRAY) {
65202027
DS		 3899 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_stime)/HZ)));
3900 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cutime)/HZ)));
3901 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cstime)/HZ)));
a0d0e21e
LW		 3902 }
3903 RETURN;
55497cff 3904#endif /* HAS_TIMES */
a0d0e21e
LW		 3905}
3906
3907PP(pp_localtime)
3908{
cea2e8a9 3909 return pp_gmtime();
a0d0e21e
LW		 3910}
3911
3912PP(pp_gmtime)
3913{
4e35701f 3914 djSP;
a0d0e21e
LW		 3915 Time_t when;
3916 struct tm *tmbuf;
3917 static char *dayname[] = {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
3918 static char *monname[] = {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
3919 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
3920
3921 if (MAXARG < 1)
3922 (void)time(&when);
3923 else
cbdc8872 3924#ifdef BIG_TIME
3925 when = (Time_t)SvNVx(POPs);
3926#else
a0d0e21e 3927 when = (Time_t)SvIVx(POPs);
cbdc8872 3928#endif
a0d0e21e 3929
533c011a 3930 if (PL_op->op_type == OP_LOCALTIME)
a0d0e21e
LW		 3931 tmbuf = localtime(&when);
3932 else
3933 tmbuf = gmtime(&when);
3934
3935 EXTEND(SP, 9);
bbce6d69 3936 EXTEND_MORTAL(9);
a0d0e21e
LW		 3937 if (GIMME != G_ARRAY) {
3938 dTARGET;
46fc3d4c 3939 SV *tsv;
a0d0e21e
LW		 3940 if (!tmbuf)
3941 RETPUSHUNDEF;
cea2e8a9 3942 tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %d",
f5a29b03
RB		 3943 dayname[tmbuf->tm_wday],
3944 monname[tmbuf->tm_mon],
3945 (IV)tmbuf->tm_mday,
3946 (IV)tmbuf->tm_hour,
3947 (IV)tmbuf->tm_min,
3948 (IV)tmbuf->tm_sec,
3949 (IV)tmbuf->tm_year + 1900);
46fc3d4c 3950 PUSHs(sv_2mortal(tsv));
a0d0e21e
LW		 3951 }
3952 else if (tmbuf) {
c6419e06
JH		 3953 PUSHs(sv_2mortal(newSViv(tmbuf->tm_sec)));
3954 PUSHs(sv_2mortal(newSViv(tmbuf->tm_min)));
3955 PUSHs(sv_2mortal(newSViv(tmbuf->tm_hour)));
3956 PUSHs(sv_2mortal(newSViv(tmbuf->tm_mday)));
3957 PUSHs(sv_2mortal(newSViv(tmbuf->tm_mon)));
3958 PUSHs(sv_2mortal(newSViv(tmbuf->tm_year)));
3959 PUSHs(sv_2mortal(newSViv(tmbuf->tm_wday)));
3960 PUSHs(sv_2mortal(newSViv(tmbuf->tm_yday)));
3961 PUSHs(sv_2mortal(newSViv(tmbuf->tm_isdst)));
a0d0e21e
LW		 3962 }
3963 RETURN;
3964}
3965
3966PP(pp_alarm)
3967{
4e35701f 3968 djSP; dTARGET;
a0d0e21e
LW		 3969 int anum;
3970#ifdef HAS_ALARM
3971 anum = POPi;
3972 anum = alarm((unsigned int)anum);
3973 EXTEND(SP, 1);
3974 if (anum < 0)
3975 RETPUSHUNDEF;
c6419e06 3976 PUSHi(anum);
a0d0e21e
LW		 3977 RETURN;
3978#else
cea2e8a9 3979 DIE(aTHX_ PL_no_func, "Unsupported function alarm");
a0d0e21e
LW		 3980#endif
3981}
3982
3983PP(pp_sleep)
3984{
4e35701f 3985 djSP; dTARGET;
a0d0e21e
LW		 3986 I32 duration;
3987 Time_t lasttime;
3988 Time_t when;
3989
3990 (void)time(&lasttime);
3991 if (MAXARG < 1)
76e3520e 3992 PerlProc_pause();
a0d0e21e
LW		 3993 else {
3994 duration = POPi;
76e3520e 3995 PerlProc_sleep((unsigned int)duration);
a0d0e21e
LW		 3996 }
3997 (void)time(&when);
3998 XPUSHi(when - lasttime);
3999 RETURN;
4000}
4001
4002/* Shared memory. */
4003
4004PP(pp_shmget)
4005{
cea2e8a9 4006 return pp_semget();
a0d0e21e
LW		 4007}
4008
4009PP(pp_shmctl)
4010{
cea2e8a9 4011 return pp_semctl();
a0d0e21e
LW		 4012}
4013
4014PP(pp_shmread)
4015{
cea2e8a9 4016 return pp_shmwrite();
a0d0e21e
LW		 4017}
4018
4019PP(pp_shmwrite)
4020{
4021#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 4022 djSP; dMARK; dTARGET;
533c011a 4023 I32 value = (I32)(do_shmio(PL_op->op_type, MARK, SP) >= 0);
a0d0e21e
LW		 4024 SP = MARK;
4025 PUSHi(value);
4026 RETURN;
4027#else
cea2e8a9 4028 return pp_semget();
a0d0e21e
LW		 4029#endif
4030}
4031
4032/* Message passing. */
4033
4034PP(pp_msgget)
4035{
cea2e8a9 4036 return pp_semget();
a0d0e21e
LW		 4037}
4038
4039PP(pp_msgctl)
4040{
cea2e8a9 4041 return pp_semctl();
a0d0e21e
LW		 4042}
4043
4044PP(pp_msgsnd)
4045{
4046#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 4047 djSP; dMARK; dTARGET;
a0d0e21e
LW		 4048 I32 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4049 SP = MARK;
4050 PUSHi(value);
4051 RETURN;
4052#else
cea2e8a9 4053 return pp_semget();
a0d0e21e
LW		 4054#endif
4055}
4056
4057PP(pp_msgrcv)
4058{
4059#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 4060 djSP; dMARK; dTARGET;
a0d0e21e
LW		 4061 I32 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4062 SP = MARK;
4063 PUSHi(value);
4064 RETURN;
4065#else
cea2e8a9 4066 return pp_semget();
a0d0e21e
LW		 4067#endif
4068}
4069
4070/* Semaphores. */
4071
4072PP(pp_semget)
4073{
4074#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 4075 djSP; dMARK; dTARGET;
533c011a 4076 int anum = do_ipcget(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 4077 SP = MARK;
4078 if (anum == -1)
4079 RETPUSHUNDEF;
4080 PUSHi(anum);
4081 RETURN;
4082#else
cea2e8a9 4083 DIE(aTHX_ "System V IPC is not implemented on this machine");
a0d0e21e
LW		 4084#endif
4085}
4086
4087PP(pp_semctl)
4088{
4089#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 4090 djSP; dMARK; dTARGET;
533c011a 4091 int anum = do_ipcctl(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 4092 SP = MARK;
4093 if (anum == -1)
4094 RETSETUNDEF;
4095 if (anum != 0) {
4096 PUSHi(anum);
4097 }
4098 else {
8903cb82 4099 PUSHp(zero_but_true, ZBTLEN);
a0d0e21e
LW		 4100 }
4101 RETURN;
4102#else
cea2e8a9 4103 return pp_semget();
a0d0e21e
LW		 4104#endif
4105}
4106
4107PP(pp_semop)
4108{
4109#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 4110 djSP; dMARK; dTARGET;
a0d0e21e
LW		 4111 I32 value = (I32)(do_semop(MARK, SP) >= 0);
4112 SP = MARK;
4113 PUSHi(value);
4114 RETURN;
4115#else
cea2e8a9 4116 return pp_semget();
a0d0e21e
LW		 4117#endif
4118}
4119
4120/* Get system info. */
4121
4122PP(pp_ghbyname)
4123{
693762b4 4124#ifdef HAS_GETHOSTBYNAME
cea2e8a9 4125 return pp_ghostent();
a0d0e21e 4126#else
cea2e8a9 4127 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
a0d0e21e
LW		 4128#endif
4129}
4130
4131PP(pp_ghbyaddr)
4132{
693762b4 4133#ifdef HAS_GETHOSTBYADDR
cea2e8a9 4134 return pp_ghostent();
a0d0e21e 4135#else
cea2e8a9 4136 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
a0d0e21e
LW		 4137#endif
4138}
4139
4140PP(pp_ghostent)
4141{
4e35701f 4142 djSP;
693762b4 4143#if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
533c011a 4144 I32 which = PL_op->op_type;
a0d0e21e
LW		 4145 register char **elem;
4146 register SV *sv;
dc45a647 4147#ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4599a1de
JH		 4148 struct hostent *PerlSock_gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4149 struct hostent *PerlSock_gethostbyname(Netdb_name_t);
6ad3d225 4150 struct hostent *PerlSock_gethostent(void);
a0d0e21e
LW		 4151#endif
4152 struct hostent *hent;
4153 unsigned long len;
2d8e6c8d 4154 STRLEN n_a;
a0d0e21e
LW		 4155
4156 EXTEND(SP, 10);
dc45a647
MB		 4157 if (which == OP_GHBYNAME)
4158#ifdef HAS_GETHOSTBYNAME
2d8e6c8d 4159 hent = PerlSock_gethostbyname(POPpx);
dc45a647 4160#else
cea2e8a9 4161 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
dc45a647 4162#endif
a0d0e21e 4163 else if (which == OP_GHBYADDR) {
dc45a647 4164#ifdef HAS_GETHOSTBYADDR
a0d0e21e 4165 int addrtype = POPi;
748a9306 4166 SV *addrsv = POPs;
a0d0e21e 4167 STRLEN addrlen;
4599a1de 4168 Netdb_host_t addr = (Netdb_host_t) SvPV(addrsv, addrlen);
a0d0e21e 4169
4599a1de 4170 hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
dc45a647 4171#else
cea2e8a9 4172 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
dc45a647 4173#endif
a0d0e21e
LW		 4174 }
4175 else
4176#ifdef HAS_GETHOSTENT
6ad3d225 4177 hent = PerlSock_gethostent();
a0d0e21e 4178#else
cea2e8a9 4179 DIE(aTHX_ PL_no_sock_func, "gethostent");
a0d0e21e
LW		 4180#endif
4181
4182#ifdef HOST_NOT_FOUND
4183 if (!hent)
f86702cc 4184 STATUS_NATIVE_SET(h_errno);
a0d0e21e
LW		 4185#endif
4186
4187 if (GIMME != G_ARRAY) {
4188 PUSHs(sv = sv_newmortal());
4189 if (hent) {
4190 if (which == OP_GHBYNAME) {
fd0af264 4191 if (hent->h_addr)
4192 sv_setpvn(sv, hent->h_addr, hent->h_length);
a0d0e21e
LW		 4193 }
4194 else
4195 sv_setpv(sv, (char*)hent->h_name);
4196 }
4197 RETURN;
4198 }
4199
4200 if (hent) {
3280af22 4201 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4202 sv_setpv(sv, (char*)hent->h_name);
3280af22 4203 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 4204 for (elem = hent->h_aliases; elem && *elem; elem++) {
4205 sv_catpv(sv, *elem);
4206 if (elem[1])
4207 sv_catpvn(sv, " ", 1);
4208 }
3280af22 4209 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4210 sv_setiv(sv, (IV)hent->h_addrtype);
3280af22 4211 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4212 len = hent->h_length;
1e422769 4213 sv_setiv(sv, (IV)len);
a0d0e21e
LW		 4214#ifdef h_addr
4215 for (elem = hent->h_addr_list; elem && *elem; elem++) {
3280af22 4216 XPUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 4217 sv_setpvn(sv, *elem, len);
4218 }
4219#else
6b88bc9c 4220 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
fd0af264 4221 if (hent->h_addr)
4222 sv_setpvn(sv, hent->h_addr, len);
a0d0e21e
LW		 4223#endif /* h_addr */
4224 }
4225 RETURN;
4226#else
cea2e8a9 4227 DIE(aTHX_ PL_no_sock_func, "gethostent");
a0d0e21e
LW		 4228#endif
4229}
4230
4231PP(pp_gnbyname)
4232{
693762b4 4233#ifdef HAS_GETNETBYNAME
cea2e8a9 4234 return pp_gnetent();
a0d0e21e 4235#else
cea2e8a9 4236 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
a0d0e21e
LW		 4237#endif
4238}
4239
4240PP(pp_gnbyaddr)
4241{
693762b4 4242#ifdef HAS_GETNETBYADDR
cea2e8a9 4243 return pp_gnetent();
a0d0e21e 4244#else
cea2e8a9 4245 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
a0d0e21e
LW		 4246#endif
4247}
4248
4249PP(pp_gnetent)
4250{
4e35701f 4251 djSP;
693762b4 4252#if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
533c011a 4253 I32 which = PL_op->op_type;
a0d0e21e
LW		 4254 register char **elem;
4255 register SV *sv;
dc45a647
MB		 4256#ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4257 struct netent *PerlSock_getnetbyaddr(Netdb_net_t, int);
4258 struct netent *PerlSock_getnetbyname(Netdb_name_t);
4259 struct netent *PerlSock_getnetent(void);
8ac85365 4260#endif
a0d0e21e 4261 struct netent *nent;
2d8e6c8d 4262 STRLEN n_a;
a0d0e21e
LW		 4263
4264 if (which == OP_GNBYNAME)
dc45a647 4265#ifdef HAS_GETNETBYNAME
2d8e6c8d 4266 nent = PerlSock_getnetbyname(POPpx);
dc45a647 4267#else
cea2e8a9 4268 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
dc45a647 4269#endif
a0d0e21e 4270 else if (which == OP_GNBYADDR) {
dc45a647 4271#ifdef HAS_GETNETBYADDR
a0d0e21e 4272 int addrtype = POPi;
4599a1de 4273 Netdb_net_t addr = (Netdb_net_t) U_L(POPn);
76e3520e 4274 nent = PerlSock_getnetbyaddr(addr, addrtype);
dc45a647 4275#else
cea2e8a9 4276 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
dc45a647 4277#endif
a0d0e21e
LW		 4278 }
4279 else
dc45a647 4280#ifdef HAS_GETNETENT
76e3520e 4281 nent = PerlSock_getnetent();
dc45a647 4282#else
cea2e8a9 4283 DIE(aTHX_ PL_no_sock_func, "getnetent");
dc45a647 4284#endif
a0d0e21e
LW		 4285
4286 EXTEND(SP, 4);
4287 if (GIMME != G_ARRAY) {
4288 PUSHs(sv = sv_newmortal());
4289 if (nent) {
4290 if (which == OP_GNBYNAME)
1e422769 4291 sv_setiv(sv, (IV)nent->n_net);
a0d0e21e
LW		 4292 else
4293 sv_setpv(sv, nent->n_name);
4294 }
4295 RETURN;
4296 }
4297
4298 if (nent) {
3280af22 4299 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4300 sv_setpv(sv, nent->n_name);
3280af22 4301 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 4302 for (elem = nent->n_aliases; elem && *elem; elem++) {
a0d0e21e
LW		 4303 sv_catpv(sv, *elem);
4304 if (elem[1])
4305 sv_catpvn(sv, " ", 1);
4306 }
3280af22 4307 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4308 sv_setiv(sv, (IV)nent->n_addrtype);
3280af22 4309 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4310 sv_setiv(sv, (IV)nent->n_net);
a0d0e21e
LW		 4311 }
4312
4313 RETURN;
4314#else
cea2e8a9 4315 DIE(aTHX_ PL_no_sock_func, "getnetent");
a0d0e21e
LW		 4316#endif
4317}
4318
4319PP(pp_gpbyname)
4320{
693762b4 4321#ifdef HAS_GETPROTOBYNAME
cea2e8a9 4322 return pp_gprotoent();
a0d0e21e 4323#else
cea2e8a9 4324 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
a0d0e21e
LW		 4325#endif
4326}
4327
4328PP(pp_gpbynumber)
4329{
693762b4 4330#ifdef HAS_GETPROTOBYNUMBER
cea2e8a9 4331 return pp_gprotoent();
a0d0e21e 4332#else
cea2e8a9 4333 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
a0d0e21e
LW		 4334#endif
4335}
4336
4337PP(pp_gprotoent)
4338{
4e35701f 4339 djSP;
693762b4 4340#if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
533c011a 4341 I32 which = PL_op->op_type;
a0d0e21e 4342 register char **elem;
8ac85365 4343 register SV *sv;
dc45a647 4344#ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4599a1de 4345 struct protoent *PerlSock_getprotobyname(Netdb_name_t);
6ad3d225
GS		 4346 struct protoent *PerlSock_getprotobynumber(int);
4347 struct protoent *PerlSock_getprotoent(void);
8ac85365 4348#endif
a0d0e21e 4349 struct protoent *pent;
2d8e6c8d 4350 STRLEN n_a;
a0d0e21e
LW		 4351
4352 if (which == OP_GPBYNAME)
e5c9fcd0 4353#ifdef HAS_GETPROTOBYNAME
2d8e6c8d 4354 pent = PerlSock_getprotobyname(POPpx);
e5c9fcd0 4355#else
cea2e8a9 4356 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
e5c9fcd0 4357#endif
a0d0e21e 4358 else if (which == OP_GPBYNUMBER)
e5c9fcd0 4359#ifdef HAS_GETPROTOBYNUMBER
6ad3d225 4360 pent = PerlSock_getprotobynumber(POPi);
e5c9fcd0 4361#else
cea2e8a9 4362 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
e5c9fcd0 4363#endif
a0d0e21e 4364 else
e5c9fcd0 4365#ifdef HAS_GETPROTOENT
6ad3d225 4366 pent = PerlSock_getprotoent();
e5c9fcd0 4367#else
cea2e8a9 4368 DIE(aTHX_ PL_no_sock_func, "getprotoent");
e5c9fcd0 4369#endif
a0d0e21e
LW		 4370
4371 EXTEND(SP, 3);
4372 if (GIMME != G_ARRAY) {
4373 PUSHs(sv = sv_newmortal());
4374 if (pent) {
4375 if (which == OP_GPBYNAME)
1e422769 4376 sv_setiv(sv, (IV)pent->p_proto);
a0d0e21e
LW		 4377 else
4378 sv_setpv(sv, pent->p_name);
4379 }
4380 RETURN;
4381 }
4382
4383 if (pent) {
3280af22 4384 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4385 sv_setpv(sv, pent->p_name);
3280af22 4386 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 4387 for (elem = pent->p_aliases; elem && *elem; elem++) {
a0d0e21e
LW		 4388 sv_catpv(sv, *elem);
4389 if (elem[1])
4390 sv_catpvn(sv, " ", 1);
4391 }
3280af22 4392 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4393 sv_setiv(sv, (IV)pent->p_proto);
a0d0e21e
LW		 4394 }
4395
4396 RETURN;
4397#else
cea2e8a9 4398 DIE(aTHX_ PL_no_sock_func, "getprotoent");
a0d0e21e
LW		 4399#endif
4400}
4401
4402PP(pp_gsbyname)
4403{
9ec75305 4404#ifdef HAS_GETSERVBYNAME
cea2e8a9 4405 return pp_gservent();
a0d0e21e 4406#else
cea2e8a9 4407 DIE(aTHX_ PL_no_sock_func, "getservbyname");
a0d0e21e
LW		 4408#endif
4409}
4410
4411PP(pp_gsbyport)
4412{
9ec75305 4413#ifdef HAS_GETSERVBYPORT
cea2e8a9 4414 return pp_gservent();
a0d0e21e 4415#else
cea2e8a9 4416 DIE(aTHX_ PL_no_sock_func, "getservbyport");
a0d0e21e
LW		 4417#endif
4418}
4419
4420PP(pp_gservent)
4421{
4e35701f 4422 djSP;
693762b4 4423#if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
533c011a 4424 I32 which = PL_op->op_type;
a0d0e21e
LW		 4425 register char **elem;
4426 register SV *sv;
dc45a647 4427#ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4599a1de
JH		 4428 struct servent *PerlSock_getservbyname(Netdb_name_t, Netdb_name_t);
4429 struct servent *PerlSock_getservbyport(int, Netdb_name_t);
6ad3d225 4430 struct servent *PerlSock_getservent(void);
8ac85365 4431#endif
a0d0e21e 4432 struct servent *sent;
2d8e6c8d 4433 STRLEN n_a;
a0d0e21e
LW		 4434
4435 if (which == OP_GSBYNAME) {
dc45a647 4436#ifdef HAS_GETSERVBYNAME
2d8e6c8d
GS		 4437 char *proto = POPpx;
4438 char *name = POPpx;
a0d0e21e
LW		 4439
4440 if (proto && !*proto)
4441 proto = Nullch;
4442
6ad3d225 4443 sent = PerlSock_getservbyname(name, proto);
dc45a647 4444#else
cea2e8a9 4445 DIE(aTHX_ PL_no_sock_func, "getservbyname");
dc45a647 4446#endif
a0d0e21e
LW		 4447 }
4448 else if (which == OP_GSBYPORT) {
dc45a647 4449#ifdef HAS_GETSERVBYPORT
2d8e6c8d 4450 char *proto = POPpx;
36477c24 4451 unsigned short port = POPu;
a0d0e21e 4452
36477c24 4453#ifdef HAS_HTONS
6ad3d225 4454 port = PerlSock_htons(port);
36477c24 4455#endif
6ad3d225 4456 sent = PerlSock_getservbyport(port, proto);
dc45a647 4457#else
cea2e8a9 4458 DIE(aTHX_ PL_no_sock_func, "getservbyport");
dc45a647 4459#endif
a0d0e21e
LW		 4460 }
4461 else
e5c9fcd0 4462#ifdef HAS_GETSERVENT
6ad3d225 4463 sent = PerlSock_getservent();
e5c9fcd0 4464#else
cea2e8a9 4465 DIE(aTHX_ PL_no_sock_func, "getservent");
e5c9fcd0 4466#endif
a0d0e21e
LW		 4467
4468 EXTEND(SP, 4);
4469 if (GIMME != G_ARRAY) {
4470 PUSHs(sv = sv_newmortal());
4471 if (sent) {
4472 if (which == OP_GSBYNAME) {
4473#ifdef HAS_NTOHS
6ad3d225 4474 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
a0d0e21e 4475#else
1e422769 4476 sv_setiv(sv, (IV)(sent->s_port));
a0d0e21e
LW		 4477#endif
4478 }
4479 else
4480 sv_setpv(sv, sent->s_name);
4481 }
4482 RETURN;
4483 }
4484
4485 if (sent) {
3280af22 4486 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4487 sv_setpv(sv, sent->s_name);
3280af22 4488 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 4489 for (elem = sent->s_aliases; elem && *elem; elem++) {
a0d0e21e
LW		 4490 sv_catpv(sv, *elem);
4491 if (elem[1])
4492 sv_catpvn(sv, " ", 1);
4493 }
3280af22 4494 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4495#ifdef HAS_NTOHS
76e3520e 4496 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
a0d0e21e 4497#else
1e422769 4498 sv_setiv(sv, (IV)(sent->s_port));
a0d0e21e 4499#endif
3280af22 4500 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 4501 sv_setpv(sv, sent->s_proto);
4502 }
4503
4504 RETURN;
4505#else
cea2e8a9 4506 DIE(aTHX_ PL_no_sock_func, "getservent");
a0d0e21e
LW		 4507#endif
4508}
4509
4510PP(pp_shostent)
4511{
4e35701f 4512 djSP;
693762b4 4513#ifdef HAS_SETHOSTENT
76e3520e 4514 PerlSock_sethostent(TOPi);
a0d0e21e
LW		 4515 RETSETYES;
4516#else
cea2e8a9 4517 DIE(aTHX_ PL_no_sock_func, "sethostent");
a0d0e21e
LW		 4518#endif
4519}
4520
4521PP(pp_snetent)
4522{
4e35701f 4523 djSP;
693762b4 4524#ifdef HAS_SETNETENT
76e3520e 4525 PerlSock_setnetent(TOPi);
a0d0e21e
LW		 4526 RETSETYES;
4527#else
cea2e8a9 4528 DIE(aTHX_ PL_no_sock_func, "setnetent");
a0d0e21e
LW		 4529#endif
4530}
4531
4532PP(pp_sprotoent)
4533{
4e35701f 4534 djSP;
693762b4 4535#ifdef HAS_SETPROTOENT
76e3520e 4536 PerlSock_setprotoent(TOPi);
a0d0e21e
LW		 4537 RETSETYES;
4538#else
cea2e8a9 4539 DIE(aTHX_ PL_no_sock_func, "setprotoent");
a0d0e21e
LW		 4540#endif
4541}
4542
4543PP(pp_sservent)
4544{
4e35701f 4545 djSP;
693762b4 4546#ifdef HAS_SETSERVENT
76e3520e 4547 PerlSock_setservent(TOPi);
a0d0e21e
LW		 4548 RETSETYES;
4549#else
cea2e8a9 4550 DIE(aTHX_ PL_no_sock_func, "setservent");
a0d0e21e
LW		 4551#endif
4552}
4553
4554PP(pp_ehostent)
4555{
4e35701f 4556 djSP;
693762b4 4557#ifdef HAS_ENDHOSTENT
76e3520e 4558 PerlSock_endhostent();
924508f0 4559 EXTEND(SP,1);
a0d0e21e
LW		 4560 RETPUSHYES;
4561#else
cea2e8a9 4562 DIE(aTHX_ PL_no_sock_func, "endhostent");
a0d0e21e
LW		 4563#endif
4564}
4565
4566PP(pp_enetent)
4567{
4e35701f 4568 djSP;
693762b4 4569#ifdef HAS_ENDNETENT
76e3520e 4570 PerlSock_endnetent();
924508f0 4571 EXTEND(SP,1);
a0d0e21e
LW		 4572 RETPUSHYES;
4573#else
cea2e8a9 4574 DIE(aTHX_ PL_no_sock_func, "endnetent");
a0d0e21e
LW		 4575#endif
4576}
4577
4578PP(pp_eprotoent)
4579{
4e35701f 4580 djSP;
693762b4 4581#ifdef HAS_ENDPROTOENT
76e3520e 4582 PerlSock_endprotoent();
924508f0 4583 EXTEND(SP,1);
a0d0e21e
LW		 4584 RETPUSHYES;
4585#else
cea2e8a9 4586 DIE(aTHX_ PL_no_sock_func, "endprotoent");
a0d0e21e
LW		 4587#endif
4588}
4589
4590PP(pp_eservent)
4591{
4e35701f 4592 djSP;
693762b4 4593#ifdef HAS_ENDSERVENT
76e3520e 4594 PerlSock_endservent();
924508f0 4595 EXTEND(SP,1);
a0d0e21e
LW		 4596 RETPUSHYES;
4597#else
cea2e8a9 4598 DIE(aTHX_ PL_no_sock_func, "endservent");
a0d0e21e
LW		 4599#endif
4600}
4601
4602PP(pp_gpwnam)
4603{
4604#ifdef HAS_PASSWD
cea2e8a9 4605 return pp_gpwent();
a0d0e21e 4606#else
cea2e8a9 4607 DIE(aTHX_ PL_no_func, "getpwnam");
a0d0e21e
LW		 4608#endif
4609}
4610
4611PP(pp_gpwuid)
4612{
4613#ifdef HAS_PASSWD
cea2e8a9 4614 return pp_gpwent();
a0d0e21e 4615#else
cea2e8a9 4616 DIE(aTHX_ PL_no_func, "getpwuid");
a0d0e21e
LW		 4617#endif
4618}
4619
4620PP(pp_gpwent)
4621{
4e35701f 4622 djSP;
28e8609d 4623#if defined(HAS_PASSWD) && defined(HAS_GETPWENT)
533c011a 4624 I32 which = PL_op->op_type;
a0d0e21e
LW		 4625 register SV *sv;
4626 struct passwd *pwent;
2d8e6c8d 4627 STRLEN n_a;
6a5e2de5 4628#if defined(HAS_GETSPENT) || defined(HAS_GETSPNAM)
eff96b52 4629 struct spwd *spwent = NULL;
8c0bfa08 4630#endif
a0d0e21e
LW		 4631
4632 if (which == OP_GPWNAM)
2d8e6c8d 4633 pwent = getpwnam(POPpx);
a0d0e21e
LW		 4634 else if (which == OP_GPWUID)
4635 pwent = getpwuid(POPi);
4636 else
4637 pwent = (struct passwd *)getpwent();
4638
f1066039 4639#ifdef HAS_GETSPNAM
eff96b52
GS		 4640 if (which == OP_GPWNAM) {
4641 if (pwent)
4642 spwent = getspnam(pwent->pw_name);
4643 }
f1066039 4644# ifdef HAS_GETSPUID /* AFAIK there isn't any anywhere. --jhi */
eff96b52
GS		 4645 else if (which == OP_GPWUID) {
4646 if (pwent)
4647 spwent = getspnam(pwent->pw_name);
4648 }
f1066039 4649# endif
6a5e2de5 4650# ifdef HAS_GETSPENT
eff96b52
GS		 4651 else
4652 spwent = (struct spwd *)getspent();
6a5e2de5 4653# endif
8c0bfa08
PB		 4654#endif
4655
a0d0e21e
LW		 4656 EXTEND(SP, 10);
4657 if (GIMME != G_ARRAY) {
4658 PUSHs(sv = sv_newmortal());
4659 if (pwent) {
4660 if (which == OP_GPWNAM)
1e422769 4661 sv_setiv(sv, (IV)pwent->pw_uid);
a0d0e21e
LW		 4662 else
4663 sv_setpv(sv, pwent->pw_name);
4664 }
4665 RETURN;
4666 }
4667
4668 if (pwent) {
3280af22 4669 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4670 sv_setpv(sv, pwent->pw_name);
6ee623d5 4671
3280af22 4672 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
28e8609d 4673#ifdef PWPASSWD
6a5e2de5 4674# if defined(HAS_GETSPENT) || defined(HAS_GETSPNAM)
8c0bfa08
PB		 4675 if (spwent)
4676 sv_setpv(sv, spwent->sp_pwdp);
4677 else
4678 sv_setpv(sv, pwent->pw_passwd);
f1066039 4679# else
a0d0e21e 4680 sv_setpv(sv, pwent->pw_passwd);
f1066039 4681# endif
8c0bfa08 4682#endif
6ee623d5 4683
3280af22 4684 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4685 sv_setiv(sv, (IV)pwent->pw_uid);
6ee623d5 4686
3280af22 4687 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4688 sv_setiv(sv, (IV)pwent->pw_gid);
6ee623d5
GS		 4689
4690 /* pw_change, pw_quota, and pw_age are mutually exclusive. */
3280af22 4691 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4692#ifdef PWCHANGE
1e422769 4693 sv_setiv(sv, (IV)pwent->pw_change);
a0d0e21e 4694#else
6ee623d5 4695# ifdef PWQUOTA
1e422769 4696 sv_setiv(sv, (IV)pwent->pw_quota);
6ee623d5
GS		 4697# else
4698# ifdef PWAGE
a0d0e21e 4699 sv_setpv(sv, pwent->pw_age);
6ee623d5
GS		 4700# endif
4701# endif
a0d0e21e 4702#endif
6ee623d5
GS		 4703
4704 /* pw_class and pw_comment are mutually exclusive. */
3280af22 4705 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 4706#ifdef PWCLASS
4707 sv_setpv(sv, pwent->pw_class);
4708#else
6ee623d5 4709# ifdef PWCOMMENT
a0d0e21e 4710 sv_setpv(sv, pwent->pw_comment);
6ee623d5 4711# endif
a0d0e21e 4712#endif
6ee623d5 4713
3280af22 4714 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
6ee623d5 4715#ifdef PWGECOS
a0d0e21e 4716 sv_setpv(sv, pwent->pw_gecos);
6ee623d5 4717#endif
fb73857a 4718#ifndef INCOMPLETE_TAINTS
d2719217 4719 /* pw_gecos is tainted because user himself can diddle with it. */
fb73857a 4720 SvTAINTED_on(sv);
4721#endif
6ee623d5 4722
3280af22 4723 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4724 sv_setpv(sv, pwent->pw_dir);
6ee623d5 4725
3280af22 4726 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4727 sv_setpv(sv, pwent->pw_shell);
6ee623d5 4728
a0d0e21e 4729#ifdef PWEXPIRE
6b88bc9c 4730 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4731 sv_setiv(sv, (IV)pwent->pw_expire);
a0d0e21e
LW		 4732#endif
4733 }
4734 RETURN;
4735#else
cea2e8a9 4736 DIE(aTHX_ PL_no_func, "getpwent");
a0d0e21e
LW		 4737#endif
4738}
4739
4740PP(pp_spwent)
4741{
4e35701f 4742 djSP;
2c2d71f5 4743#if defined(HAS_PASSWD) && defined(HAS_SETPWENT) && !defined(CYGWIN)
a0d0e21e 4744 setpwent();
f1066039 4745# ifdef HAS_SETSPENT
8c0bfa08 4746 setspent();
f1066039 4747# endif
a0d0e21e
LW		 4748 RETPUSHYES;
4749#else
cea2e8a9 4750 DIE(aTHX_ PL_no_func, "setpwent");
a0d0e21e
LW		 4751#endif
4752}
4753
4754PP(pp_epwent)
4755{
4e35701f 4756 djSP;
28e8609d 4757#if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
a0d0e21e 4758 endpwent();
f1066039 4759# ifdef HAS_ENDSPENT
8c0bfa08 4760 endspent();
f1066039 4761# endif
a0d0e21e
LW		 4762 RETPUSHYES;
4763#else
cea2e8a9 4764 DIE(aTHX_ PL_no_func, "endpwent");
a0d0e21e
LW		 4765#endif
4766}
4767
4768PP(pp_ggrnam)
4769{
4770#ifdef HAS_GROUP
cea2e8a9 4771 return pp_ggrent();
a0d0e21e 4772#else
cea2e8a9 4773 DIE(aTHX_ PL_no_func, "getgrnam");
a0d0e21e
LW		 4774#endif
4775}
4776
4777PP(pp_ggrgid)
4778{
4779#ifdef HAS_GROUP
cea2e8a9 4780 return pp_ggrent();
a0d0e21e 4781#else
cea2e8a9 4782 DIE(aTHX_ PL_no_func, "getgrgid");
a0d0e21e
LW		 4783#endif
4784}
4785
4786PP(pp_ggrent)
4787{
4e35701f 4788 djSP;
28e8609d 4789#if defined(HAS_GROUP) && defined(HAS_GETGRENT)
533c011a 4790 I32 which = PL_op->op_type;
a0d0e21e
LW		 4791 register char **elem;
4792 register SV *sv;
4793 struct group *grent;
2d8e6c8d 4794 STRLEN n_a;
a0d0e21e
LW		 4795
4796 if (which == OP_GGRNAM)
2d8e6c8d 4797 grent = (struct group *)getgrnam(POPpx);
a0d0e21e
LW		 4798 else if (which == OP_GGRGID)
4799 grent = (struct group *)getgrgid(POPi);
4800 else
4801 grent = (struct group *)getgrent();
4802
4803 EXTEND(SP, 4);
4804 if (GIMME != G_ARRAY) {
4805 PUSHs(sv = sv_newmortal());
4806 if (grent) {
4807 if (which == OP_GGRNAM)
1e422769 4808 sv_setiv(sv, (IV)grent->gr_gid);
a0d0e21e
LW		 4809 else
4810 sv_setpv(sv, grent->gr_name);
4811 }
4812 RETURN;
4813 }
4814
4815 if (grent) {
3280af22 4816 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4817 sv_setpv(sv, grent->gr_name);
28e8609d 4818
3280af22 4819 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
28e8609d 4820#ifdef GRPASSWD
a0d0e21e 4821 sv_setpv(sv, grent->gr_passwd);
28e8609d
JH		 4822#endif
4823
3280af22 4824 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4825 sv_setiv(sv, (IV)grent->gr_gid);
28e8609d 4826
3280af22 4827 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 4828 for (elem = grent->gr_mem; elem && *elem; elem++) {
a0d0e21e
LW		 4829 sv_catpv(sv, *elem);
4830 if (elem[1])
4831 sv_catpvn(sv, " ", 1);
4832 }
4833 }
4834
4835 RETURN;
4836#else
cea2e8a9 4837 DIE(aTHX_ PL_no_func, "getgrent");
a0d0e21e
LW		 4838#endif
4839}
4840
4841PP(pp_sgrent)
4842{
4e35701f 4843 djSP;
28e8609d 4844#if defined(HAS_GROUP) && defined(HAS_SETGRENT)
a0d0e21e
LW		 4845 setgrent();
4846 RETPUSHYES;
4847#else
cea2e8a9 4848 DIE(aTHX_ PL_no_func, "setgrent");
a0d0e21e
LW		 4849#endif
4850}
4851
4852PP(pp_egrent)
4853{
4e35701f 4854 djSP;
28e8609d 4855#if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
a0d0e21e
LW		 4856 endgrent();
4857 RETPUSHYES;
4858#else
cea2e8a9 4859 DIE(aTHX_ PL_no_func, "endgrent");
a0d0e21e
LW		 4860#endif
4861}
4862
4863PP(pp_getlogin)
4864{
4e35701f 4865 djSP; dTARGET;
a0d0e21e
LW		 4866#ifdef HAS_GETLOGIN
4867 char *tmps;
4868 EXTEND(SP, 1);
76e3520e 4869 if (!(tmps = PerlProc_getlogin()))
a0d0e21e
LW		 4870 RETPUSHUNDEF;
4871 PUSHp(tmps, strlen(tmps));
4872 RETURN;
4873#else
cea2e8a9 4874 DIE(aTHX_ PL_no_func, "getlogin");
a0d0e21e
LW		 4875#endif
4876}
4877
4878/* Miscellaneous. */
4879
4880PP(pp_syscall)
4881{
d2719217 4882#ifdef HAS_SYSCALL
4e35701f 4883 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW		 4884 register I32 items = SP - MARK;
4885 unsigned long a[20];
4886 register I32 i = 0;
4887 I32 retval = -1;
748a9306 4888 MAGIC *mg;
2d8e6c8d 4889 STRLEN n_a;
a0d0e21e 4890
3280af22 4891 if (PL_tainting) {
a0d0e21e 4892 while (++MARK <= SP) {
bbce6d69 4893 if (SvTAINTED(*MARK)) {
4894 TAINT;
4895 break;
4896 }
a0d0e21e
LW		 4897 }
4898 MARK = ORIGMARK;
4899 TAINT_PROPER("syscall");
4900 }
4901
4902 /* This probably won't work on machines where sizeof(long) != sizeof(int)
4903 * or where sizeof(long) != sizeof(char*). But such machines will
4904 * not likely have syscall implemented either, so who cares?
4905 */
4906 while (++MARK <= SP) {
4907 if (SvNIOK(*MARK) || !i)
4908 a[i++] = SvIV(*MARK);
3280af22 4909 else if (*MARK == &PL_sv_undef)
748a9306
LW		 4910 a[i++] = 0;
4911 else
2d8e6c8d 4912 a[i++] = (unsigned long)SvPV_force(*MARK, n_a);
a0d0e21e
LW		 4913 if (i > 15)
4914 break;
4915 }
4916 switch (items) {
4917 default:
cea2e8a9 4918 DIE(aTHX_ "Too many args to syscall");
a0d0e21e 4919 case 0:
cea2e8a9 4920 DIE(aTHX_ "Too few args to syscall");
a0d0e21e
LW		 4921 case 1:
4922 retval = syscall(a[0]);
4923 break;
4924 case 2:
4925 retval = syscall(a[0],a[1]);
4926 break;
4927 case 3:
4928 retval = syscall(a[0],a[1],a[2]);
4929 break;
4930 case 4:
4931 retval = syscall(a[0],a[1],a[2],a[3]);
4932 break;
4933 case 5:
4934 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
4935 break;
4936 case 6:
4937 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
4938 break;
4939 case 7:
4940 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
4941 break;
4942 case 8:
4943 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
4944 break;
4945#ifdef atarist
4946 case 9:
4947 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
4948 break;
4949 case 10:
4950 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
4951 break;
4952 case 11:
4953 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
4954 a[10]);
4955 break;
4956 case 12:
4957 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
4958 a[10],a[11]);
4959 break;
4960 case 13:
4961 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
4962 a[10],a[11],a[12]);
4963 break;
4964 case 14:
4965 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
4966 a[10],a[11],a[12],a[13]);
4967 break;
4968#endif /* atarist */
4969 }
4970 SP = ORIGMARK;
4971 PUSHi(retval);
4972 RETURN;
4973#else
cea2e8a9 4974 DIE(aTHX_ PL_no_func, "syscall");
a0d0e21e
LW		 4975#endif
4976}
4977
ff68c719 4978#ifdef FCNTL_EMULATE_FLOCK
4979
4980/* XXX Emulate flock() with fcntl().
4981 What's really needed is a good file locking module.
4982*/
4983
cea2e8a9
GS		 4984static int
4985fcntl_emulate_flock(int fd, int operation)
ff68c719 4986{
4987 struct flock flock;
4988
4989 switch (operation & ~LOCK_NB) {
4990 case LOCK_SH:
4991 flock.l_type = F_RDLCK;
4992 break;
4993 case LOCK_EX:
4994 flock.l_type = F_WRLCK;
4995 break;
4996 case LOCK_UN:
4997 flock.l_type = F_UNLCK;
4998 break;
4999 default:
5000 errno = EINVAL;
5001 return -1;
5002 }
5003 flock.l_whence = SEEK_SET;
d9b3e12d 5004 flock.l_start = flock.l_len = (Off_t)0;
ff68c719 5005
5006 return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5007}
5008
5009#endif /* FCNTL_EMULATE_FLOCK */
5010
5011#ifdef LOCKF_EMULATE_FLOCK
16d20bd9
AD		 5012
5013/* XXX Emulate flock() with lockf(). This is just to increase
5014 portability of scripts. The calls are not completely
5015 interchangeable. What's really needed is a good file
5016 locking module.
5017*/
5018
76c32331 5019/* The lockf() constants might have been defined in <unistd.h>.
5020 Unfortunately, <unistd.h> causes troubles on some mixed
5021 (BSD/POSIX) systems, such as SunOS 4.1.3.
16d20bd9
AD		 5022
5023 Further, the lockf() constants aren't POSIX, so they might not be
5024 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
5025 just stick in the SVID values and be done with it. Sigh.
5026*/
5027
5028# ifndef F_ULOCK
5029# define F_ULOCK 0 /* Unlock a previously locked region */
5030# endif
5031# ifndef F_LOCK
5032# define F_LOCK 1 /* Lock a region for exclusive use */
5033# endif
5034# ifndef F_TLOCK
5035# define F_TLOCK 2 /* Test and lock a region for exclusive use */
5036# endif
5037# ifndef F_TEST
5038# define F_TEST 3 /* Test a region for other processes locks */
5039# endif
5040
cea2e8a9
GS		 5041static int
5042lockf_emulate_flock(int fd, int operation)
16d20bd9
AD		 5043{
5044 int i;
84902520
TB		 5045 int save_errno;
5046 Off_t pos;
5047
5048 /* flock locks entire file so for lockf we need to do the same */
5049 save_errno = errno;
6ad3d225 5050 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
84902520 5051 if (pos > 0) /* is seekable and needs to be repositioned */
6ad3d225 5052 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
08b714dd 5053 pos = -1; /* seek failed, so don't seek back afterwards */
84902520
TB		 5054 errno = save_errno;
5055
16d20bd9
AD		 5056 switch (operation) {
5057
5058 /* LOCK_SH - get a shared lock */
5059 case LOCK_SH:
5060 /* LOCK_EX - get an exclusive lock */
5061 case LOCK_EX:
5062 i = lockf (fd, F_LOCK, 0);
5063 break;
5064
5065 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5066 case LOCK_SH|LOCK_NB:
5067 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5068 case LOCK_EX|LOCK_NB:
5069 i = lockf (fd, F_TLOCK, 0);
5070 if (i == -1)
5071 if ((errno == EAGAIN) || (errno == EACCES))
5072 errno = EWOULDBLOCK;
5073 break;
5074
ff68c719 5075 /* LOCK_UN - unlock (non-blocking is a no-op) */
16d20bd9 5076 case LOCK_UN:
ff68c719 5077 case LOCK_UN|LOCK_NB:
16d20bd9
AD		 5078 i = lockf (fd, F_ULOCK, 0);
5079 break;
5080
5081 /* Default - can't decipher operation */
5082 default:
5083 i = -1;
5084 errno = EINVAL;
5085 break;
5086 }
84902520
TB		 5087
5088 if (pos > 0) /* need to restore position of the handle */
6ad3d225 5089 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
84902520 5090
16d20bd9
AD		 5091 return (i);
5092}
ff68c719 5093
5094#endif /* LOCKF_EMULATE_FLOCK */
Unnamed repository; edit this file 'description' to name the repository.