#|
Ltk-remote networking support for the Ltk library
This software is Copyright (c) 2003 Peter Herth <herth@peter-herth.de>
Peter Herth grants you the rights to distribute
and use this software as governed by the terms
of the Lisp Lesser GNU Public License
(http://opensource.franz.com/preamble.html),
known as the LLGPL.
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.
|#
#+:sbcl (require 'sb-bsd-sockets)
(defpackage :ltk-remote
(:use :common-lisp :ltk
#+(or :cmu :scl) :ext
#+:sbcl :sb-ext
#+:sbcl :sb-thread
#+:sbcl :sb-bsd-sockets)
(:export
#:with-remote-ltk))
(in-package ltk-remote)
;;; cmu version
#+:cmu
(defun ip-address-string (address)
(format nil "~D.~D.~D.~D"
(ldb (byte 8 24) address)
(ldb (byte 8 16) address)
(ldb (byte 8 8) address)
(ldb (byte 8 0) address)))
(defvar *stop-remote* nil)
#+:cmu
(defmacro with-remote-ltk (port bindings form &rest cleanup)
`(mp:make-process
(lambda ()
(setf *stop-remote* nil)
(let ((fd (ext:create-inet-listener ,port :stream :reuse-address t)))
(unwind-protect
(loop
(when (or *stop-remote* mp::*quitting-lisp*)
(return))
(let ((winp (mp:process-wait-until-fd-usable fd :input 2)))
(when (or *stop-remote* mp::*quitting-lisp*)
(return))
(when winp
(let ((new-fd (ignore-errors (ext:accept-tcp-connection fd))))
(when new-fd
(mp:make-process
(lambda ()
(multiple-value-bind (server-address server-port)
(ext:get-socket-host-and-port new-fd)
(multiple-value-bind (remote-address remote-port)
(ext:get-peer-host-and-port new-fd)
(flet ((host-name (address)
(let ((host-entry (ext:lookup-host-entry address)))
(if host-entry
(ext:host-entry-name host-entry)
(ip-address-string address)))))
(let ((stream (sys:make-fd-stream new-fd :input t :output t))
(server-name (host-name server-address))
(remote-name (host-name remote-address)))
(format t "Connection to ~A:~D from ~A:~D at "
server-name server-port
remote-name remote-port)
(ext:format-universal-time t (get-universal-time)
:style :rfc1123)
(setf (mp:process-name mp:*current-process*)
(format nil "LTK connection to ~A:~D from ~A:~D"
server-name server-port
remote-name remote-port))
(let ,bindings
(ltk::call-with-ltk (lambda ()
,form)
:stream stream)
,@cleanup))))))))))))
(unix:unix-close fd))))
:name (format nil "LTK connection listener on port ~D" ,port)))
#+:cmu
(defun stop-server ()
(setf *stop-remote* t))
#+:cmu
(defun start-mp ()
#+nil (setf mp::*idle-process* mp::*initial-process*)
(mp::startup-idle-and-top-level-loops))
#+:cmu
(defun start-remote (port)
(multiprocessing::make-process #'(lambda () (ltk-remote-server port))))
;;; SCL version
#+:scl
(defmacro with-remote-ltk (port bindings form &rest cleanup)
`(thread:thread-create
(lambda ()
(setf *stop-remote* nil)
(let ((fd (ext:create-inet-listener ,port :stream :reuse-address t)))
(unwind-protect
(loop
(when (or *stop-remote* thread:*quitting-lisp*)
(return))
(let ((winp (sys:wait-until-fd-usable fd :input 2)))
(when (or *stop-remote* thread:*quitting-lisp*)
(return))
(when winp
(let ((new-fd (ignore-errors (ext:accept-tcp-connection fd))))
(when new-fd
(thread:thread-create
(lambda ()
(multiple-value-bind (server-address server-port)
(ext:get-socket-host-and-port new-fd)
(multiple-value-bind (remote-address remote-port)
(ext:get-peer-host-and-port new-fd)
(flet ((host-name (address)
(let ((host-entry (ext:lookup-host-entry address)))
(if host-entry
(ext:host-entry-name host-entry)
(ext:ip-address-string address)))))
(let ((stream (sys:make-fd-stream new-fd :input t :output t))
(server-name (host-name server-address))
(remote-name (host-name remote-address)))
(format t "Connection to ~A:~D from ~A:~D at "
server-name server-port
remote-name remote-port)
(ext:format-universal-time t (get-universal-time)
:style :rfc1123)
(setf (thread:thread-name thread:*thread*)
(format nil "LTK connection to ~A:~D from ~A:~D"
server-name server-port
remote-name remote-port))
(let ,bindings
(ltk::call-with-ltk (lambda ()
,form)
:stream stream)
,@cleanup))))))))))))
(unix:unix-close fd))))
:name (format nil "LTK connection listener on port ~D" ,port)))
#+:scl
(defun stop-server ()
(setf *stop-remote* t))
;;; sbcl version
#+:sbcl
(defun stop-server ()
(setf *stop-remote* t))
#+:sbcl
(defun make-socket-server (port)
(let ((socket (make-instance 'inet-socket :type :stream :protocol :tcp)))
(socket-bind socket #(0 0 0 0) port)
(socket-listen socket 100)
socket))
#+:sbcl
(defun get-connection-stream (server-socket)
(let* ((s (socket-accept server-socket))
(stream (socket-make-stream s :input t :output t)))
stream)) ;; do we need to return s as well ?
#+:sbcl
(defmacro with-remote-ltk (port bindings form &rest cleanup)
`(make-thread
(lambda ()
(setf *stop-remote* nil)
(let ((socket (make-socket-server ,port)))
(loop
(when *stop-remote*
(socket-close socket)
(return))
(let* ((s (socket-accept socket))
(stream (socket-make-stream s :input t :output t)))
(make-thread
(lambda ()
(let ,bindings
(ltk::call-with-ltk (lambda ()
,form)
:stream stream)
,@cleanup)))))
(socket-close socket)))))
;; lispworks version
(defvar *server* nil)
#+:lispworks
(defun stop-server ()
(mp:process-kill ltk-remote::*server*))
#+:lispworks
(require "comm")
#+:lispworks
(defmacro with-remote-ltk (port bindings form &rest cleanup)
`(setf ltk-remote::*server*
(comm:start-up-server :function
(lambda (handle)
(let ((stream (make-instance 'comm:socket-stream
:socket handle
:direction :io
:element-type
'base-char)))
(mp:process-run-function
(format nil "ltk-remote ~D" handle)
'()
(lambda ()
(let ,bindings
(ltk::call-with-ltk (lambda ()
,form)
:stream stream)
,@cleanup)))))
:service ,port)))
;; allegro version
#+:allegro
(progn
(require :sock)
(use-package :socket))
#+:allegro
(defmacro with-remote-ltk (port bindings form &rest cleanup)
`(setf ltk-remote::*server*
(mp:process-run-function
(format nil "ltk remote server [~a]" ,port)
(lambda ()
(let ((server (make-socket :type :stream :address-family :internet :connect :passive
:local-host "0.0.0.0" :local-port ,port
:reuse-address t :keepalive t)))
(restart-case
(unwind-protect
(loop
(let ((connection (accept-connection server)))
(mp:process-run-function
(format nil "ltk remote connection <~s>" (ipaddr-to-hostname
(remote-host connection)))
(lambda ()
(let ,bindings
(ltk::call-with-ltk (lambda ()
,form)
:stream connection)
,@cleanup)))))
(close server))
(quit ()
:report "Shutdown ltk remote server"
nil)))))))
;;; simple test function
(defun lrtest (port)
(with-remote-ltk
port ()
(let* ((txt (make-text nil :width 40 :height 10))
(f (make-instance 'frame ))
(b (make-instance 'button :master f :text "Hallo"
:command (lambda ()
(append-text txt (format nil "Hallo pressed~&")))))
(b2 (make-instance 'button :master f :text "Quit"
:command (lambda ()
(setf *exit-mainloop* t))))
(b3 (make-instance 'button :master f :text "Clear"
:command (lambda ()
(clear-text txt ))))
)
(pack b :side "left")
(pack b3 :side "left")
(pack b2 :side "left")
(pack f :side "top")
(pack txt :side "bottom")
)))
(defun rlb-test2 ()
(with-remote-ltk 8080 ()
(let* ((last nil)
(l (make-instance 'listbox))
(wf (make-instance 'frame))
(lbl (make-instance 'label :master wf :text "Widget:"))
(f (make-instance 'frame :master wf))
(canv (make-instance 'canvas :master f :width 100 :height 100))
(scanv (make-instance 'scrolled-canvas :master f))
(widgets (list
(make-instance 'button :master f :text "Button")
(make-instance 'label :master f :text "Label")
canv
scanv
))
; (b (make-instance 'button :text "Show" :command ))
)
(bind l "<Button-1>" (lambda (event)
(declare (ignore event))
(let ((sel (listbox-get-selection l)))
(format t "selection: ~a~%" sel)
(force-output)
(if (first sel)
(let ((w (nth (first (listbox-get-selection l)) widgets)))
(when last
(pack-forget last))
(pack w)
(setf last w))))))
(pack l :expand 1 :fill "y")
(pack wf :expand 1 :fill "both")
;(grid l 0 0)
;(grid wf 0 1)
(pack lbl :side "top")
(pack f :expand 1 :fill "both")
(configure wf "borderwidth" 2)
(configure wf "relief" "sunken")
;(pack b)
(create-line canv (list 0 0 40 40 60 20 80 80 60 60 40 80 20 60 0 80 0 0))
(create-line (canvas scanv) (mapcar (lambda (x)
(* x 10))
(list 0 0 40 40 60 20 80 80 60 60 40 80 20 60 0 80 0 0)))
(scrollregion (canvas scanv) 0 0 800 800)
(listbox-append l (mapcar (lambda (x) (type-of x)) widgets))
)))