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