[clfswm-cvs] [clfswm-git]CLFSWM - A(nother) Common Lisp FullScreen Window Manager branch master updated. R-1106-143-gc31ef42
Philippe Brochard
pbrochard at common-lisp.net
Sat Oct 20 12:12:56 UTC 2012
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "CLFSWM - A(nother) Common Lisp FullScreen Window Manager".
The branch, master has been updated
via c31ef42829758a1934eee6515e9ca32023e3b9f6 (commit)
from fb5fe5fe1ca54228086486b67307cd13b029675f (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit c31ef42829758a1934eee6515e9ca32023e3b9f6
Author: Philippe Brochard <pbrochard at common-lisp.net>
Date: Sat Oct 20 14:12:25 2012 +0200
Build clfswm image in load.lisp. Let bind-on-slot on other child than current child
diff --git a/doc/dot-clfswmrc b/doc/dot-clfswmrc
index ce51b72..7dc7adb 100644
--- a/doc/dot-clfswmrc
+++ b/doc/dot-clfswmrc
@@ -190,3 +190,16 @@
;;;; my-init-hook-rox-filer
;;;;(setf *init-hook* nil)
;;;;; Init hook end
+
+
+;;; For debuging: start another sever (for example: 'startx -- :1'), Xnest
+;;; or Zephyr and add the lines above in a dot-clfswmrc-debug file
+;;; mod-2 is the numlock key on some keyboards.
+;;(setf *default-modifiers* '(:mod-2))
+;;
+;;(defun my-add-escape ()
+;; (define-main-key ("Escape" :mod-2) 'exit-clfswm))
+;;
+;;(add-hook *binding-hook* 'my-add-escape)
+;;
+;;(clfswm:main :display ":1" :alternate-conf #P"/where/is/dot-clfswmrc-debug")
diff --git a/load.lisp b/load.lisp
index 826997d..ca9d1d0 100644
--- a/load.lisp
+++ b/load.lisp
@@ -23,6 +23,9 @@
;;;
;;; --------------------------------------------------------------------------
+;;;------------------
+;;; Customization part
+;;;------------------
(pushnew :clfswm-build *features*)
(pushnew :clfswm-dump *features*)
(pushnew :clfswm-start *features*)
@@ -31,21 +34,29 @@
;;;;;; Uncomment lines above to build the default documentation.
;;(pushnew :clfswm-build-doc *features*)
+;;;;; Uncomment the line below if you want to see all ignored X errors
+;;(pushnew :xlib-debug *features*)
+
+;;;;; Uncomment the line below if you want to see all event debug messages
+;;(pushnew :event-debug *features*)
+
(defparameter *base-dir* (directory-namestring *load-truename*))
(export '*base-dir*)
-#+CMU
+#+:CMU
(setf ext:*gc-verbose* nil)
-
+;;;------------------
+;;; ASDF part
+;;;------------------
;;;; Loading ASDF
-#+(or SBCL ECL)
+#+(or :SBCL :ECL)
(require :asdf)
-#-ASDF
+#-:ASDF
(load (make-pathname :host (pathname-host *base-dir*)
:device (pathname-device *base-dir*)
:directory (append (pathname-directory *base-dir*) (list "contrib"))
@@ -53,54 +64,48 @@
(push *base-dir* asdf:*central-registry*)
+;;(setf asdf:*verbose-out* t)
-
-
-#+(or CMU ECL)
+;;;------------------
+;;; XLib part
+;;;------------------
+#+(or :CMU :ECL)
(require :clx)
-#+(AND CLISP (not CLX))
-(when (fboundp 'require)
- (require "clx.lisp"))
-
-#-ASDF
-(load (make-pathname :host (pathname-host *base-dir*)
- :device (pathname-device *base-dir*)
- :directory (append (pathname-directory *base-dir*) (list "contrib"))
- :name "asdf" :type "lisp"))
-
-(push *base-dir* asdf:*central-registry*)
-
-;;(setf asdf:*verbose-out* t)
-;;;; Uncomment the line above if you want to follow the
-;;;; handle event mecanism.
-;;(pushnew :event-debug *features*)
+;;; This part needs clisp >= 2.50
+;;#+(AND CLISP (not CLX))
+;;(when (fboundp 'require)
+;; (require "clx.lisp"))
+;;;------------------
+;;; CLFSWM loading
+;;;------------------
+#+:clfswm-build
(asdf:oos 'asdf:load-op :clfswm)
+
+;;;-------------------------
+;;; Starting clfswm
+;;;-------------------------
(in-package :clfswm)
-#-:clfswm-build-doc
+#+:clfswm-start
(ignore-errors
- (main :read-conf-file-p t))
+ (main :read-conf-file-p #-:clfswm-build-doc t #+:clfswm-build-doc nil))
+
+;;;-------------------------
+;;; Building documentation
+;;;-------------------------
#+:clfswm-build-doc
-(ignore-errors
- (main :read-conf-file-p nil)
- (produce-all-docs))
-
-
-;;; For debuging: start another sever (for example: 'startx -- :1'), Xnest
-;;; or Zephyr and add the lines above in a dot-clfswmrc-debug file
-;;; mod-2 is the numlock key on some keyboards.
-;;(setf *default-modifiers* '(:mod-2))
-;;
-;;(defun my-add-escape ()
-;; (define-main-key ("Escape" :mod-2) 'exit-clfswm))
-;;
-;;(add-hook *binding-hook* 'my-add-escape)
-;;
-;;(clfswm:main :display ":1" :alternate-conf #P"/where/is/dot-clfswmrc-debug")
+(produce-all-docs)
+
+;;;-----------------------
+;;; Building image part
+;;;-----------------------
+#+:clfswm-build
+(build-lisp-image "clfswm")
+
diff --git a/src/clfswm-internal.lisp b/src/clfswm-internal.lisp
index 81c5e7e..7e404ab 100644
--- a/src/clfswm-internal.lisp
+++ b/src/clfswm-internal.lisp
@@ -879,6 +879,13 @@ XINERAMA version 1.1 opcode: 150
(push window acc))
acc))
+(defun get-all-frame-windows (&optional (root *root-frame*))
+ "Return all frame windows in root and in its children"
+ (let ((acc nil))
+ (with-all-frames (root frame)
+ (push (frame-window frame) acc))
+ acc))
+
(defun get-hidden-windows ()
"Return all hiddens windows"
@@ -1568,9 +1575,11 @@ managed."
"Windows present when clfswm starts up must be absorbed by clfswm."
(setf *in-process-existing-windows* t)
(let ((id-list nil)
- (all-windows (get-all-windows)))
+ (all-windows (get-all-windows))
+ (all-frame-windows (get-all-frame-windows)))
(dolist (win (xlib:query-tree (xlib:screen-root screen)))
- (unless (child-member win all-windows)
+ (unless (or (child-member win all-windows)
+ (child-member win all-frame-windows))
(let ((map-state (xlib:window-map-state win))
(wm-state (window-state win)))
(unless (or (eql (xlib:window-override-redirect win) :on)
diff --git a/src/clfswm-util.lisp b/src/clfswm-util.lisp
index 841cbed..9e0b396 100644
--- a/src/clfswm-util.lisp
+++ b/src/clfswm-util.lisp
@@ -64,6 +64,15 @@
+;;;----------------------------
+;;; Lisp image part
+;;;----------------------------
+(defun build-lisp-image (dump-name)
+ #+CLISP (ext:saveinitmem dump-name :init-function (lambda () (clfswm:main) (ext:quit)) :executable t :norc t)
+ #+SBCL (sb-ext:save-lisp-and-die dump-name :toplevel 'clfswm:main :executable t))
+
+
+
(defun query-yes-or-no (formatter &rest args)
(let ((rep (query-string (apply #'format nil formatter args) "" '("Yes" "No"))))
(or (string= rep "")
@@ -941,9 +950,9 @@ For window: set current child to window or its parent according to window-parent
(dotimes (i 10)
(setf (aref key-slots i) nil)))
- (defun bind-on-slot (&optional (slot current-slot))
+ (defun bind-on-slot (&optional (slot current-slot) child)
"Bind current child to slot"
- (setf (aref key-slots slot) (current-child)))
+ (setf (aref key-slots slot) (if child child (current-child))))
(defun remove-binding-on-slot ()
"Remove binding on slot"
diff --git a/src/tools.lisp b/src/tools.lisp
index d930362..04b0dc7 100644
--- a/src/tools.lisp
+++ b/src/tools.lisp
@@ -403,7 +403,6 @@ Return the result of the last hook"
(force-output))
-
(defun in-rectangle (x y rectangle)
(and rectangle
(<= (rectangle-x rectangle) x (+ (rectangle-x rectangle) (rectangle-width rectangle)))
-----------------------------------------------------------------------
Summary of changes:
doc/dot-clfswmrc | 13 +++++++
load.lisp | 87 ++++++++++++++++++++++++---------------------
src/clfswm-internal.lisp | 13 ++++++-
src/clfswm-util.lisp | 13 ++++++-
src/tools.lisp | 1 -
5 files changed, 81 insertions(+), 46 deletions(-)
hooks/post-receive
--
CLFSWM - A(nother) Common Lisp FullScreen Window Manager
More information about the clfswm-cvs
mailing list