[clfswm-cvs] r361 - in clfswm: . contrib contrib/server src
Philippe Brochard
pbrochard at common-lisp.net
Mon Oct 25 22:00:48 UTC 2010
Author: pbrochard
Date: Mon Oct 25 18:00:48 2010
New Revision: 361
Log:
contrib/server/server.lisp: Load clfswm client code in the main program and let the user start it with a --client command line option. * src/package.lisp (*main-entrance-hook*): New hook executed after loading configuration file and before opening the display.
Modified:
clfswm/ChangeLog
clfswm/contrib/clfswm
clfswm/contrib/server/clfswm-client.asd
clfswm/contrib/server/clfswm-client.lisp
clfswm/contrib/server/server.lisp
clfswm/contrib/server/util-server.asd
clfswm/load.lisp
clfswm/src/clfswm.lisp
clfswm/src/package.lisp
clfswm/src/tools.lisp
Modified: clfswm/ChangeLog
==============================================================================
--- clfswm/ChangeLog (original)
+++ clfswm/ChangeLog Mon Oct 25 18:00:48 2010
@@ -1,3 +1,12 @@
+2010-10-25 Philippe Brochard <pbrochard at common-lisp.net>
+
+ * contrib/server/server.lisp: Load clfswm client code in the main
+ program and let the user start it with a --client command line
+ option.
+
+ * src/package.lisp (*main-entrance-hook*): New hook executed after
+ loading configuration file and before opening the display.
+
2010-10-23 Philippe Brochard <pbrochard at common-lisp.net>
* src/xlib-util.lisp: Remove unnecessary xlib:display-finish-output.
Modified: clfswm/contrib/clfswm
==============================================================================
--- clfswm/contrib/clfswm (original)
+++ clfswm/contrib/clfswm Mon Oct 25 18:00:48 2010
@@ -137,8 +137,10 @@
--)
shift
break ;;
- *)
+ -h|--help)
usage ;;
+ *)
+ ARGS="$ARGS $1" ;;
esac
shift
done
@@ -188,18 +190,21 @@
rm -rf $(find "$dump_path/" -name "*svn")
rm -rf "$tmp_dir"/clfswm-tmp
+
+ echo "CLFSWM image is: $dump_image"
fi
# Run the resulting image
if test no = "$no_start"
then
cd "$dump_path"
+ echo "Arguments: $* and $ARGS"
case $lisp in
- clisp ) "$dump_image" ;;
- sbcl ) exec sbcl --core "$dump_image" ;;
- cmucl ) exec cmucl -core "$dump_image" ;;
- ccl ) exec ccl -I "$dump_image" ;;
- ecl ) "$dump_image" -eval "(progn (clfswm:main) (ext:quit 0))" ;;
+ clisp ) "$dump_image" -- $ARGS ;;
+ sbcl ) exec sbcl --core "$dump_image" $ARGS ;;
+ cmucl ) exec cmucl -core "$dump_image" $ARGS ;;
+ ccl ) exec ccl -I "$dump_image" -- $ARGS ;;
+ ecl ) "$dump_image" -eval "(progn (clfswm:main) (ext:quit 0))" $ARGS ;;
*) echo "..." ;;
esac
else
Modified: clfswm/contrib/server/clfswm-client.asd
==============================================================================
--- clfswm/contrib/server/clfswm-client.asd (original)
+++ clfswm/contrib/server/clfswm-client.asd Mon Oct 25 18:00:48 2010
@@ -7,14 +7,12 @@
(defsystem clfswm-client
:description ""
:licence "GNU Lesser General Public License (LGPL)"
- :components ((:file "clfswm-client"))
- :depends-on (util-server))
-
-
-
-
-
-
-
+ :components ((:file "md5")
+ (:file "net")
+ (:file "crypt")
+ (:file "key"
+ :depends-on ("crypt"))
+ (:file "clfswm-client"
+ :depends-on ("md5" "net" "crypt" "key"))))
Modified: clfswm/contrib/server/clfswm-client.lisp
==============================================================================
--- clfswm/contrib/server/clfswm-client.lisp (original)
+++ clfswm/contrib/server/clfswm-client.lisp Mon Oct 25 18:00:48 2010
@@ -1,22 +1,11 @@
(in-package :common-lisp-user)
(defpackage :clfswm-client
- (:use :common-lisp :crypt))
+ (:use :common-lisp :crypt)
+ (:export :start-client))
(in-package :clfswm-client)
-(defun args ()
- #+sbcl (cdr sb-ext:*posix-argv*)
- #+(or clozure ccl) (cddddr (ccl::command-line-arguments))
- #+gcl (cdr si:*command-args*)
- #+ecl (loop for i from 1 below (si:argc) collect (si:argv i))
- #+cmu (cdddr extensions:*command-line-strings*)
- #+allegro (cdr (sys:command-line-arguments))
- #+lispworks (cdr sys:*line-arguments-list*)
- #+clisp ext:*args*
- #-(or sbcl clozure gcl ecl cmu allegro lispworks clisp)
- (error "get-command-line-arguments not supported for your implementation"))
-
(defun uquit ()
#+(or clisp cmu) (ext:quit)
#+sbcl (sb-ext:quit)
@@ -27,7 +16,6 @@
#+ccl (ccl:quit))
-
(defparameter *server-port* 33333)
(defun print-output (sock &optional wait)
@@ -61,7 +49,7 @@
(parse-args sock (subseq args pos))))))
-(defun start-client (&optional (url "127.0.0.1") (port *server-port*))
+(defun start-client (args &optional (url "127.0.0.1") (port *server-port*))
(load-new-key)
(let* ((sock (port:open-socket url port))
(key (string-trim '(#\Newline #\Space) (decrypt (read-line sock nil nil) *key*))))
@@ -69,7 +57,7 @@
(write-line (crypt (format nil "~A~A" *key* (md5:md5 *key*)) *key*) sock)
(force-output sock)
(print-output sock t)
- (dolist (a (args))
+ (dolist (a args)
(parse-args sock a))
(loop
(print-output sock)
@@ -77,5 +65,6 @@
(let ((line (read-line)))
(write-line (crypt line *key*) sock)
(force-output sock)
- (quit-on-command line sock))))))
+ (quit-on-command line sock)))
+ (sleep 0.01))))
Modified: clfswm/contrib/server/server.lisp
==============================================================================
--- clfswm/contrib/server/server.lisp (original)
+++ clfswm/contrib/server/server.lisp Mon Oct 25 18:00:48 2010
@@ -37,7 +37,7 @@
(dbg asdf:*central-registry*)
-(asdf:oos 'asdf:load-op :util-server)
+(asdf:oos 'asdf:load-op :clfswm-client)
(in-package :clfswm)
@@ -234,13 +234,13 @@
(defun start-server (&optional port)
- (save-new-key)
(when port
(setf *server-port* port))
(setf *server-socket* (port:open-socket-server *server-port*))
(add-hook *loop-hook* 'handle-server)
(format t "*** Server is started on port ~A and is accepting connection only from [~{~A~^, ~}].~2%"
- *server-port* *server-allowed-host*))
+ *server-port* *server-allowed-host*)
+ (save-new-key))
@@ -248,11 +248,17 @@
(format t "done.
You can now start a clfswm server with the command (start-server &optional port).
-Only [~{~A~^, ~}] ~A allowed to login on the server~%"
+Only [~{~A~^, ~}] ~A allowed to login on the server.
+You can start the client with the '--client' command line option.~%"
*server-allowed-host*
(if (or (null *server-allowed-host*) (= (length *server-allowed-host*) 1))
"is" "are"))
+(defun server-parse-cmdline ()
+ (let ((args (get-command-line-words)))
+ (when (member "--client" args :test #'string-equal)
+ (clfswm-client:start-client (remove "--client" args :test #'string-equal))
+ (uquit))))
-
+(add-hook *main-entrance-hook* 'server-parse-cmdline)
Modified: clfswm/contrib/server/util-server.asd
==============================================================================
--- clfswm/contrib/server/util-server.asd (original)
+++ clfswm/contrib/server/util-server.asd Mon Oct 25 18:00:48 2010
@@ -4,14 +4,16 @@
(in-package #:asdf)
-(defsystem util-server
+(defsystem clfswm-client
:description ""
:licence "GNU Lesser General Public License (LGPL)"
:components ((:file "md5")
(:file "net")
(:file "crypt")
(:file "key"
- :depends-on ("crypt"))))
+ :depends-on ("crypt"))
+ (:file "clfswm-client"
+ :depends-on ("md5" "net" "crypt" "key"))))
Modified: clfswm/load.lisp
==============================================================================
--- clfswm/load.lisp (original)
+++ clfswm/load.lisp Mon Oct 25 18:00:48 2010
@@ -57,8 +57,8 @@
(in-package :clfswm)
-(ignore-errors
- (main :read-conf-file-p t))
+;;(ignore-errors
+ (main :read-conf-file-p t);)
;;;; Uncomment lines above to save the default documentation.
Modified: clfswm/src/clfswm.lisp
==============================================================================
--- clfswm/src/clfswm.lisp (original)
+++ clfswm/src/clfswm.lisp Mon Oct 25 18:00:48 2010
@@ -248,6 +248,7 @@
(conf-file-name alternate-conf)
(when read-conf-file-p
(read-conf-file))
+ (call-hook *main-entrance-hook*)
(handler-case
(open-display display protocol)
(xlib:access-error (c)
@@ -276,6 +277,7 @@
(format t "~2&Unhandled events: ~A~%" *unhandled-events*))))
+
(defun main (&key (display (or (getenv "DISPLAY") ":0")) protocol
(base-dir (directory-namestring (or *load-truename* "")))
(read-conf-file-p t)
Modified: clfswm/src/package.lisp
==============================================================================
--- clfswm/src/package.lisp (original)
+++ clfswm/src/package.lisp Mon Oct 25 18:00:48 2010
@@ -183,6 +183,10 @@
(defparameter *loop-hook* nil
"Config(Hook group): Hook executed on each event loop")
+(defparameter *main-entrance-hook* nil
+ "Config(Hook group): Hook executed on the main function entrance after
+loading configuration file and before opening the display.")
+
(defparameter *in-second-mode* nil)
Modified: clfswm/src/tools.lisp
==============================================================================
--- clfswm/src/tools.lisp (original)
+++ clfswm/src/tools.lisp Mon Oct 25 18:00:48 2010
@@ -717,9 +717,17 @@
(defun get-command-line-words ()
- #+CLISP ext:*args*
- #+CMU (nthcdr 3 extensions:*command-line-strings*)
- #+SBCL sb-ext:*posix-argv*)
+ #+sbcl (cdr sb-ext:*posix-argv*)
+ #+(or clozure ccl) (cddddr (ccl::command-line-arguments))
+ #+gcl (cdr si:*command-args*)
+ #+ecl (loop for i from 1 below (si:argc) collect (si:argv i))
+ #+cmu (cdddr extensions:*command-line-strings*)
+ #+allegro (cdr (sys:command-line-arguments))
+ #+lispworks (cdr sys:*line-arguments-list*)
+ #+clisp ext:*args*
+ #-(or sbcl clozure gcl ecl cmu allegro lispworks clisp)
+ (error "get-command-line-arguments not supported for your implementation"))
+
More information about the clfswm-cvs
mailing list