From: Philippe Brochard Date: Sat, 20 Oct 2012 12:12:25 +0000 (+0200) Subject: Build clfswm image in load.lisp. Let bind-on-slot on other child than current child X-Git-Tag: R-1212~21 X-Git-Url: https://repo.or.cz/w/clfswm.git/commitdiff_plain/c31ef42829758a1934eee6515e9ca32023e3b9f6 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)))