Группа :: Разработка/Scheme
Пакет: gambit-dsock
навигация по пакетам
Главная Изменения Спек Патчи Исходники Загрузить Gear Bugs and FR Repocop
gambit-dsock-1.1/ 0000755 0000000 0000000 00000000000 12307400442 0013711 5 ustar 00root root 0000000 0000000 gambit-dsock-1.1/Makefile 0000644 0000000 0000000 00000003001 12307400442 0015343 0 ustar 00root root 0000000 0000000
libdir=/usr/lib
includedir=/usr/include
BASENAME=dsock
LIBS=
#LIBS=-l$(BASENAME)
all: libgambc-$(BASENAME).so
libgambc-$(BASENAME).c: $(BASENAME).scm $(BASENAME)-common.scm $(BASENAME)-ffi.scm
gsc -:daq- -link -flat -o libgambc-$(BASENAME).c $(BASENAME).scm
$(BASENAME).c: libgambc-$(BASENAME).c
[ -f $< ]
libgambc-$(BASENAME).o: $(BASENAME).c libgambc-$(BASENAME).c
gsc -:daq- -obj -cc-options "-D___LIBRARY -D___SHARED -D___PRIMAL" $(BASENAME).c libgambc-$(BASENAME).c
$(BASENAME).o: libgambc-$(BASENAME).o
[ -f $< ]
libgambc-$(BASENAME).so: $(BASENAME).o libgambc-$(BASENAME).o
gcc -shared $(BASENAME).o libgambc-$(BASENAME).o -lgambc $(LIBS) -o libgambc-$(BASENAME).so
install: libgambc-$(BASENAME).so libgambc-$(BASENAME).c
install -Dp -m0644 libgambc-$(BASENAME).so $(libdir)/gambit/libgambc-$(BASENAME).so
install -Dp -m0644 libgambc-$(BASENAME).c $(includedir)/gambit/libgambc-$(BASENAME).c
$(BASENAME)-test: $(BASENAME)-test.scm libgambc-$(BASENAME).so
echo "Run $(BASENAME)-test.scm to verify the library"
gsc -:daq- -link ./libgambc-$(BASENAME).c $(BASENAME)-test.scm
gsc -:daq- -obj $(BASENAME)-test.c $(BASENAME)-test_.c
gcc $(BASENAME)-test.o $(BASENAME)-test_.o -lgambc -L. -lgambc-$(BASENAME) -o $(BASENAME)-test
check: $(BASENAME)-test
LD_LIBRARY_PATH=. ./$(BASENAME)-test -:daq-
clean:
rm -fv libgambc-$(BASENAME).c libgambc-$(BASENAME).o libgambc-$(BASENAME).so
rm -fv $(BASENAME)-test $(BASENAME)-test.c $(BASENAME)-test.o $(BASENAME)-test_.c $(BASENAME)-test_.o $(BASENAME).c $(BASENAME).o
gambit-dsock-1.1/dsock-common.scm 0000644 0000000 0000000 00000006140 12307400442 0017007 0 ustar 00root root 0000000 0000000 ;; UNIX domain sockets for Gambit-C. High-level interface.
;;
;; Copyright (C) 2013 Paul Wolneykien <manowar@altlinux.org>
;;
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
(define (raise-domain-socket-lasterror)
(raise (cons 'domain-socket-exception
(cons (dlasterror) (dlasterror-string)))))
(define (domain-socket-exception? e)
(and (pair? e) (eq? 'domain-socket-exception (car e))))
(define (domain-socket-exception-code e)
(cadr e))
(define (domain-socket-exception-message e)
(cddr e))
(define (make-domain-socket path backlog)
(let ((socket-fd (dsocket)))
(if (< 0 socket-fd)
(if (= 0 (dbind socket-fd path))
(if (= 0 (dlisten socket-fd backlog))
(cons socket-fd path)
(raise-domain-socket-lasterror))
(raise-domain-socket-lasterror))
(raise-domain-socket-lasterror))))
(define (domain-socket? ds)
(and ds
(pair? ds)
(integer? (car ds))
(< 0 (car ds))
(string? (cdr ds))))
(define (assert-domain-socket ds)
(or (domain-socket? ds)
(raise "Instance of make-domain-socket expected")))
(define (domain-socket-fd ds)
(and (assert-domain-socket ds) (car ds)))
(define (domain-socket-path ds)
(and (assert-domain-socket ds) (cdr ds)))
(define (domain-socket-shutdown-read ds)
(or (= 0 (dshutdown-read (domain-socket-fd ds)))
(raise-domain-socket-lasterror)))
(define (domain-socket-shutdown-write ds)
(or (= 0 (dshutdown-write (domain-socket-fd ds)))
(raise-domain-socket-lasterror)))
(define (domain-socket-shutdown-both ds)
(or (= 0 (dshutdown (domain-socket-fd ds)))
(raise-domain-socket-lasterror)))
(define (delete-domain-socket ds)
(if (domain-socket-shutdown-both ds)
(delete-file (domain-socket-path ds))
#t))
(define (domain-socket-accept ds . args)
(let* ((timeout (or (and (not (null? args)) (pair? args) (car args)) -1))
(client-fd (daccept (domain-socket-fd ds) timeout)))
(if (< 0 client-fd)
(##open-predefined 3 (list (domain-socket-path ds) 'server) client-fd)
(if (and (= 0 client-fd) (<= 0 timeout))
#f
(raise-domain-socket-lasterror)))))
(define *EINPROGRESS* (dsock-EINPROGRESS-code))
(define (domain-socket-connect path . args)
(let ((timeout (or (and (not (null? args)) (pair? args) (car args)) -1))
(socket-fd (dsocket)))
(if (< 0 socket-fd)
(let ((ret (dconnect socket-fd path timeout)))
(if (= 0 ret)
(##open-predefined 3 (list path 'client) socket-fd)
(if (= *EINPROGRESS* ret)
#f
(raise-domain-socket-lasterror))))
(raise-domain-socket-lasterror))))
gambit-dsock-1.1/dsock-ffi.scm 0000644 0000000 0000000 00000007076 12307400442 0016274 0 ustar 00root root 0000000 0000000 ;; UNIX domain sockets for Gambit-C. Low-level interface.
;;
;; Copyright (C) 2013 Paul Wolneykien <manowar@altlinux.org>
;;
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
(c-declare "
#include <sys/socket.h>
#include <sys/un.h>
#include <stddef.h>
#include <string.h>
#include <errno.h>
#include <poll.h>
#include <fcntl.h>
")
(define dsocket
(c-lambda () int
"___result = socket (PF_LOCAL, SOCK_STREAM, 0);"))
(define dbind
(c-lambda (int char-string) int
#<<c-lambda-end
struct sockaddr_un name;
size_t size;
name.sun_family = AF_LOCAL;
strncpy (name.sun_path, ___arg2, sizeof (name.sun_path));
name.sun_path[sizeof (name.sun_path) - 1] = '\0';
size = (offsetof (struct sockaddr_un, sun_path) + strlen (name.sun_path) + 1);
___result = bind(___arg1, (struct sockaddr *) &name, size);
c-lambda-end
))
(define dlisten
(c-lambda (int int) int
"___result = listen (___arg1, ___arg2);"))
(define daccept
(c-lambda (int int) int
#<<c-lambda-end
struct sockaddr_un clientname;
size_t size = sizeof(struct sockaddr_un);
struct pollfd fds;
fds.fd = ___arg1;
fds.events = POLLIN;
fds.revents = 0;
___result = poll (&fds, 1, ___arg2);
if (___result > 0 && (fds.revents & POLLIN)) {
___result = accept (___arg1, (struct sockaddr *) &clientname, &size);
}
c-lambda-end
))
(define dsock-EINPROGRESS-code (c-lambda () int "___result = EINPROGRESS;"))
(define dconnect
(c-lambda (int char-string int) int
#<<c-lambda-end
struct sockaddr_un name;
size_t size;
name.sun_family = AF_LOCAL;
strncpy (name.sun_path, ___arg2, sizeof (name.sun_path));
name.sun_path[sizeof (name.sun_path) - 1] = '\0';
size = (offsetof (struct sockaddr_un, sun_path) + strlen (name.sun_path) + 1);
int flags = 0;
struct pollfd fds;
fds.fd = ___arg1;
fds.events = POLLOUT;
fds.revents = 0;
int valopt;
socklen_t optlen;
int ret;
if ((flags = fcntl (___arg1, F_GETFL, NULL)) >= 0) {
if ((___result = fcntl (___arg1, F_SETFL, flags | O_NONBLOCK)) == 0) {
___result = connect (___arg1, (struct sockaddr *) &name, size);
if (___result < 0) {
if (errno == EINPROGRESS || errno == EALREADY) {
if (poll (&fds, 1, ___arg3) > 0 && (fds.revents & POLLOUT)) {
if ((___result = getsockopt (___arg1, SOL_SOCKET, SO_ERROR, &valopt, &optlen)) == 0) {
___result = errno = valopt;
}
} else {
___result = EINPROGRESS;
}
}
}
ret = fcntl (___arg1, F_SETFL, flags & ~O_NONBLOCK);
if (___result == 0) {
___result = ret;
}
}
} else {
___result = (int) flags;
}
c-lambda-end
))
(define dshutdown
(c-lambda (int) int
#<<c-lambda-end
___result = shutdown (___arg1, SHUT_RDWR);
c-lambda-end
))
(define dshutdown-read
(c-lambda (int) int
#<<c-lambda-end
___result = shutdown (___arg1, SHUT_RD);
c-lambda-end
))
(define dshutdown-write
(c-lambda (int) int
#<<c-lambda-end
___result = shutdown (___arg1, SHUT_WR);
c-lambda-end
))
(define dlasterror
(c-lambda () int
"___result = errno;"))
(define dlasterror-string
(c-lambda () char-string
"___result = strerror(errno);"))
gambit-dsock-1.1/dsock-test.scm 0000644 0000000 0000000 00000004721 12307400442 0016501 0 ustar 00root root 0000000 0000000
(define *socket-path* "test.sock")
(define (display-message name msg new-line)
(display "[")
(display name)
(display "] ")
(display msg)
(if new-line
(newline)))
(define (read-and-report name port)
(input-port-timeout-set! port 5
(lambda ()
(display-message name "Read timed-out" #t)
#f))
(display-message name "Reading the data" #t)
(let ((res (read port)))
(display-message name "Receive: " #f)
(pp res)
res))
(define (connect-or-report name path maxloops)
(display-message name "Connecting to the socket..." #t)
(let loop ((t 0))
(let ((port (domain-socket-connect path 100)))
(if (and port (port? port))
port
(if (>= t maxloops)
(begin
(display-message name "Connection timed-out" #t)
#f)
(begin
(thread-sleep! 0.01)
(loop (+ t 1))))))))
(define (make-client name maxloops)
(make-thread
(lambda ()
(let ((socket (connect-or-report name *socket-path* maxloops)))
(if (and socket (port? socket))
(begin
(display-message name "Writing the data" #t)
(write name socket)
(force-output socket 1)
(let ((res (read-and-report name socket)))
(close-port socket)
res))
#f)))
name))
(define (accept-or-report name ds maxloops)
(display-message name "Waiting for connection..." #t)
(let loop ((t 0))
(let ((port (domain-socket-accept ds 0)))
(if (and port (port? port))
port
(if (>= t maxloops)
(begin
(display-message name "Connection timed-out" #t)
#f)
(begin
(thread-yield!)
(loop (+ t 1))))))))
(let ((ds (make-domain-socket *socket-path* 2))
(c1 (make-client "alpha" 50))
(c2 (make-client "beta" 50)))
(thread-start! c1)
(thread-start! c2)
(let* ((p1 (accept-or-report "server" ds 50))
(d1 (and p1 (read-and-report "server" p1)))
(p2 (accept-or-report "server" ds 50))
(d2 (and p2 (read-and-report "server" p2))))
(if p1
(begin
(display-message "server" "Writing the data to the peer 1" #t)
(write d1 p1)
(force-output p1 1)
(close-port p1)))
(if p2
(begin
(display-message "server" "Writing the data to the peer 2" #t)
(write d2 p2)
(force-output p2 1)
(close-port p2)))
(delete-domain-socket ds)
(if (and p1
p2
(equal? (thread-join! c1) (thread-name c1))
(equal? (thread-join! c2) (thread-name c2)))
(begin
(display "Test passed")
(newline)
(exit 0))
(begin
(display "Test FAILED")
(newline)
(exit 1)))))
gambit-dsock-1.1/dsock.scm 0000644 0000000 0000000 00000001446 12307400442 0015525 0 ustar 00root root 0000000 0000000 ;; UNIX domain sockets for Gambit-C.
;;
;; Copyright (C) 2013 Paul Wolneykien <manowar@altlinux.org>
;;
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
(include "dsock-ffi.scm")
(include "dsock-common.scm")