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