[clfswm-cvs] CVS clfswm
pbrochard
pbrochard at common-lisp.net
Fri May 2 19:56:10 UTC 2008
Update of /project/clfswm/cvsroot/clfswm
In directory clnet:/tmp/cvs-serv1964
Modified Files:
ChangeLog bindings-pager.lisp bindings-second-mode.lisp
bindings.lisp clfswm-info.lisp clfswm-internal.lisp
clfswm-keys.lisp clfswm-pack.lisp clfswm-second-mode.lisp
clfswm-util.lisp clfswm.asd clfswm.lisp config.lisp
dot-clfswmrc keysyms.lisp load.lisp netwm-util.lisp
package.lisp tools.lisp xlib-util.lisp
Log Message:
Revert to the 0801 version. See the SVN or GIT repository for new update
--- /project/clfswm/cvsroot/clfswm/ChangeLog 2008/02/27 22:34:55 1.17
+++ /project/clfswm/cvsroot/clfswm/ChangeLog 2008/05/02 19:56:08 1.18
@@ -1,34 +1,3 @@
-2008-02-27 Philippe Brochard <hocwp at free.fr>
-
- * clfswm-layout.lisp (*-layout): Add an optional raise-p
- parameter in each layout.
-
-2008-02-26 Philippe Brochard <hocwp at free.fr>
-
- * clfswm-util.lisp (copy/cut-current-child): Does not affect the
- root group.
- (copy/move-current-child-by-name/number): new functions
- (focus-group-by-name/number): new functions
- (delete-group-by-name/number): new functions
-
-2008-02-24 Philippe Brochard <hocwp at free.fr>
-
- * *: Major update - No more reference to workspaces. The main
- structure is a tree of groups or application windows.
-
-2008-02-07 Philippe Brochard <hocwp at free.fr>
-
- * clfswm.lisp (read-conf-file): Read configuration in
- $HOME/.clfswmrc or in /etc/clfswmrc or in
- $XDG_CONFIG_HOME/clfswm/clfswmrc.
- (xdg-config-home): Return the content of $XDG-CONFIG-HOME (default
- to $HOME/.config/).
-
-2008-01-18 Philippe Brochard <hocwp at free.fr>
-
- * clfswm-internal.lisp (show-all-group): Use *root* and *root-gc*
- by default.
-
2008-01-03 Philippe Brochard <hocwp at free.fr>
* clfswm-internal.lisp (find-window-group): New function.
--- /project/clfswm/cvsroot/clfswm/bindings-pager.lisp 2008/02/24 20:53:37 1.9
+++ /project/clfswm/cvsroot/clfswm/bindings-pager.lisp 2008/05/02 19:56:08 1.10
@@ -1,7 +1,7 @@
;;; --------------------------------------------------------------------------
;;; CLFSWM - FullScreen Window Manager
;;;
-;;; #Date#: Tue Feb 12 14:02:07 2008
+;;; #Date#: Fri Jan 4 23:56:09 2008
;;;
;;; --------------------------------------------------------------------------
;;; Documentation: Bindings keys and mouse for pager mode
@@ -253,9 +253,9 @@
(defmacro define-pager-focus-workspace-by-number (key number)
"Define a pager key to focus a workspace by its number"
`(define-pager-key ,key
- (defun ,(create-symbol (format nil "b-pager-focus-workspace-~A" number)) ()
- ,(format nil "Focus workspace ~A" number)
- (pager-select-workspace-by-number ,number))))
+ (defun ,(create-symbol (format nil "b-pager-focus-workspace-~A" number)) ()
+ ,(format nil "Focus workspace ~A" number)
+ (pager-select-workspace-by-number ,number))))
(define-pager-focus-workspace-by-number (#\1 :mod-1) 1)
--- /project/clfswm/cvsroot/clfswm/bindings-second-mode.lisp 2008/02/29 23:05:56 1.16
+++ /project/clfswm/cvsroot/clfswm/bindings-second-mode.lisp 2008/05/02 19:56:08 1.17
@@ -1,7 +1,7 @@
;;; --------------------------------------------------------------------------
;;; CLFSWM - FullScreen Window Manager
;;;
-;;; #Date#: Thu Feb 28 21:38:00 2008
+;;; #Date#: Thu Jan 3 23:13:40 2008
;;;
;;; --------------------------------------------------------------------------
;;; Documentation: Bindings keys and mouse for second mode
@@ -34,698 +34,553 @@
;;;|
;;;| CONFIG - Second mode bindings
;;;`-----
+(defun leave-second-mode-maximize ()
+ "Leave second mode and maximize current group"
+ (maximize-group (current-group))
+ (banish-pointer)
+ (show-all-windows-in-workspace (current-workspace))
+ (throw 'exit-second-loop nil))
+
+(defun leave-second-mode ()
+ "Leave second mode"
+ (banish-pointer)
+ (show-all-windows-in-workspace (current-workspace))
+ (throw 'exit-second-loop nil))
+(define-second-key ("F1" :mod-1) 'help-on-second-mode)
-;;;;;;;;;;;;;;;
-;; Menu entry
-;;;;;;;;;;;;;;;
-(defun group-adding-menu ()
- "Adding group menu"
- (info-mode-menu '((#\a add-default-group)
- (#\p add-placed-group))))
+(define-second-key (#\g :control) 'stop-all-pending-actions)
-(defun group-layout-menu ()
- "Group layout menu"
- (info-mode-menu (loop for l in *layout-list*
- for i from 0
- collect (list (code-char (+ (char-code #\a) i)) l))))
+(define-second-key (#\i) 'identify-key)
+(define-second-key (#\:) 'eval-from-query-string)
-
+(defun run-program-from-query-string ()
+ "Run a program from the query input"
+ (let ((program (query-string "Run:")))
+ (when (and program (not (equal program "")))
+ (setf *second-mode-program* program)
+ (leave-second-mode))))
-(defun group-pack-menu ()
- "Group pack menu"
- (info-mode-menu '(("Up" group-pack-up)
- ("Down" group-pack-down))))
+(define-second-key (#\!) 'run-program-from-query-string)
-(defun group-movement-menu ()
- "Group movement menu"
- (info-mode-menu '((#\p group-pack-menu)
- (#\f group-fill-menu)
- (#\r group-resize-menu))))
+(define-second-key (#\t) 'leave-second-mode-maximize)
+(define-second-key ("Return") 'leave-second-mode-maximize)
+(define-second-key ("Escape") 'leave-second-mode)
-(defun group-pack-up ()
- "Pack group up"
- (print 'pack-up)
- (group-movement-menu))
+(define-second-key (#\< :control) 'leave-second-mode)
+(define-second-key ("Return" :control) 'leave-second-mode)
-(defun group-pack-down ()
- "Pack group down"
- (print 'pack-down)
- (group-movement-menu))
+;; Escape
+(define-second-key ("Escape" :control :shift) 'delete-current-window)
+(define-second-key ("Escape" :mod-1 :control :shift) 'destroy-current-window)
+(define-second-key ("Escape" :control) 'remove-current-window)
+(define-second-key ("Escape" :shift) 'unhide-all-windows-in-current-group)
+;; Up
+(define-second-key ("Up" :mod-1) 'circulate-group-up)
+(define-second-key ("Up" :mod-1 :shift) 'circulate-group-up-move-window)
+(define-second-key ("Up" :mod-1 :shift :control) 'circulate-group-up-copy-window)
+;; Down
+(define-second-key ("Down" :mod-1) 'circulate-group-down)
+(define-second-key ("Down" :mod-1 :shift) 'circulate-group-down-move-window)
+(define-second-key ("Down" :mod-1 :shift :control) 'circulate-group-down-copy-window)
+;; Right
+(define-second-key ("Right" :mod-1) 'circulate-workspace-up)
+(define-second-key ("Right" :mod-1 :shift) 'circulate-workspace-up-move-group)
+(define-second-key ("Right" :mod-1 :shift :control) 'circulate-workspace-up-copy-group)
-(defun action-by-name-menu ()
- "Actions by name menu"
- (info-mode-menu '((#\f focus-group-by-name)
- (#\o open-group-by-name)
- (#\d delete-group-by-name)
- (#\m move-current-child-by-name)
- (#\c copy-current-child-by-name))))
-(defun action-by-number-menu ()
- "Actions by number menu"
- (info-mode-menu '((#\f focus-group-by-number)
- (#\o open-group-by-number)
- (#\d delete-group-by-number)
- (#\m move-current-child-by-number)
- (#\c copy-current-child-by-number))))
+;; Left
+(define-second-key ("Left" :mod-1) 'circulate-workspace-down)
+(define-second-key ("Left" :mod-1 :shift) 'circulate-workspace-down-move-group)
+(define-second-key ("Left" :mod-1 :shift :control) 'circulate-workspace-down-copy-group)
-(defun group-menu ()
- "Group menu"
- (info-mode-menu '((#\a group-adding-menu)
- (#\l group-layout-menu)
- (#\m group-movement-menu))))
+(defmacro define-second-focus-workspace-by-number (key number)
+ "Define a second key to focus a workspace by its number"
+ `(define-second-key ,key
+ (defun ,(create-symbol (format nil "b-second-focus-workspace-~A" number)) ()
+ ,(format nil "Focus workspace ~A" number)
+ (circulate-workspace-by-number ,number))))
+(define-second-focus-workspace-by-number (#\1 :mod-1) 1)
+(define-second-focus-workspace-by-number (#\2 :mod-1) 2)
+(define-second-focus-workspace-by-number (#\3 :mod-1) 3)
+(define-second-focus-workspace-by-number (#\4 :mod-1) 4)
+(define-second-focus-workspace-by-number (#\5 :mod-1) 5)
+(define-second-focus-workspace-by-number (#\6 :mod-1) 6)
+(define-second-focus-workspace-by-number (#\7 :mod-1) 7)
+(define-second-focus-workspace-by-number (#\8 :mod-1) 8)
+(define-second-focus-workspace-by-number (#\9 :mod-1) 9)
+(define-second-focus-workspace-by-number (#\0 :mod-1) 10)
+(define-second-key (#\1 :control :mod-1) 'renumber-workspaces)
+(define-second-key (#\2 :control :mod-1) 'sort-workspaces)
-(defun selection-menu ()
- "Selection menu"
- (info-mode-menu '((#\x cut-current-child)
- (#\c copy-current-child)
- (#\v paste-selection)
- (#\p paste-selection-no-clear)
- ("Delete" remove-current-child)
- (#\z clear-selection))))
-(defun utility-menu ()
- "Utility menu"
- (info-mode-menu '((#\i identify-key)
- (#\: eval-from-query-string)
- (#\! run-program-from-query-string))))
-
-(defun main-menu ()
- "Open the main menu"
- (info-mode-menu '((#\g group-menu)
- ;;(#\w window-menu)
- (#\s selection-menu)
- (#\n action-by-name-menu)
- (#\u action-by-number-menu)
- (#\y utility-menu))))
+(define-second-key ("Tab" :mod-1) 'rotate-window-up)
+(define-second-key ("Tab" :mod-1 :shift) 'rotate-window-down)
+(define-second-key (#\b) 'banish-pointer)
+(define-second-key (#\b :mod-1) 'toggle-maximize-current-group)
+(define-second-key (#\x) 'pager-mode)
-(define-second-key ("F1" :mod-1) 'help-on-second-mode)
-(define-second-key ("m") 'main-menu)
-(define-second-key ("g") 'group-menu)
-(define-second-key ("n") 'action-by-name-menu)
-(define-second-key ("u") 'action-by-number-menu)
+(define-second-key (#\k :mod-1) 'destroy-current-window)
+(define-second-key (#\k) 'remove-current-window)
-;;(define-second-key (#\g :control) 'stop-all-pending-actions)
+(define-second-key (#\g) 'create-new-default-group)
+(define-second-key (#\g :mod-1) 'remove-current-group)
-(define-second-key (#\i) 'identify-key)
-(define-second-key (#\:) 'eval-from-query-string)
+(define-second-key (#\w) 'create-new-default-workspace)
+(define-second-key (#\w :mod-1) 'remove-current-workspace)
-(define-second-key (#\!) 'run-program-from-query-string)
+(define-second-key (#\o)
+ (defun b-open-next-window-in-new-workspace ()
+ "Open the next window in a new workspace"
+ (setf *open-next-window-in-new-workspace* t)
+ (leave-second-mode)))
+(define-second-key (#\o :control)
+ (defun b-open-next-window-in-workspace-numbered ()
+ "Open the next window in a numbered workspace"
+ (let ((number (parse-integer (or (query-string "Open next window in workspace:") "")
+ :junk-allowed t)))
+ (when (numberp number)
+ (setf *open-next-window-in-new-workspace* number)))
+ (leave-second-mode)))
+
+
+(define-second-key (#\o :mod-1)
+ (defun b-open-next-window-in-new-group-once ()
+ "Open the next window in a new group and all others in the same group"
+ (setf *open-next-window-in-new-group* :once)
+ (leave-second-mode)))
+
+(define-second-key (#\o :mod-1 :control)
+ (defun b-open-next-window-in-new-group ()
+ "Open each next window in a new group"
+ (setf *open-next-window-in-new-group* t)
+ (leave-second-mode)))
+
+
+
+(defmacro define-shell (key name docstring cmd)
+ "Define a second key to start a shell command"
+ `(define-second-key ,key
+ (defun ,name ()
+ ,docstring
+ (setf *second-mode-program* ,cmd)
+ (leave-second-mode))))
+
+(define-shell (#\c) b-start-xterm "start an xterm" "exec xterm")
+(define-shell (#\e) b-start-emacs "start emacs" "exec emacs")
+(define-shell (#\e :control) b-start-emacsremote
+ "start an emacs for another user"
+ "exec emacsremote-Eterm")
+(define-shell (#\h) b-start-xclock "start an xclock" "exec xclock -d")
+
+
+(define-second-key (#\a) 'force-window-center-in-group)
+(define-second-key (#\a :mod-1) 'force-window-in-group)
+
+
+(define-second-key (#\d :mod-1)
+ (defun b-show-debuging-info ()
+ "Show debuging info"
+ (dbg *workspace-list*)
+ (dbg *screen*)
+ (dbg (query-tree *root*))))
+
+(define-second-key (#\t :control) 'tile-current-workspace-vertically)
+(define-second-key (#\t :shift :control) 'tile-current-workspace-horizontally)
+
+(define-second-key (#\y) 'tile-current-workspace-to)
+(define-second-key (#\y :mod-1) 'reconfigure-tile-workspace)
+(define-second-key (#\y :control) 'explode-current-group)
+(define-second-key (#\y :control :shift) 'implode-current-group)
+
+;;;,-----
+;;;| Moving/Resizing groups
+;;;`-----
+(define-second-key (#\p)
+ (defun b-pack-group-on-next-arrow ()
+ "Pack group on next arrow action"
+ (setf *arrow-action* :pack)))
+
+
+(defun fill-group-in-all-directions ()
+ "Fill group in all directions"
+ (fill-current-group-up)
+ (fill-current-group-left)
+ (fill-current-group-right)
+ (fill-current-group-down))
+
+
+(define-second-key (#\f)
+ (defun b-fill-group ()
+ "Fill group on next arrow action (fill in all directions on second f keypress)"
+ (case *arrow-action*
+ (:fill (fill-group-in-all-directions)
+ (setf *arrow-action* nil))
+ (t (setf *arrow-action* :fill)))))
+
+(define-second-key (#\f :mod-1) 'fill-group-in-all-directions)
+
+(define-second-key (#\f :shift)
+ (defun b-fill-group-vert ()
+ "Fill group vertically"
+ (fill-current-group-up)
+ (fill-current-group-down)))
+
+(define-second-key (#\f :control)
+ (defun b-fill-group-horiz ()
+ "Fill group horizontally"
+ (fill-current-group-left)
+ (fill-current-group-right)))
+
+
+(define-second-key (#\r)
+ (defun b-resize-half ()
+ "Resize group to its half width or heigth on next arraw action"
+ (setf *arrow-action* :resize-half)))
+
+
+(define-second-key (#\l) 'resize-minimal-current-group)
+(define-second-key (#\l :mod-1) 'resize-down-current-group)
+
+
+(define-second-key (#\m) 'center-current-group)
+
+
+(define-second-key ("Up")
+ (defun b-move-or-pack-up ()
+ "Move, pack, fill or resize group up"
+ (case *arrow-action*
+ (:pack (pack-current-group-up))
+ (:fill (fill-current-group-up))
+ (:resize-half (resize-half-height-up-current-group))
+ (t (move-group (current-group) 0 -10)))
+ (setf *arrow-action* nil)))
+
+(define-second-key ("Down")
+ (defun b-move-or-pack-down ()
+ "Move, pack, fill or resize group down"
+ (case *arrow-action*
+ (:pack (pack-current-group-down))
+ (:fill (fill-current-group-down))
+ (:resize-half (resize-half-height-down-current-group))
+ (t (move-group (current-group) 0 +10)))
+ (setf *arrow-action* nil)))
+
+(define-second-key ("Right")
+ (defun b-move-or-pack-right ()
+ "Move, pack, fill or resize group right"
+ (case *arrow-action*
+ (:pack (pack-current-group-right))
+ (:fill (fill-current-group-right))
+ (:resize-half (resize-half-width-right-current-group))
+ (t (move-group (current-group) +10 0)))
+ (setf *arrow-action* nil)))
+
+(define-second-key ("Left")
+ (defun b-move-or-pack-left ()
+ "Move, pack, fill or resize group left"
+ (case *arrow-action*
+ (:pack (pack-current-group-left))
+ (:fill (fill-current-group-left))
+ (:resize-half (resize-half-width-left-current-group))
+ (t (move-group (current-group) -10 0)))
+ (setf *arrow-action* nil)))
+
+
+(define-second-key ("Up" :shift)
+ (defun b-resize-up ()
+ "Resize group up"
+ (resize-group (current-group) 0 -10)))
+
+(define-second-key ("Down" :shift)
+ (defun b-resize-down ()
+ "Resize group down"
+ (resize-group (current-group) 0 +10)))
+
+(define-second-key ("Right" :shift)
+ (defun b-resize-right ()
+ "Resize group right"
+ (resize-group (current-group) +10 0)))
+
+(define-second-key ("Left" :shift)
+ (defun b-resize-left ()
+ "Resize group left"
+ (resize-group (current-group) -10 0)))
+
+
+;;;,-----
+;;;| Mouse second mode functions
+;;;`-----
+(defun select-group-under-mouse (root-x root-y)
+ (let ((group (find-group-under-mouse root-x root-y)))
+ (when group
+ (no-focus)
+ (focus-group group (current-workspace))
[809 lines skipped]
--- /project/clfswm/cvsroot/clfswm/bindings.lisp 2008/02/24 20:53:37 1.7
+++ /project/clfswm/cvsroot/clfswm/bindings.lisp 2008/05/02 19:56:08 1.8
@@ -1,7 +1,7 @@
;;; --------------------------------------------------------------------------
;;; CLFSWM - FullScreen Window Manager
;;;
-;;; #Date#: Sun Feb 24 21:34:48 2008
+;;; #Date#: Thu Jan 3 19:23:24 2008
;;;
;;; --------------------------------------------------------------------------
;;; Documentation: Bindings keys and mouse
@@ -33,141 +33,72 @@
;;;| CONFIG - Bindings main mode
;;;`-----
-
(define-main-key ("F1" :mod-1) 'help-on-clfswm)
(defun quit-clfswm ()
"Quit clfswm"
- (throw 'exit-main-loop nil))
+ (throw 'quit-main-loop nil))
+
+
(define-main-key ("Home" :mod-1 :control :shift) 'quit-clfswm)
-(define-main-key ("Right" :mod-1) 'select-next-brother)
-(define-main-key ("Left" :mod-1) 'select-previous-brother)
+(define-main-key (#\t :mod-1) 'second-key-mode)
+(define-main-key ("less" :control) 'second-key-mode)
+
+(define-main-key ("Tab" :mod-1) 'rotate-window-up)
+(define-main-key ("Tab" :mod-1 :shift) 'rotate-window-down)
-(define-main-key ("Down" :mod-1) 'select-next-level)
-(define-main-key ("Up" :mod-1) 'select-previous-level)
+(define-main-key (#\b :mod-1) 'banish-pointer)
+(define-main-key (#\b :mod-1 :control) 'toggle-maximize-current-group)
-(define-main-key ("Tab" :mod-1) 'select-next-child)
-(define-main-key ("Tab" :mod-1 :shift) 'select-previous-child)
+;; Escape
+(define-main-key ("Escape" :control :shift) 'delete-current-window)
+(define-main-key ("Escape" :mod-1 :control :shift) 'destroy-current-window)
+(define-main-key ("Escape" :control) 'remove-current-window)
+(define-main-key ("Escape" :shift) 'unhide-all-windows-in-current-group)
-(define-main-key ("Return" :mod-1) 'enter-group)
-(define-main-key ("Return" :mod-1 :shift) 'leave-group)
-(define-main-key ("Home" :mod-1) 'switch-to-root-group)
-(define-main-key ("Home" :mod-1 :shift) 'switch-and-select-root-group)
+;; Up
+(define-main-key ("Up" :mod-1) 'circulate-group-up)
+(define-main-key ("Up" :mod-1 :shift) 'circulate-group-up-move-window)
+(define-main-key ("Up" :mod-1 :shift :control) 'circulate-group-up-copy-window)
-(define-main-key ("Menu") 'toggle-show-root-group)
-(define-main-key (#\b :mod-1) 'banish-pointer)
+;; Down
+(define-main-key ("Down" :mod-1) 'circulate-group-down)
+(define-main-key ("Down" :mod-1 :shift) 'circulate-group-down-move-window)
+(define-main-key ("Down" :mod-1 :shift :control) 'circulate-group-down-copy-window)
-;;;; Escape
-(define-main-key ("Escape" :control :shift) 'delete-focus-window)
-(define-main-key ("Escape" :mod-1 :control :shift) 'destroy-focus-window)
-(define-main-key ("Escape" :control) 'remove-focus-window)
-(define-main-key ("Escape" :shift) 'unhide-all-windows-in-current-child)
+;; Right
+(define-main-key ("Right" :mod-1) 'circulate-workspace-up)
+(define-main-key ("Right" :mod-1 :shift) 'circulate-workspace-up-move-group)
+(define-main-key ("Right" :mod-1 :shift :control) 'circulate-workspace-up-copy-group)
+
+
+;; Left
+(define-main-key ("Left" :mod-1) 'circulate-workspace-down)
+(define-main-key ("Left" :mod-1 :shift) 'circulate-workspace-down-move-group)
+(define-main-key ("Left" :mod-1 :shift :control) 'circulate-workspace-down-copy-group)
-(define-main-key (#\t :mod-1) 'second-key-mode)
-(define-main-key ("less" :control) 'second-key-mode)
+(defmacro define-main-focus-workspace-by-number (key number)
+ "Define a main key to focus a workspace by its number"
+ `(define-main-key ,key
+ (defun ,(create-symbol (format nil "b-main-focus-workspace-~A" number)) ()
+ ,(format nil "Focus workspace ~A" number)
+ (circulate-workspace-by-number ,number))))
-;;(define-main-key ("a") (lambda ()
-;; (dbg 'key-a)
-;; (show-all-childs *root-group*)))
-;;
-;;(define-main-key ("b") (lambda ()
-;; (dbg 'key-b)
-;; (let* ((window (xlib:create-window :parent *root*
-;; :x 300
-;; :y 200
-;; :width 400
-;; :height 300
-;; :background (get-color "Black")
-;; :colormap (xlib:screen-default-colormap *screen*)
-;; :border-width 1
-;; :border (get-color "Red")
-;; :class :input-output
-;; :event-mask '(:exposure)))
-;; (gc (xlib:create-gcontext :drawable window
-;; :foreground (get-color "Green")
-;; :background (get-color "Red")
-;; :font *default-font*
-;; :line-style :solid)))
-;; (xlib:map-window window)
-;; (draw-line window gc 10 10 200 200)
-;; (xlib:display-finish-output *display*)
-;; (xlib:draw-glyphs window gc 10 10 (format nil "~A" 10))
-;; (dbg 'ici))))
-;;
-;;
-;;;;(define-main-key ("F1" :mod-1) 'help-on-clfswm)
-;;;;
-;;(defun quit-clfswm ()
-;; "Quit clfswm"
-;; (throw 'exit-main-loop nil))
-;;
-;;
-;;
-;;(define-main-key ("Home" :mod-1 :control :shift) 'quit-clfswm)
-;;
-;;(define-main-key (#\t :mod-1) 'second-key-mode)
-;;(define-main-key ("less" :control) 'second-key-mode)
-;;
-;;(define-main-key ("Tab" :mod-1) 'rotate-window-up)
-;;(define-main-key ("Tab" :mod-1 :shift) 'rotate-window-down)
-;;
-;;(define-main-key (#\b :mod-1) 'banish-pointer)
-;;(define-main-key (#\b :mod-1 :control) 'toggle-maximize-current-group)
-;;
-;;;; Escape
-;;(define-main-key ("Escape" :control :shift) 'delete-current-window)
-;;(define-main-key ("Escape" :mod-1 :control :shift) 'destroy-current-window)
-;;(define-main-key ("Escape" :control) 'remove-current-window)
-;;(define-main-key ("Escape" :shift) 'unhide-all-windows-in-current-group)
-;;
-;;
-;;;; Up
-;;(define-main-key ("Up" :mod-1) 'circulate-group-up)
-;;(define-main-key ("Up" :mod-1 :shift) 'circulate-group-up-move-window)
-;;(define-main-key ("Up" :mod-1 :shift :control) 'circulate-group-up-copy-window)
-;;
-;;
-;;;; Down
-;;(define-main-key ("Down" :mod-1) 'circulate-group-down)
-;;(define-main-key ("Down" :mod-1 :shift) 'circulate-group-down-move-window)
-;;(define-main-key ("Down" :mod-1 :shift :control) 'circulate-group-down-copy-window)
-;;
-;;
-;;;; Right
-;;(define-main-key ("Right" :mod-1) 'circulate-workspace-up)
-;;(define-main-key ("Right" :mod-1 :shift) 'circulate-workspace-up-move-group)
-;;(define-main-key ("Right" :mod-1 :shift :control) 'circulate-workspace-up-copy-group)
-;;
-;;
-;;;; Left
-;;(define-main-key ("Left" :mod-1) 'circulate-workspace-down)
-;;(define-main-key ("Left" :mod-1 :shift) 'circulate-workspace-down-move-group)
-;;(define-main-key ("Left" :mod-1 :shift :control) 'circulate-workspace-down-copy-group)
-;;
-;;
-;;
-;;(defmacro define-main-focus-workspace-by-number (key number)
-;; "Define a main key to focus a workspace by its number"
-;; `(define-main-key ,key
-;; (defun ,(create-symbol (format nil "b-main-focus-workspace-~A" number)) ()
-;; ,(format nil "Focus workspace ~A" number)
-;; (circulate-workspace-by-number ,number))))
-;;
-;;(define-main-focus-workspace-by-number (#\1 :mod-1) 1)
-;;(define-main-focus-workspace-by-number (#\2 :mod-1) 2)
-;;(define-main-focus-workspace-by-number (#\3 :mod-1) 3)
-;;(define-main-focus-workspace-by-number (#\4 :mod-1) 4)
-;;(define-main-focus-workspace-by-number (#\5 :mod-1) 5)
-;;(define-main-focus-workspace-by-number (#\6 :mod-1) 6)
-;;(define-main-focus-workspace-by-number (#\7 :mod-1) 7)
-;;(define-main-focus-workspace-by-number (#\8 :mod-1) 8)
-;;(define-main-focus-workspace-by-number (#\9 :mod-1) 9)
-;;(define-main-focus-workspace-by-number (#\0 :mod-1) 10)
+(define-main-focus-workspace-by-number (#\1 :mod-1) 1)
+(define-main-focus-workspace-by-number (#\2 :mod-1) 2)
+(define-main-focus-workspace-by-number (#\3 :mod-1) 3)
+(define-main-focus-workspace-by-number (#\4 :mod-1) 4)
+(define-main-focus-workspace-by-number (#\5 :mod-1) 5)
+(define-main-focus-workspace-by-number (#\6 :mod-1) 6)
+(define-main-focus-workspace-by-number (#\7 :mod-1) 7)
+(define-main-focus-workspace-by-number (#\8 :mod-1) 8)
+(define-main-focus-workspace-by-number (#\9 :mod-1) 9)
+(define-main-focus-workspace-by-number (#\0 :mod-1) 10)
--- /project/clfswm/cvsroot/clfswm/clfswm-info.lisp 2008/02/24 20:53:37 1.5
+++ /project/clfswm/cvsroot/clfswm/clfswm-info.lisp 2008/05/02 19:56:08 1.6
@@ -1,7 +1,7 @@
;;; --------------------------------------------------------------------------
;;; CLFSWM - FullScreen Window Manager
;;;
-;;; #Date#: Tue Feb 19 21:43:15 2008
+;;; #Date#: Fri Dec 21 23:00:04 2007
;;;
;;; --------------------------------------------------------------------------
;;; Documentation: Info function (see the end of this file for user definition
@@ -33,49 +33,49 @@
(defun leave-info-mode (info)
"Leave the info mode"
(declare (ignore info))
- (throw 'exit-info-loop nil))
+ (throw 'exit-info nil))
(defun mouse-leave-info-mode (root-x root-y info)
"Leave the info mode"
(declare (ignore root-x root-y info))
- (throw 'exit-info-loop nil))
+ (throw 'exit-info nil))
(defun draw-info-window (info)
- (xlib:clear-area (info-window info))
- (setf (xlib:gcontext-foreground (info-gc info)) (get-color *info-foreground*))
+ (clear-area (info-window info))
+ (setf (gcontext-foreground (info-gc info)) (get-color *info-foreground*))
(loop for line in (info-list info)
- for y from 0 do
- (xlib:draw-image-glyphs (info-window info) (info-gc info)
- (- (info-ilw info) (info-x info))
- (- (+ (* (info-ilh info) y) (info-ilh info)) (info-y info))
- (format nil "~A" line))))
+ for y from 0 do
+ (draw-image-glyphs (info-window info) (info-gc info)
+ (- (info-ilw info) (info-x info))
+ (- (+ (* (info-ilh info) y) (info-ilh info)) (info-y info))
+ (format nil "~A" line))))
(defun draw-info-window-partial (info)
(let ((last-y (info-y info)))
- (setf (xlib:gcontext-foreground (info-gc info)) (get-color *info-background*))
- (xlib:draw-rectangle (info-window info) (info-gc info) 0 0
- (xlib:drawable-width (info-window info))
- (max (+ (- (info-y info)) (xlib:max-char-ascent (info-font info))) 0) t)
+ (setf (gcontext-foreground (info-gc info)) (get-color *info-background*))
+ (draw-rectangle (info-window info) (info-gc info) 0 0
+ (drawable-width (info-window info))
+ (max (+ (- (info-y info)) (max-char-ascent (info-font info))) 0) t)
(loop for line in (info-list info)
- for y from 0 do
- (setf last-y (- (+ (* (info-ilh info) y) (info-ilh info)) (info-y info)))
- (setf (xlib:gcontext-foreground (info-gc info)) (get-color *info-background*))
- (xlib:draw-rectangle (info-window info) (info-gc info)
- 0 (+ last-y (- (info-ilh info)) (xlib:max-char-descent (info-font info)))
- (xlib:drawable-width (info-window info)) (info-ilh info) t)
- (setf (xlib:gcontext-foreground (info-gc info)) (get-color *info-foreground*))
- (xlib:draw-image-glyphs (info-window info) (info-gc info)
- (- (info-ilw info) (info-x info))
- last-y
- (format nil "~A" line)))
- (setf (xlib:gcontext-foreground (info-gc info)) (get-color *info-background*))
- (xlib:draw-rectangle (info-window info) (info-gc info) 0 last-y
- (xlib:drawable-width (info-window info))
- (xlib:drawable-height (info-window info))
- t)))
+ for y from 0 do
+ (setf last-y (- (+ (* (info-ilh info) y) (info-ilh info)) (info-y info)))
+ (setf (gcontext-foreground (info-gc info)) (get-color *info-background*))
+ (draw-rectangle (info-window info) (info-gc info)
+ 0 (+ last-y (- (info-ilh info)) (max-char-descent (info-font info)))
+ (drawable-width (info-window info)) (info-ilh info) t)
+ (setf (gcontext-foreground (info-gc info)) (get-color *info-foreground*))
+ (draw-image-glyphs (info-window info) (info-gc info)
+ (- (info-ilw info) (info-x info))
+ last-y
+ (format nil "~A" line)))
+ (setf (gcontext-foreground (info-gc info)) (get-color *info-background*))
+ (draw-rectangle (info-window info) (info-gc info) 0 last-y
+ (drawable-width (info-window info))
+ (drawable-height (info-window info))
+ t)))
;;;,-----
@@ -129,7 +129,7 @@
(defun info-end-line (info)
"Move to last line"
(setf (info-x info) 0
- (info-y info) (- (* (length (info-list info)) (info-ilh info)) (xlib:drawable-height (info-window info))))
+ (info-y info) (- (* (length (info-list info)) (info-ilh info)) (drawable-height (info-window info))))
(draw-info-window info)))
@@ -206,35 +206,35 @@
(when info-list
(let* ((pointer-grabbed (xgrab-pointer-p))
(keyboard-grabbed (xgrab-keyboard-p))
- (font (xlib:open-font *display* *info-font-string*))
- (ilw (xlib:max-char-width font))
- (ilh (+ (xlib:max-char-ascent font) (xlib:max-char-descent font) 1))
- (window (xlib:create-window :parent *root*
- :x x :y y
- :width (or width
- (min (* (+ (loop for l in info-list maximize (length l)) 2) ilw)
- (- (xlib:screen-width *screen*) 2 x)))
- :height (or height
- (min (+ (* (length info-list) ilh) (/ ilh 2))
- (- (xlib:screen-height *screen*) 2 y)))
- :background (get-color *info-background*)
- :colormap (xlib:screen-default-colormap *screen*)
- :border-width 1
- :border (get-color *info-border*)
- :event-mask '(:exposure)))
- (gc (xlib:create-gcontext :drawable window
- :foreground (get-color *info-foreground*)
- :background (get-color *info-background*)
- :font font
- :line-style :solid))
+ (font (open-font *display* *info-font-string*))
+ (ilw (max-char-width font))
+ (ilh (+ (max-char-ascent font) (max-char-descent font) 1))
+ (window (create-window :parent *root*
+ :x x :y y
+ :width (or width
+ (min (* (+ (loop for l in info-list maximize (length l)) 2) ilw)
+ (- (screen-width *screen*) 2 x)))
+ :height (or height
+ (min (+ (* (length info-list) ilh) (/ ilh 2))
+ (- (screen-height *screen*) 2 y)))
+ :background (get-color *info-background*)
+ :colormap (screen-default-colormap *screen*)
+ :border-width 1
+ :border (get-color *info-border*)
+ :event-mask '(:exposure)))
+ (gc (create-gcontext :drawable window
+ :foreground (get-color *info-foreground*)
+ :background (get-color *info-background*)
+ :font font
+ :line-style :solid))
(info (make-info :window window :gc gc :x 0 :y 0 :list info-list
- :font font :ilw ilw :ilh ilh)))
+ :font font :ilw ilw :ilh ilh)))
(labels ((handle-key (&rest event-slots &key root code state &allow-other-keys)
(declare (ignore event-slots root))
(funcall-key-from-code *info-keys* code state info))
(handle-motion-notify (&rest event-slots &key root-x root-y &allow-other-keys)
(declare (ignore event-slots))
- (unless (xlib:event-case (*display* :discard-p nil :peek-p t :timeout 0)
+ (unless (event-case (*display* :discard-p nil :peek-p t :timeout 0)
(:motion-notify () t))
(funcall-button-from-code *info-mouse-action* 'motion 0 root-x root-y #'first info)))
(handle-button-press (&rest event-slots &key root-x root-y code state &allow-other-keys)
@@ -243,12 +243,18 @@
(handle-button-release (&rest event-slots &key root-x root-y code state &allow-other-keys)
(declare (ignore event-slots))
(funcall-button-from-code *info-mouse-action* code state root-x root-y #'third info))
- (info-handle-unmap-notify (&rest event-slots)
- (apply #'handle-unmap-notify event-slots)
- (draw-info-window info))
- (info-handle-destroy-notify (&rest event-slots)
- (apply #'handle-destroy-notify event-slots)
- (draw-info-window info))
+ (handle-unmap-notify (&rest event-slots &key send-event-p event-window window &allow-other-keys)
+ (declare (ignore event-slots))
+ (unless (and (not send-event-p)
+ (not (window-equal window event-window)))
+ (remove-window-in-all-workspace window)
+ (draw-info-window info)))
+ (handle-destroy-notify (&rest event-slots &key send-event-p event-window window &allow-other-keys)
+ (declare (ignore event-slots))
+ (unless (or send-event-p
+ (window-equal event-window window))
+ (remove-window-in-all-workspace window)
+ (draw-info-window info)))
(handle-events (&rest event-slots &key display event-key &allow-other-keys)
(declare (ignore display))
(case event-key
@@ -257,33 +263,33 @@
(:button-release (apply #'handle-button-release event-slots) t)
(:motion-notify (apply #'handle-motion-notify event-slots) t)
(:map-request nil)
- (:unmap-notify (apply #'info-handle-unmap-notify event-slots) t)
- (:destroy-notify (apply #'info-handle-destroy-notify event-slots) t)
+ (:unmap-notify (apply #'handle-unmap-notify event-slots) t)
+ (:destroy-notify (apply #'handle-destroy-notify event-slots) t)
(:mapping-notify nil)
(:property-notify nil)
(:create-notify nil)
(:enter-notify nil)
(:exposure (draw-info-window info)))
t))
- (xlib:map-window window)
+ (map-window window)
(draw-info-window info)
(xgrab-pointer *root* 68 69)
(unless keyboard-grabbed
(xgrab-keyboard *root*))
(unwind-protect
- (catch 'exit-info-loop
+ (catch 'exit-info
(loop
- (xlib:display-finish-output *display*)
- (xlib:process-event *display* :handler #'handle-events)))
+ (display-finish-output *display*)
+ (process-event *display* :handler #'handle-events)))
(if pointer-grabbed
(xgrab-pointer *root* 66 67)
(xungrab-pointer))
(unless keyboard-grabbed
(xungrab-keyboard))
- (xlib:free-gcontext gc)
- (xlib:destroy-window window)
- (xlib:close-font font)
- (show-all-childs)
+ (free-gcontext gc)
+ (destroy-window window)
+ (close-font font)
+ (show-all-group (current-workspace))
(wait-no-key-or-button-press))))))
@@ -305,12 +311,12 @@
(lambda (&optional args)
(declare (ignore args))
(setf action function)
- (throw 'exit-info-loop nil)))))
+ (throw 'exit-info nil)))))
(info-mode (nreverse info-list) :x x :y y :width width :height height)
(dolist (item item-list)
(let ((key (first item)))
(undefine-info-key-fun (list key 0))))
- (when (fboundp action)
+ (when action
(funcall action))))
@@ -324,9 +330,9 @@
"Append spaces before Newline on each line"
(with-output-to-string (stream)
(loop for c across string do
- (when (equal c #\Newline)
- (princ " " stream))
- (princ c stream))))
+ (when (equal c #\Newline)
+ (princ " " stream))
+ (princ c stream))))
(defun show-key-binding (&rest hash-table-key)
@@ -340,6 +346,7 @@
(defun show-global-key-binding ()
"Show all key binding"
(show-key-binding *main-keys* *second-keys* *mouse-action*
+ *pager-keys* *pager-mouse-action*
*info-keys* *info-mouse-action*))
(defun show-main-mode-key-binding ()
@@ -351,6 +358,12 @@
(show-key-binding *second-keys* *mouse-action*))
+(defun show-pager-key-binding ()
+ "Show the pager mode key binding"
+ (show-key-binding *pager-keys* *pager-mouse-action*))
+
+
+
(let ((days '("Lundi" "Mardi" "Mercredi" "Jeudi" "Vendredi" "Samedi" "Dimanche"))
(months '("Janvier" "Fevrier" "Mars" "Avril" "Mai" "Juin" "Juillet"
"Aout" "Septembre" "Octobre" "Novembre" "Decembre")))
@@ -367,15 +380,18 @@
(info-mode (list (date-string))))
-
+(defun show-date-pager ()
+ "Show the current time and date"
+ (pager-draw-display)
+ (info-mode (list (date-string))))
(defun info-on-shell (program)
(let ((lines (do-shell program nil t)))
(info-mode (loop for line = (read-line lines nil nil)
- while line
- collect line))))
+ while line
+ collect line))))
(defun show-cpu-proc ()
@@ -440,5 +456,11 @@
+(defun help-on-pager ()
+ "Open the help and info window"
+ (info-mode-menu '((#\h show-global-key-binding)
+ (#\b show-pager-key-binding)
+ (#\t show-date-pager)))
+ (pager-draw-display))
--- /project/clfswm/cvsroot/clfswm/clfswm-internal.lisp 2008/02/29 23:05:56 1.18
+++ /project/clfswm/cvsroot/clfswm/clfswm-internal.lisp 2008/05/02 19:56:08 1.19
@@ -1,7 +1,7 @@
;;; --------------------------------------------------------------------------
;;; CLFSWM - FullScreen Window Manager
;;;
-;;; #Date#: Sat Mar 1 00:03:14 2008
+;;; #Date#: Thu Jan 3 23:09:04 2008
;;;
;;; --------------------------------------------------------------------------
;;; Documentation: Main functions
@@ -29,7 +29,7 @@
;;; Minimal hook
-(defun call-hook (hook &optional args)
+(defun call-hook (hook args)
"Call a hook (a function, a symbol or a list of function)"
(typecase hook
(list (dolist (h hook)
@@ -37,540 +37,265 @@
(t (apply hook args))))
-;;; Group data manipulation functions
-(defun group-data-slot (group slot)
- "Return the value associated to data slot"
- (when (group-p group)
- (second (assoc slot (group-data group)))))
-(defun set-group-data-slot (group slot value)
- "Set the value associated to data slot"
- (when (group-p group)
- (with-slots (data) group
- (setf data (remove (assoc slot data) data))
- (push (list slot value) data))
- value))
+;;; CLFSWM internal functions
+(defun create-default-workspace (&optional number)
+ (make-workspace :number (or number (incf *current-workspace-number*))))
+
+
+(defun get-group-size (group)
+ (if (group-fullscreenp group)
+ (destructuring-bind (x y width height) *fullscreen*
+ (values x y width height))
+ (values (group-x group)
+ (group-y group)
+ (group-width group)
+ (group-height group))))
+
+
+(defun select-minimum-workspace ()
+ "Rotate the workspace list until the smallest workspace is selected"
+ (let ((min-number (loop for w in *workspace-list*
+ minimize (workspace-number w))))
+ (when min-number
+ (loop while (and (workspace-p (first *workspace-list*))
+ (/= (workspace-number (first *workspace-list*)) min-number))
+ do (setf *workspace-list* (rotate-list *workspace-list*))))))
+
+
+
+(defun adapt-window-to-group (window group)
+ (handler-case
+ (when (and window group)
+ (unhide-window window)
+ (multiple-value-bind (x y width height)
+ (get-group-size group)
+ (case (window-type window)
+ (:normal
+ (setf/= (drawable-x window) x)
+ (setf/= (drawable-y window) y)
+ (setf/= (drawable-width window) width)
+ (setf/= (drawable-height window) height)))))
+ ((or match-error window-error drawable-error) (c)
+ (declare (ignore c)))))
+ ;;(dbg "Adapt error" c))))
-(defsetf group-data-slot set-group-data-slot)
+
+(defun adapt-all-window-in-group (group)
+ (when group
+ (dolist (window (group-window-list group))
+ (adapt-window-to-group window group))))
-(defgeneric group-p (group))
-(defmethod group-p ((group group))
- (declare (ignore group))
- t)
-(defmethod group-p (group)
- (declare (ignore group))
- nil)
+(defun adapt-all-window-in-workspace (workspace)
+ "Adapt all window to groups in workspace"
+ (dolist (group (workspace-group-list workspace))
+ (adapt-all-window-in-group group)))
+(defun add-window-in-group (window group)
+ (when (and window group)
+ (pushnew window (group-window-list group))
+ (adapt-window-to-group window group)
+ window))
-(defgeneric child-name (child))
+(defun add-group-in-workspace (group workspace)
+ (when group
+ (pushnew group (workspace-group-list workspace))
+ group))
-(defmethod child-name ((child xlib:window))
- (xlib:wm-name child))
-(defmethod child-name ((child group))
- (group-name child))
-(defmethod child-name (child)
- (declare (ignore child))
- "???")
+(defun add-workspace (workspace)
+ (when workspace
+ (select-minimum-workspace)
+ (setf *workspace-list* (anti-rotate-list (append *workspace-list* (list workspace))))
+ (netwm-update-desktop-property)
+ workspace))
-;; (with-all-childs (*root-group* child) (typecase child (xlib:window (print child)) (group (print (group-number child)))))
-(defmacro with-all-childs ((root child) &body body)
- (let ((rec (gensym))
- (sub-child (gensym)))
- `(labels ((,rec (,child)
- , at body
- (when (group-p ,child)
- (dolist (,sub-child (group-child ,child))
- (,rec ,sub-child)))))
- (,rec ,root))))
+(defun remove-window-in-group (window group)
+ (setf (group-window-list group)
+ (remove window (group-window-list group))))
+(defun remove-window-in-workspace (window workspace)
+ (dolist (group (workspace-group-list workspace))
+ (remove-window-in-group window group)))
-;; (with-all-group (*root-group* group) (print (group-number group)))
-(defmacro with-all-groups ((root group) &body body)
- (let ((rec (gensym))
- (child (gensym)))
- `(labels ((,rec (,group)
- (when (group-p ,group)
- , at body
- (dolist (,child (group-child ,group))
- (,rec ,child)))))
- (,rec ,root))))
+(defun remove-window-in-all-workspace (window)
+ (dolist (workspace *workspace-list*)
+ (remove-window-in-workspace window workspace))
+ (netwm-remove-in-client-list window))
-;; (with-all-windows (*root-group* window) (print window))
-(defmacro with-all-windows ((root window) &body body)
- (let ((rec (gensym))
- (child (gensym)))
- `(labels ((,rec (,window)
- (when (xlib:window-p ,window)
- , at body)
- (when (group-p ,window)
- (dolist (,child (group-child ,window))
- (,rec ,child)))))
- (,rec ,root))))
+(defun remove-group-in-workspace (group workspace)
+ (setf (workspace-group-list workspace)
+ (remove group (workspace-group-list workspace))))
+(defun remove-group-in-all-workspace (group)
+ (dolist (workspace *workspace-list*)
+ (remove-group-in-workspace group workspace)))
+(defun remove-workspace (workspace)
+ (setf *workspace-list* (remove workspace *workspace-list*))
+ (netwm-update-desktop-property))
-;; (with-all-groups-windows (*root-group* child) (print child) (print (group-number child)))
-(defmacro with-all-windows-groups ((root child) body-window body-group)
- (let ((rec (gensym))
- (sub-child (gensym)))
- `(labels ((,rec (,child)
- (typecase ,child
- (xlib:window ,body-window)
- (group ,body-group
- (dolist (,sub-child (group-child ,child))
- (,rec ,sub-child))))))
- (,rec ,root))))
+(defun current-workspace ()
+ (if (consp *workspace-list*)
+ (first *workspace-list*)
+ (add-workspace (create-default-workspace))))
-(defun group-find-free-number ()
- (let ((all-numbers nil))
- (with-all-groups (*root-group* group)
- (push (group-number group) all-numbers))
- (find-free-number all-numbers)))
+(defun current-group ()
+ (let ((current-workspace (current-workspace)))
+ (when current-workspace
+ (let ((group-list (workspace-group-list current-workspace)))
+ (if (consp group-list)
+ (first group-list)
+ (add-group-in-workspace (copy-group *default-group*) current-workspace))))))
+(defun current-window ()
+ (let ((current-group (current-group)))
+ (when current-group
+ (let ((window-list (group-window-list current-group)))
+ (when (consp window-list)
+ (first window-list))))))
-(defun create-group (&key name (number (group-find-free-number)) (x 0.1) (y 0.1) (w 0.8) (h 0.8) layout)
- (let* ((window (xlib:create-window :parent *root*
- :x 0
- :y 0
- :width 200
- :height 200
- :background (get-color "Black")
- :colormap (xlib:screen-default-colormap *screen*)
- :border-width 1
- :border (get-color "Red")
- :event-mask '(:exposure :button-press)))
- (gc (xlib:create-gcontext :drawable window
- :foreground (get-color "Green")
- :background (get-color "Black")
- :font *default-font*
- :line-style :solid)))
- (make-instance 'group :name name :number number
- :x x :y y :w w :h h :window window :gc gc :layout layout)))
-(defun add-group (group father)
- (push group (group-child father)))
+(defun hide-group (root group)
+ (multiple-value-bind (x y width height)
+ (get-group-size group)
+ (clear-area root :x (1- x) :y (1- y) :width (+ width 2) :height (+ height 2))))
+(defun show-group (root gc group)
+ (when (and gc group)
+ (handler-case
+ (multiple-value-bind (x y width height)
+ (get-group-size group)
+ (setf (gcontext-foreground gc)
+ (get-color (if (eql group (current-group))
+ *color-selected*
+ *color-unselected*)))
+ (draw-rectangle root gc (1- x) (1- y) (1+ width) (1+ height))
+ (draw-line root gc x y (+ x width) (+ y height))
+ (draw-line root gc x (+ y height) (+ x width) y))
+ ((or match-error window-error drawable-error) (c)
+ (declare (ignore c))))))
-(defun get-current-child ()
- "Return the current focused child"
- (unless (equal *current-child* *root-group*)
- (typecase *current-child*
- (xlib:window *current-child*)
- (group (if (xlib:window-p (first (group-child *current-child*)))
- (first (group-child *current-child*))
- *current-child*)))))
-(defun find-child (to-find root)
- "Find to-find in root or in its childs"
- (with-all-childs (root child)
- (when (equal child to-find)
- (return-from find-child t))))
+(defun show-all-group (workspace &optional (root *root*) (gc *root-gc*) (clear-all :hide-each))
+ "Show all groups in workspace
+clear-all: nil=do not clear; t=clear all root window; :hide-each=clear each group before redrawing"
+ (handler-case
+ (progn
+ (when clear-all
+ (clear-area root))
+ (dolist (group (reverse (workspace-group-list workspace)))
+ (when (eql clear-all :hide-each)
+ (hide-group root group))
+ (show-group root gc group)))
+ ((or match-error window-error drawable-error) (c)
+ (declare (ignore c)))))
+;;(dbg "Show all group" c))))
-(defun find-father-group (to-find &optional (root *root-group*))
- "Return the father group of to-find"
- (with-all-groups (root group)
- (when (member to-find (group-child group))
- (return-from find-father-group group))))
-
+(defun hide-all-windows-in-workspace (workspace)
+ "Hide all windows in a workspace"
+ (no-focus)
+ (setf *open-next-window-in-new-workspace* nil)
+ (dolist (group (workspace-group-list workspace))
+ (dolist (window (group-window-list group))
+ (hide-window window))))
-(defun find-group-window (window &optional (root *root-group*))
- "Return the group with the window window"
- (with-all-groups (root group)
- (when (xlib:window-equal window (group-window group))
- (return-from find-group-window group))))
+(defun show-all-windows-in-workspace (workspace)
+ "Show all windows in a workspace"
+ (dolist (group (workspace-group-list workspace))
+ (dolist (window (group-window-list group))
+ (unhide-window window)
+ (adapt-window-to-group window group))
+ (raise-window (first (group-window-list group))))
+ (adapt-window-to-group (current-window) (current-group))
+ (focus-window (current-window))
+ (show-all-group (current-workspace)))
-(defun find-group-by-name (name)
- "Find a group from its name"
- (when name
- (with-all-groups (*root-group* group)
- (when (string-equal name (group-name group))
- (return-from find-group-by-name group)))))
-(defun find-group-by-number (number)
- "Find a group from its number"
- (when (numberp number)
- (with-all-groups (*root-group* group)
- (when (= number (group-number group))
- (return-from find-group-by-number group)))))
+(defun find-window-group (window workspace)
+ "Find the group where the window window is"
+ (dolist (group (workspace-group-list workspace))
+ (when (member window (group-window-list group))
+ (return-from find-window-group group))))
+(defun get-all-windows ()
+ "Return a list with all known windows in all workspace"
+ (let ((acc nil))
+ (dolist (workspace *workspace-list*)
+ (dolist (group (workspace-group-list workspace))
+ (dolist (window (group-window-list group))
+ (pushnew window acc))))
+ (reverse acc)))
-(defun get-all-windows (&optional (root *root-group*))
- "Return all windows in root and in its childs"
+(defun get-all-windows-in-workspace (workspace)
+ "Return a list with all known windows in workspace"
(let ((acc nil))
- (with-all-windows (root window)
- (push window acc))
+ (dolist (group (workspace-group-list workspace))
+ (dolist (window (group-window-list group))
+ (pushnew window acc)))
acc))
-(defun get-hidden-windows ()
- "Return all hiddens windows"
- (let ((all-windows (get-all-windows))
- (hidden-windows (remove-if-not #'window-hidden-p
- (copy-list (xlib:query-tree *root*)))))
- (set-difference hidden-windows all-windows)))
-
-
-
-
-(defun display-group-info (group)
- (let ((dy (+ (xlib:max-char-ascent *default-font*) (xlib:max-char-descent *default-font*))))
- (with-slots (name number gc window child) group
- (when (equal group *current-root*)
- (xlib:clear-area window))
- (xlib:with-gcontext (gc :foreground (get-color (if (and (equal group *current-root*)
- (equal group *current-child*))
- "Red" "Green")))
- (xlib:draw-image-glyphs window gc 5 dy
- (format nil "Group: ~A~A "
[522 lines skipped]
--- /project/clfswm/cvsroot/clfswm/clfswm-keys.lisp 2008/02/24 20:53:37 1.6
+++ /project/clfswm/cvsroot/clfswm/clfswm-keys.lisp 2008/05/02 19:56:08 1.7
@@ -1,7 +1,7 @@
;;; --------------------------------------------------------------------------
;;; CLFSWM - FullScreen Window Manager
;;;
-;;; #Date#: Tue Feb 12 19:23:14 2008
+;;; #Date#: Thu Jan 3 19:24:00 2008
;;;
;;; --------------------------------------------------------------------------
;;; Documentation: Keys functions definition
@@ -47,20 +47,20 @@
(undefine-name (create-symbol "undefine-" name "-key"))
(undefine-multi-name (create-symbol "undefine-" name "-multi-keys")))
`(progn
- (defun ,name-key-fun (key function &optional keystring)
- "Define a new key, a key is '(char '(modifier list))"
- (setf (gethash key ,hashtable) (list function keystring)))
+ (defun ,name-key-fun (key function &optional keystring)
+ "Define a new key, a key is '(char '(modifier list))"
+ (setf (gethash key ,hashtable) (list function keystring)))
- (defmacro ,name-key ((key &rest modifiers) function &optional keystring)
- `(,',name-key-fun (list ,key ,(modifiers->state modifiers)) ,function ,keystring))
+ (defmacro ,name-key ((key &rest modifiers) function &optional keystring)
+ `(,',name-key-fun (list ,key ,(modifiers->state modifiers)) ,function ,keystring))
- (defmacro ,undefine-name ((key &rest modifiers))
- `(remhash (list ,key ,(modifiers->state modifiers)) ,',hashtable))
+ (defmacro ,undefine-name ((key &rest modifiers))
+ `(remhash (list ,key ,(modifiers->state modifiers)) ,',hashtable))
- (defmacro ,undefine-multi-name (&rest keys)
- `(progn
- ,@(loop for k in keys
- collect `(,',undefine-name ,k)))))))
+ (defmacro ,undefine-multi-name (&rest keys)
+ `(progn
+ ,@(loop for k in keys
+ collect `(,',undefine-name ,k)))))))
(defmacro define-define-mouse (name hashtable)
@@ -68,15 +68,15 @@
(name-mouse (create-symbol "define-" name))
(undefine-name (create-symbol "undefine-" name)))
`(progn
- (defun ,name-mouse-fun (button function-press &optional keystring function-release)
- "Define a new mouse button action, a button is '(button number '(modifier list))"
- (setf (gethash button ,hashtable) (list function-press keystring function-release)))
+ (defun ,name-mouse-fun (button function-press &optional keystring function-release)
+ "Define a new mouse button action, a button is '(button number '(modifier list))"
+ (setf (gethash button ,hashtable) (list function-press keystring function-release)))
- (defmacro ,name-mouse ((button &rest modifiers) function-press &optional function-release keystring)
- `(,',name-mouse-fun (list ,button ,(modifiers->state modifiers)) ,function-press ,keystring ,function-release))
+ (defmacro ,name-mouse ((button &rest modifiers) function-press &optional function-release keystring)
+ `(,',name-mouse-fun (list ,button ,(modifiers->state modifiers)) ,function-press ,keystring ,function-release))
- (defmacro ,undefine-name ((key &rest modifiers))
- `(remhash (list ,key ,(modifiers->state modifiers)) ,',hashtable)))))
+ (defmacro ,undefine-name ((key &rest modifiers))
+ `(remhash (list ,key ,(modifiers->state modifiers)) ,',hashtable)))))
@@ -105,77 +105,27 @@
(defmacro define-ungrab/grab (name function hashtable)
`(defun ,name ()
- (maphash #'(lambda (k v)
- (declare (ignore v))
- (when (consp k)
- (handler-case
- (let* ((key (first k))
- (keycode (typecase key
- (character (char->keycode key))
- (number key)
- (string (let ((keysym (keysym-name->keysym key)))
- (and keysym (xlib:keysym->keycodes *display* keysym)))))))
- (if keycode
- (,function *root* keycode :modifiers (second k))
- (format t "~&Grabbing error: Can't find key '~A'~%" key)))
- (error (c)
- ;;(declare (ignore c))
- (format t "~&Grabbing error: Can't grab key '~A' (~A)~%" k c)))
- (force-output)))
- ,hashtable)))
-
-(define-ungrab/grab grab-main-keys xlib:grab-key *main-keys*)
-(define-ungrab/grab ungrab-main-keys xlib:ungrab-key *main-keys*)
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-(defun funcall-key-from-code (hash-table-key code state &optional args)
- (labels ((funcall-from (key)
- (multiple-value-bind (function foundp)
- (gethash (list key state) hash-table-key)
- (when (and foundp (first function))
- (if args
- (funcall (first function) args)
- (funcall (first function)))
- t)))
- (from-code ()
- (funcall-from code))
- (from-char ()
- (let ((char (keycode->char code state)))
- (funcall-from char)))
- (from-string ()
- (let ((string (keysym->keysym-name (xlib:keycode->keysym *display* code 0))))
- (funcall-from string))))
- (cond ((from-code))
- ((from-char))
- ((from-string)))))
-
-
-
-(defun funcall-button-from-code (hash-table-key code state root-x root-y
- &optional (action #'first) args)
- "Action: first=press third=release"
- (let ((state (modifiers->state (set-difference (state->modifiers state)
- '(:button-1 :button-2 :button-3 :button-4 :button-5)))))
- (multiple-value-bind (function foundp)
- (gethash (list code state) hash-table-key)
- (if (and foundp (funcall action function))
- (if args
- (funcall (funcall action function) root-x root-y args)
- (funcall (funcall action function) root-x root-y))
- t))))
+ (maphash #'(lambda (k v)
+ (declare (ignore v))
+ (when (consp k)
+ (handler-case
+ (let* ((key (first k))
+ (keycode (typecase key
+ (character (char->keycode key))
+ (number key)
+ (string (let ((keysym (keysym-name->keysym key)))
+ (and keysym (keysym->keycodes *display* keysym)))))))
+ (if keycode
+ (,function *root* keycode :modifiers (second k))
+ (format t "~&Grabbing error: Can't find key '~A'~%" key)))
+ (error (c)
+ ;;(declare (ignore c))
+ (format t "~&Grabbing error: Can't grab key '~A' (~A)~%" k c)))
+ (force-output)))
+ ,hashtable)))
+(define-ungrab/grab grab-main-keys grab-key *main-keys*)
+(define-ungrab/grab ungrab-main-keys ungrab-key *main-keys*)
@@ -195,8 +145,8 @@
(produce-keys (hk)
`("table class=\"ex\" cellspacing=\"5\" border=\"0\" width=\"100%\""
(tr ("th align=\"right\" width=\"10%\"" "Modifiers")
- ("th align=\"center\" width=\"10%\"" "Key/Button")
- ("th align=\"left\"" "Function"))
+ ("th align=\"center\" width=\"10%\"" "Key/Button")
+ ("th align=\"left\"" "Function"))
,@(let ((acc nil))
(maphash #'(lambda (k v)
(when (consp k)
--- /project/clfswm/cvsroot/clfswm/clfswm-pack.lisp 2008/02/24 20:53:37 1.5
+++ /project/clfswm/cvsroot/clfswm/clfswm-pack.lisp 2008/05/02 19:56:08 1.6
@@ -1,7 +1,7 @@
;;; --------------------------------------------------------------------------
;;; CLFSWM - FullScreen Window Manager
;;;
-;;; #Date#: Tue Feb 12 14:02:45 2008
+;;; #Date#: Fri Dec 28 22:13:42 2007
;;;
;;; --------------------------------------------------------------------------
;;; Documentation: Tile, pack and fill functions
@@ -34,14 +34,14 @@
"Tile a workspace vertically"
(let* ((len (max (length (workspace-group-list workspace)) 1))
(n (ceiling (sqrt len)))
- (dx (/ (xlib:screen-width *screen*) n))
- (dy (/ (xlib:screen-height *screen*) (ceiling (/ len n)))))
+ (dx (/ (screen-width *screen*) n))
+ (dy (/ (screen-height *screen*) (ceiling (/ len n)))))
(loop for group in (workspace-group-list workspace)
- for i from 0 do
- (setf (group-x group) (1+ (truncate (* (mod i n) dx)))
- (group-y group) (1+ (truncate (* (truncate (/ i n)) dy)))
- (group-width group) (- (truncate dx) 2)
- (group-height group) (- (truncate dy) 2)))))
+ for i from 0 do
+ (setf (group-x group) (1+ (truncate (* (mod i n) dx)))
+ (group-y group) (1+ (truncate (* (truncate (/ i n)) dy)))
+ (group-width group) (- (truncate dx) 2)
+ (group-height group) (- (truncate dy) 2)))))
(defun tile-current-workspace-vertically ()
@@ -56,14 +56,14 @@
"Tile a workspace horizontally"
(let* ((len (max (length (workspace-group-list workspace)) 1))
(n (ceiling (sqrt len)))
- (dx (/ (xlib:screen-width *screen*) (ceiling (/ len n))))
- (dy (/ (xlib:screen-height *screen*) n)))
+ (dx (/ (screen-width *screen*) (ceiling (/ len n))))
+ (dy (/ (screen-height *screen*) n)))
(loop for group in (workspace-group-list workspace)
- for i from 0 do
- (setf (group-x group) (1+ (truncate (* (truncate (/ i n)) dx)))
- (group-y group) (1+ (truncate (* (mod i n) dy)))
- (group-width group) (- (truncate dx) 2)
- (group-height group) (- (truncate dy) 2)))))
+ for i from 0 do
+ (setf (group-x group) (1+ (truncate (* (truncate (/ i n)) dx)))
+ (group-y group) (1+ (truncate (* (mod i n) dy)))
+ (group-width group) (- (truncate dx) 2)
+ (group-height group) (- (truncate dy) 2)))))
(defun tile-current-workspace-horizontally ()
@@ -80,19 +80,19 @@
(if (<= len 1)
(setf (group-x group) 0
(group-y group) 0
- (group-width group) (xlib:screen-width *screen*)
- (group-height group) (xlib:screen-height *screen*))
- (let ((dy (/ (xlib:screen-height *screen*) (1- len))))
+ (group-width group) (screen-width *screen*)
+ (group-height group) (screen-height *screen*))
+ (let ((dy (/ (screen-height *screen*) (1- len))))
(setf (group-x group) 1
(group-y group) 1
- (group-width group) (- (xlib:screen-width *screen*) *tile-border-size* 1)
- (group-height group) (- (xlib:screen-height *screen*) 1))
+ (group-width group) (- (screen-width *screen*) *tile-border-size* 1)
+ (group-height group) (- (screen-height *screen*) 1))
(loop :for i :from 0
- :for g :in (rest (workspace-group-list workspace))
- :do (setf (group-x g) (- (xlib:screen-width *screen*) *tile-border-size* -1)
- (group-y g) (truncate (* i dy))
- (group-width g) (- *tile-border-size* 2)
- (group-height g) (truncate (- dy 1))))))))
+ :for g :in (rest (workspace-group-list workspace))
+ :do (setf (group-x g) (- (screen-width *screen*) *tile-border-size* -1)
+ (group-y g) (truncate (* i dy))
+ (group-width g) (- *tile-border-size* 2)
+ (group-height g) (truncate (- dy 1))))))))
(defun tile-workspace-left (workspace)
"Tile workspace with the current window on the right and others on the left"
@@ -101,19 +101,19 @@
(if (<= len 1)
(setf (group-x group) 0
(group-y group) 0
- (group-width group) (xlib:screen-width *screen*)
- (group-height group) (xlib:screen-height *screen*))
- (let ((dy (/ (xlib:screen-height *screen*) (1- len))))
+ (group-width group) (screen-width *screen*)
+ (group-height group) (screen-height *screen*))
+ (let ((dy (/ (screen-height *screen*) (1- len))))
(setf (group-x group) *tile-border-size*
(group-y group) 1
- (group-width group) (- (xlib:screen-width *screen*) *tile-border-size* 1)
- (group-height group) (- (xlib:screen-height *screen*) 1))
+ (group-width group) (- (screen-width *screen*) *tile-border-size* 1)
+ (group-height group) (- (screen-height *screen*) 1))
(loop :for i :from 0
- :for g :in (rest (workspace-group-list workspace))
- :do (setf (group-x g) 0
- (group-y g) (truncate (* i dy))
- (group-width g) (- *tile-border-size* 2)
- (group-height g) (truncate (- dy 1))))))))
+ :for g :in (rest (workspace-group-list workspace))
+ :do (setf (group-x g) 0
+ (group-y g) (truncate (* i dy))
+ (group-width g) (- *tile-border-size* 2)
+ (group-height g) (truncate (- dy 1))))))))
(defun tile-workspace-top (workspace)
@@ -123,19 +123,19 @@
(if (<= len 1)
(setf (group-x group) 0
(group-y group) 0
- (group-width group) (xlib:screen-width *screen*)
- (group-height group) (xlib:screen-height *screen*))
- (let ((dx (/ (xlib:screen-width *screen*) (1- len))))
+ (group-width group) (screen-width *screen*)
+ (group-height group) (screen-height *screen*))
+ (let ((dx (/ (screen-width *screen*) (1- len))))
(setf (group-x group) 1
(group-y group) *tile-border-size*
- (group-width group) (- (xlib:screen-width *screen*) 1)
- (group-height group) (- (xlib:screen-height *screen*) *tile-border-size* 1))
+ (group-width group) (- (screen-width *screen*) 1)
+ (group-height group) (- (screen-height *screen*) *tile-border-size* 1))
(loop :for i :from 0
- :for g :in (rest (workspace-group-list workspace))
- :do (setf (group-x g) (truncate (* i dx))
- (group-y g) 0
- (group-width g) (truncate (- dx 1))
- (group-height g) (- *tile-border-size* 2)))))))
+ :for g :in (rest (workspace-group-list workspace))
+ :do (setf (group-x g) (truncate (* i dx))
+ (group-y g) 0
+ (group-width g) (truncate (- dx 1))
+ (group-height g) (- *tile-border-size* 2)))))))
(defun tile-workspace-bottom (workspace)
"Tile workspace with the current window on the top and others on the bottom"
@@ -144,19 +144,19 @@
(if (<= len 1)
(setf (group-x group) 0
(group-y group) 0
- (group-width group) (xlib:screen-width *screen*)
- (group-height group) (xlib:screen-height *screen*))
- (let ((dx (/ (xlib:screen-width *screen*) (1- len))))
+ (group-width group) (screen-width *screen*)
+ (group-height group) (screen-height *screen*))
+ (let ((dx (/ (screen-width *screen*) (1- len))))
(setf (group-x group) 1
(group-y group) 1
- (group-width group) (- (xlib:screen-width *screen*) 1)
- (group-height group) (- (xlib:screen-height *screen*) *tile-border-size* 1))
+ (group-width group) (- (screen-width *screen*) 1)
+ (group-height group) (- (screen-height *screen*) *tile-border-size* 1))
(loop :for i :from 0
- :for g :in (rest (workspace-group-list workspace))
- :do (setf (group-x g) (truncate (* i dx))
- (group-y g) (- (xlib:screen-height *screen*) *tile-border-size* -1)
- (group-width g) (truncate (- dx 1))
- (group-height g) (- *tile-border-size* 2)))))))
+ :for g :in (rest (workspace-group-list workspace))
+ :do (setf (group-x g) (truncate (* i dx))
+ (group-y g) (- (screen-height *screen*) *tile-border-size* -1)
+ (group-width g) (truncate (- dx 1))
+ (group-height g) (- *tile-border-size* 2)))))))
(defun tile-current-workspace-to ()
@@ -170,11 +170,11 @@
(let ((method (loop :for m = (intern (string-upcase
(query-string "Workspace tiling method (R)ight, (L)eft, (T)op, (B)ottom:"))
:keyword)
- :when (member m '(:r :l :t :b)) :return m))
+ :when (member m '(:r :l :t :b)) :return m))
(size (loop :for s = (parse-integer (query-string "Workspace tiling border size"
(format nil "~A" *tile-border-size*))
:junk-allowed t)
- :when (numberp s) :return s)))
+ :when (numberp s) :return s)))
(setf *tile-workspace-function* (case method
(:r 'tile-workspace-right)
(:l 'tile-workspace-left)
@@ -206,7 +206,7 @@
y-found))
(defun find-edge-down (current-group workspace)
- (let ((y-found (xlib:screen-height *screen*)))
+ (let ((y-found (screen-height *screen*)))
(dolist (group (workspace-group-list workspace))
(when (and (not (equal group current-group))
(>= (group-y group) (group-y2 current-group))
@@ -216,7 +216,7 @@
y-found))
(defun find-edge-right (current-group workspace)
- (let ((x-found (xlib:screen-width *screen*)))
+ (let ((x-found (screen-width *screen*)))
(dolist (group (workspace-group-list workspace))
(when (and (not (equal group current-group))
(>= (group-x group) (group-x2 current-group))
@@ -294,8 +294,8 @@
(defun center-group (group)
"Center group"
- (setf (group-x group) (truncate (/ (- (xlib:screen-width *screen*) (group-width group)) 2))
- (group-y group) (truncate (/ (- (xlib:screen-height *screen*) (group-height group)) 2))))
+ (setf (group-x group) (truncate (/ (- (screen-width *screen*) (group-width group)) 2))
+ (group-y group) (truncate (/ (- (screen-height *screen*) (group-height group)) 2))))
(defun center-current-group ()
"Center the current group"
@@ -375,11 +375,11 @@
(defun resize-minimal-group (group)
"Resize down a group to its minimal size"
(loop while (> (group-width group) 100) do
- (setf (group-x group) (+ (group-x group) 10)
- (group-width group) (max (- (group-width group) 20))))
+ (setf (group-x group) (+ (group-x group) 10)
+ (group-width group) (max (- (group-width group) 20))))
(loop while (> (group-height group) 100) do
- (setf (group-y group) (+ (group-y group) 10)
- (group-height group) (max (- (group-height group) 20)))))
+ (setf (group-y group) (+ (group-y group) 10)
+ (group-height group) (max (- (group-height group) 20)))))
--- /project/clfswm/cvsroot/clfswm/clfswm-second-mode.lisp 2008/02/24 20:53:37 1.11
+++ /project/clfswm/cvsroot/clfswm/clfswm-second-mode.lisp 2008/05/02 19:56:08 1.12
@@ -1,7 +1,7 @@
;;; --------------------------------------------------------------------------
;;; CLFSWM - FullScreen Window Manager
;;;
-;;; #Date#: Fri Feb 22 21:38:53 2008
+;;; #Date#: Thu Jan 3 00:14:39 2008
;;;
;;; --------------------------------------------------------------------------
;;; Documentation: Second mode functions
@@ -34,35 +34,24 @@
(defparameter *second-mode-program* nil
"Execute the program string if not nil")
-
-;;(defun draw-second-mode-window ()
-;; (xlib:clear-area *sm-window*)
-;; (let* ((text (format nil "Workspace ~A ~:(~A~) ~A ~A ~A"
-;; (workspace-number (current-workspace))
-;; (if *arrow-action* *arrow-action* "")
-;; (if *motion-action* *motion-action* "")
-;; (cond ((numberp *open-next-window-in-new-workspace*)
-;; (format nil ">W:~A" *open-next-window-in-new-workspace*))
-;; (*open-next-window-in-new-workspace* ">W")
-;; (t ""))
-;; (cond ((equal *open-next-window-in-new-group* :once) ">G")
-;; (*open-next-window-in-new-group* ">G+")
-;; (t ""))))
-;; (len (length text)))
-;; (xlib:draw-image-glyphs *sm-window* *sm-gc*
-;; (truncate (/ (- *sm-width* (* (xlib:max-char-width *sm-font*) len)) 2))
-;; (truncate (/ (+ *sm-height* (- (font-ascent *sm-font*) (font-descent *sm-font*))) 2))
-;; text)))
-
-
(defun draw-second-mode-window ()
- (xlib:clear-area *sm-window*)
- (let* ((text (format nil "Second mode"))
+ (clear-area *sm-window*)
+ (let* ((text (format nil "Workspace ~A ~:(~A~) ~A ~A ~A"
+ (workspace-number (current-workspace))
+ (if *arrow-action* *arrow-action* "")
+ (if *motion-action* *motion-action* "")
+ (cond ((numberp *open-next-window-in-new-workspace*)
+ (format nil ">W:~A" *open-next-window-in-new-workspace*))
+ (*open-next-window-in-new-workspace* ">W")
+ (t ""))
+ (cond ((equal *open-next-window-in-new-group* :once) ">G")
+ (*open-next-window-in-new-group* ">G+")
+ (t ""))))
(len (length text)))
- (xlib:draw-image-glyphs *sm-window* *sm-gc*
- (truncate (/ (- *sm-width* (* (xlib:max-char-width *sm-font*) len)) 2))
- (truncate (/ (+ *sm-height* (- (xlib:font-ascent *sm-font*) (xlib:font-descent *sm-font*))) 2))
- text)))
+ (draw-image-glyphs *sm-window* *sm-gc*
+ (truncate (/ (- *sm-width* (* (max-char-width *sm-font*) len)) 2))
+ (truncate (/ (+ *sm-height* (- (font-ascent *sm-font*) (font-descent *sm-font*))) 2))
+ text)))
@@ -74,8 +63,8 @@
(draw-second-mode-window))
(defun sm-handle-enter-notify (&rest event-slots &key root-x root-y &allow-other-keys)
- (declare (ignore event-slots root-x root-y))
- ;; (focus-group-under-mouse root-x root-y)
+ (declare (ignore event-slots))
+ (focus-group-under-mouse root-x root-y)
(draw-second-mode-window))
(defun sm-handle-motion-notify (&rest event-slots &key root-x root-y &allow-other-keys)
@@ -122,7 +111,7 @@
;;(defun sm-handle-property-notify (&rest event-slots &key window &allow-other-keys)
-;; ;;(dbg (xlib:wm-name window))
+;; ;;(dbg (wm-name window))
;; (draw-second-mode-window))
@@ -146,22 +135,24 @@
(defun sm-handle-event (&rest event-slots &key display event-key &allow-other-keys)
(declare (ignore display))
;;(dbg event-key)
- (with-xlib-protect
- (case event-key
- (:button-press (call-hook *sm-button-press-hook* event-slots))
- (:button-release (call-hook *sm-button-release-hook* event-slots))
- (:motion-notify (call-hook *sm-motion-notify-hook* event-slots))
- (:key-press (call-hook *sm-key-press-hook* event-slots))
- (:configure-request (call-hook *sm-configure-request-hook* event-slots))
- (:configure-notify (call-hook *sm-configure-notify-hook* event-slots))
- (:map-request (call-hook *sm-map-request-hook* event-slots))
- (:unmap-notify (call-hook *sm-unmap-notify-hook* event-slots))
- (:destroy-notify (call-hook *sm-destroy-notify-hook* event-slots))
- (:mapping-notify (call-hook *sm-mapping-notify-hook* event-slots))
- (:property-notify (call-hook *sm-property-notify-hook* event-slots))
- (:create-notify (call-hook *sm-create-notify-hook* event-slots))
- (:enter-notify (call-hook *sm-enter-notify-hook* event-slots))
- (:exposure (call-hook *sm-exposure-hook* event-slots))))
+ (handler-case
+ (case event-key
+ (:button-press (call-hook *sm-button-press-hook* event-slots))
+ (:button-release (call-hook *sm-button-release-hook* event-slots))
+ (:motion-notify (call-hook *sm-motion-notify-hook* event-slots))
+ (:key-press (call-hook *sm-key-press-hook* event-slots))
+ (:configure-request (call-hook *sm-configure-request-hook* event-slots))
+ (:configure-notify (call-hook *sm-configure-notify-hook* event-slots))
+ (:map-request (call-hook *sm-map-request-hook* event-slots))
+ (:unmap-notify (call-hook *sm-unmap-notify-hook* event-slots))
+ (:destroy-notify (call-hook *sm-destroy-notify-hook* event-slots))
+ (:mapping-notify (call-hook *sm-mapping-notify-hook* event-slots))
+ (:property-notify (call-hook *sm-property-notify-hook* event-slots))
+ (:create-notify (call-hook *sm-create-notify-hook* event-slots))
+ (:enter-notify (call-hook *sm-enter-notify-hook* event-slots))
+ (:exposure (call-hook *sm-exposure-hook* event-slots)))
+ ((or drawable-error window-error) (c)
+ (declare (ignore c))))
;;(dbg "Ignore handle event" c event-slots)))
t)
@@ -170,22 +161,23 @@
(defun second-key-mode ()
"Switch to editing mode"
;;(dbg "Second key ignore" c)))))
- (setf *sm-window* (xlib:create-window :parent *root*
- :x (truncate (/ (- (xlib:screen-width *screen*) *sm-width*) 2))
- :y 0
- :width *sm-width* :height *sm-height*
- :background (get-color *sm-background-color*)
- :border-width 1
- :border (get-color *sm-border-color*)
- :colormap (xlib:screen-default-colormap *screen*)
- :event-mask '(:exposure))
- *sm-font* (xlib:open-font *display* *sm-font-string*)
- *sm-gc* (xlib:create-gcontext :drawable *sm-window*
- :foreground (get-color *sm-foreground-color*)
- :background (get-color *sm-background-color*)
- :font *sm-font*
- :line-style :solid))
- (xlib:map-window *sm-window*)
+ (minimize-group (current-group))
+ (setf *sm-window* (create-window :parent *root*
+ :x (truncate (/ (- (screen-width *screen*) *sm-width*) 2))
+ :y 0
+ :width *sm-width* :height *sm-height*
+ :background (get-color *sm-background-color*)
+ :border-width 1
+ :border (get-color *sm-border-color*)
+ :colormap (screen-default-colormap *screen*)
+ :event-mask '(:exposure))
+ *sm-font* (open-font *display* *sm-font-string*)
+ *sm-gc* (create-gcontext :drawable *sm-window*
+ :foreground (get-color *sm-foreground-color*)
+ :background (get-color *sm-background-color*)
+ :font *sm-font*
+ :line-style :solid))
+ (map-window *sm-window*)
(draw-second-mode-window)
(no-focus)
(ungrab-main-keys)
@@ -195,16 +187,18 @@
(catch 'exit-second-loop
(loop
(raise-window *sm-window*)
- (xlib:display-finish-output *display*)
- (xlib:process-event *display* :handler #'sm-handle-event)
- (xlib:display-finish-output *display*)))
- (xlib:free-gcontext *sm-gc*)
- (xlib:close-font *sm-font*)
- (xlib:destroy-window *sm-window*)
+ (display-finish-output *display*)
+ (process-event *display* :handler #'sm-handle-event)
+ (display-finish-output *display*)))
+ (free-gcontext *sm-gc*)
+ (close-font *sm-font*)
+ (destroy-window *sm-window*)
(xungrab-keyboard)
(xungrab-pointer)
- (grab-main-keys)
- (show-all-childs))
+ (grab-main-keys))
+ (adapt-window-to-group (current-window) (current-group))
+ (focus-window (current-window))
+ (show-all-group (current-workspace))
(wait-no-key-or-button-press)
(when *second-mode-program*
(do-shell *second-mode-program*)
@@ -212,11 +206,229 @@
-(defun leave-second-mode ()
- "Leave second mode"
- (banish-pointer)
- (throw 'exit-second-loop nil))
-
+;;;;; Alternative - Second mode with dashed screen
+;;(let ((num 5)
+;; (line-color "Green"))
+;; (defun draw-second-mode-window (window gc)
+;; (show-all-windows-in-workspace (current-workspace))
+;; (sleep 0.1)
+;; (display-finish-output *display*)
+;; (raise-window window)
+;; (setf (gcontext-foreground gc) (get-color line-color)
+;; (gcontext-line-style gc) :dash)
+;; (let ((dx (/ (drawable-width window) num))
+;; (dy (/ (drawable-height window) num)))
+;; (loop for i from 1 below num do
+;; (draw-line window gc (truncate (* i dx)) 0 0 (truncate (* i dy)))
+;; (draw-line window gc (truncate (* i dx)) (drawable-height window) (drawable-width window) (truncate (* i dy)))
+;; (draw-line window gc (truncate (* i dx)) 0 (drawable-width window) (truncate (* (- num i) dy)))
+;; (draw-line window gc (truncate (* (- num i) dx)) (drawable-height window) 0 (truncate (* i dy)))))
+;; (draw-line window gc 0 (drawable-height window) (drawable-width window) 0)
+;; (draw-line window gc 0 0 (drawable-width window) (drawable-height window))
+;; (setf (gcontext-line-style gc) :solid)
+;; (show-all-group (current-workspace) window gc)
+;; (no-focus)))
+;;
+;;(defmacro with-draw-second-mode-window ((hide show) &body body)
+;; (cond ((and hide show) `(progn
+;; (hide-window sm-window)
+;; , at body
+;; (draw-second-mode-window sm-window sm-gc)
+;; (display-force-output *display*)))
+;; (hide `(progn
+;; (hide-window sm-window)
+;; , at body
+;; (display-force-output *display*)))
+;; (show `(progn
+;; , at body
+;; (draw-second-mode-window sm-window sm-gc)
+;; (display-force-output *display*)))
+;; (t `(progn
+;; , at body
+;; (display-force-output *display*)))))
+;;
+;;
+;;(defun second-key-mode ()
+;; "Switch to editing mode"
+;; (let* ((sm-window (create-window :parent *root* :x 0 :y 0
+;; :width (screen-width *screen*) :height (screen-height *screen*)
+;; :colormap (screen-default-colormap *screen*)
+;; :event-mask '()))
+;; (sm-gc (create-gcontext :drawable sm-window
+;; :foreground (get-color "Red")
+;; :background (get-color "Black")
+;; :line-style :solid)))
+;; (labels ((handle-key-press (&rest event-slots &key root code state &allow-other-keys)
+;; (declare (ignore event-slots root))
+;; (funcall-key-from-code *second-keys* code state))
+;; (sm-handle-enter-notify (&rest event-slots &key window root-x root-y &allow-other-keys)
+;; (declare (ignore event-slots))
+;; (unless (or (window-equal sm-window window)
+;; (window-equal window *root*))
+;; (with-draw-second-mode-window (t t)
+;; (focus-group-under-mouse root-x root-y))))
+;; (handle-motion-notify (&rest event-slots &key root-x root-y &allow-other-keys)
+;; (declare (ignore event-slots))
+;; (unless (event-case (*display* :discard-p nil :peek-p t :timeout 0)
+;; (:motion-notify () t))
+;; (funcall-button-from-code *mouse-action* 'motion 0 root-x root-y #'first)
+;; (show-all-group (current-workspace) sm-window sm-gc)
+;; (no-focus)))
+;; (handle-button-press (&rest event-slots &key root-x root-y code state &allow-other-keys)
+;; (declare (ignore event-slots))
+;; (funcall-button-from-code *mouse-action* code state root-x root-y #'first))
+;; (handle-button-release (&rest event-slots &key root-x root-y code state &allow-other-keys)
+;; (declare (ignore event-slots))
+;; (funcall-button-from-code *mouse-action* code state root-x root-y #'third))
+;; (sm-handle-configure-request (&rest event-slots &key window &allow-other-keys)
+;; (unless (window-equal sm-window window)
+;; (with-draw-second-mode-window (t t)
+;; (apply #'handle-configure-request event-slots))))
+;; (sm-handle-map-request (&rest event-slots &key window &allow-other-keys)
+;; (unless (window-equal sm-window window)
+;; (with-draw-second-mode-window (t t)
+;; (apply #'handle-map-request event-slots))))
+;; (sm-handle-unmap-notify (&rest event-slots &key window &allow-other-keys)
+;; (unless (window-equal sm-window window)
+;; (with-draw-second-mode-window (t t)
+;; (apply #'handle-unmap-notify event-slots))))
+;; (sm-handle-destroy-notify (&rest event-slots &key window &allow-other-keys)
+;; (unless (window-equal sm-window window)
+;; (with-draw-second-mode-window (t t)
+;; (apply #'handle-destroy-notify event-slots))))
+;; (handle-event (&rest event-slots &key display event-key &allow-other-keys)
+;; (declare (ignore display))
+;; (handler-case
+;; (case event-key
+;; (:key-press (with-draw-second-mode-window (t t)
+;; (apply #'handle-key-press event-slots)))
+;; (:enter-notify nil)
+;; (:motion-notify (apply #'handle-motion-notify event-slots))
+;; (:button-press (with-draw-second-mode-window (t nil)
+;; (apply #'handle-button-press event-slots)))
+;; (:button-release (with-draw-second-mode-window (nil t)
+;; (apply #'handle-button-release event-slots)))
+;; (:configure-request (apply #'sm-handle-configure-request event-slots))
+;; (:map-request (apply #'sm-handle-map-request event-slots))
+;; (:unmap-notify (apply #'sm-handle-unmap-notify event-slots))
+;; (:destroy-notify (apply #'sm-handle-destroy-notify event-slots))
+;; (:mapping-notify nil)
+;; (:property-notify nil)
+;; (:create-notify nil))
+;; ((or drawable-error window-error) (c)
+;; (declare (ignore c))))
+;; t))
+;; ;;(dbg "Second key ignore" c)))))
+;; (minimize-group (current-group))
+;; (map-window sm-window)
+;; (raise-window sm-window)
+;; (draw-second-mode-window sm-window sm-gc)
+;; (no-focus)
+;; (ungrab-main-keys)
+;; (xgrab-keyboard *root*)
+;; (xgrab-pointer *root* 66 67)
+;; (unwind-protect
+;; (catch 'exit-second-loop
+;; (loop
+;; (process-event *display* :handler #'handle-event)
+;; (display-finish-output *display*)))
+;; (free-gcontext sm-gc)
+;; (destroy-window sm-window)
+;; (xungrab-keyboard)
+;; (xungrab-pointer)
+;; (grab-main-keys))
+;; (adapt-window-to-group (current-window) (current-group))
+;; (focus-window (current-window))
+;; (show-all-group (current-workspace))
+;; (wait-no-key-or-button-press))))
+
+
+
+;;;;; Alternative - Second mode with big screen border
+;;(let ((border-size 5)
+;; (border-color "Green"))
+;; (defun second-key-mode ()
+;; "Switch to editing mode"
+;; (let* ((windows (list (create-window :parent *root* :x 0 :y 0
+;; :width (screen-width *screen*) :height border-size
+;; :background (get-color border-color)
+;; :colormap (screen-default-colormap *screen*))
+;; (create-window :parent *root* :x 0 :y (- (screen-height *screen*) border-size)
+;; :width (screen-width *screen*) :height border-size
+;; :background (get-color border-color)
+;; :colormap (screen-default-colormap *screen*))
+;; (create-window :parent *root* :x 0 :y border-size
+;; :width border-size :height (- (screen-height *screen*) (* border-size 2))
+;; :background (get-color border-color)
+;; :colormap (screen-default-colormap *screen*))
+;; (create-window :parent *root* :x (- (screen-width *screen*) border-size)
+;; :y border-size
+;; :width border-size :height (- (screen-height *screen*) (* border-size 2))
+;; :background (get-color border-color)
+;; :colormap (screen-default-colormap *screen*)))))
+;; (labels ((draw-second-mode-window ()
+;; (dolist (win windows)
+;; (raise-window win)))
+;; (handle-key-press (&rest event-slots &key root code state &allow-other-keys)
+;; (declare (ignore event-slots root))
+;; (funcall-key-from-code *second-keys* code state))
+;; (handle-enter-notify (&rest event-slots &key root-x root-y &allow-other-keys)
+;; (declare (ignore event-slots))
+;; (focus-group-under-mouse root-x root-y))
+;; (handle-motion-notify (&rest event-slots &key root-x root-y &allow-other-keys)
+;; (declare (ignore event-slots))
+;; (unless (event-case (*display* :discard-p nil :peek-p t :timeout 0)
+;; (:motion-notify () t))
+;; (funcall-button-from-code *mouse-action* 'motion 0 root-x root-y #'first)))
+;; (handle-button-press (&rest event-slots &key root-x root-y code state &allow-other-keys)
+;; (declare (ignore event-slots))
+;; (funcall-button-from-code *mouse-action* code state root-x root-y #'first))
+;; (handle-button-release (&rest event-slots &key root-x root-y code state &allow-other-keys)
+;; (declare (ignore event-slots))
+;; (funcall-button-from-code *mouse-action* code state root-x root-y #'third))
+;; (handle-event (&rest event-slots &key display event-key &allow-other-keys)
+;; (declare (ignore display))
+;; (handler-case
+;; (case event-key
+;; (:key-press (apply #'handle-key-press event-slots))
+;; (:enter-notify (apply #'handle-enter-notify event-slots))
+;; (:motion-notify (apply #'handle-motion-notify event-slots))
+;; (:button-press (apply #'handle-button-press event-slots))
+;; (:button-release (apply #'handle-button-release event-slots))
+;; (:configure-request (apply #'handle-configure-request event-slots))
+;; (:map-request (apply #'handle-map-request event-slots))
+;; (:unmap-notify (apply #'handle-unmap-notify event-slots))
+;; (:destroy-notify (apply #'handle-destroy-notify event-slots))
+;; (:mapping-notify nil)
+;; (:property-notify nil)
+;; (:create-notify nil))
+;; ((or drawable-error window-error) (c)
[26 lines skipped]
--- /project/clfswm/cvsroot/clfswm/clfswm-util.lisp 2008/02/29 23:05:56 1.15
+++ /project/clfswm/cvsroot/clfswm/clfswm-util.lisp 2008/05/02 19:56:08 1.16
@@ -1,7 +1,7 @@
;;; --------------------------------------------------------------------------
;;; CLFSWM - FullScreen Window Manager
;;;
-;;; #Date#: Sat Mar 1 00:03:08 2008
+;;; #Date#: Wed Jan 2 23:45:31 2008
;;;
;;; --------------------------------------------------------------------------
;;; Documentation: Utility
@@ -28,134 +28,393 @@
(in-package :clfswm)
+;;;,-----
+;;;| Various definitions
+;;;`-----
+(defun stop-all-pending-actions ()
+ "Stop all pending actions (actions like open in new workspace/group)"
+ (setf *open-next-window-in-new-workspace* nil
+ *open-next-window-in-new-group* nil
+ *arrow-action* nil
+ *pager-arrow-action* nil))
+
+(defun rotate-window-up ()
+ "Rotate up windows in the current group"
+ (setf (group-window-list (current-group))
+ (rotate-list (group-window-list (current-group))))
+ (adapt-window-to-group (current-window) (current-group))
+ (focus-window (current-window))
+ (show-all-group (current-workspace)))
+
+(defun rotate-window-down ()
+ "Rotate down windows in the current group"
+ (setf (group-window-list (current-group))
+ (anti-rotate-list (group-window-list (current-group))))
+ (adapt-window-to-group (current-window) (current-group))
+ (focus-window (current-window))
+ (show-all-group (current-workspace)))
+
+
+(defun maximize-group (group)
+ "Maximize the group"
+ (when group
+ (unless (group-fullscreenp group)
+ (setf (group-fullscreenp group) t)))
+ (show-all-windows-in-workspace (current-workspace)))
+
+(defun minimize-group (group)
+ "Minimize the group"
+ (when group
+ (when (group-fullscreenp group)
+ (setf (group-fullscreenp group) nil)))
+ (show-all-windows-in-workspace (current-workspace)))
+
+(defun toggle-maximize-group (group)
+ "Maximize/minimize a group"
+ (if (group-fullscreenp group)
+ (minimize-group group)
+ (maximize-group group)))
+
+
+(defun toggle-maximize-current-group ()
+ "Maximize/minimize the current group"
+ (toggle-maximize-group (current-group)))
+
+
+(defun banish-pointer ()
+ "Move the pointer to the lower right corner of the screen and redraw all groups"
+ (warp-pointer *root*
+ (1- (screen-width *screen*))
+ (1- (screen-height *screen*)))
+ (show-all-group (current-workspace)))
+
+
+(defun renumber-workspaces ()
+ "Reset workspaces numbers (1 for current workspace, 2 for the second...) "
+ (hide-all-windows-in-workspace (current-workspace))
+ (setf *current-workspace-number* 0)
+ (loop for workspace in *workspace-list* do
+ (setf (workspace-number workspace) (incf *current-workspace-number*)))
+ (show-all-windows-in-workspace (current-workspace)))
+
+
+(defun sort-workspaces ()
+ "Sort workspaces by numbers"
+ (hide-all-windows-in-workspace (current-workspace))
+ (setf *workspace-list* (sort *workspace-list*
+ #'(lambda (x y)
+ (< (workspace-number x) (workspace-number y)))))
+ (show-all-windows-in-workspace (current-workspace)))
+
+
+
+
+(defun circulate-group-up ()
+ "Circulate up in group"
+ (banish-pointer)
+ (minimize-group (current-group))
+ (no-focus)
+ (setf (workspace-group-list (current-workspace))
+ (rotate-list (workspace-group-list (current-workspace))))
+ (adapt-window-to-group (current-window) (current-group))
+ (focus-window (current-window))
+ (show-all-group (current-workspace)))
+
+
+(defun circulate-group-up-move-window ()
+ "Circulate up in group moving the current window in the next group"
+ (banish-pointer)
+ (minimize-group (current-group))
+ (no-focus)
+ (let ((window (current-window)))
+ (remove-window-in-group window (current-group))
+ (focus-window (current-window))
+ (setf (workspace-group-list (current-workspace))
+ (rotate-list (workspace-group-list (current-workspace))))
+ (add-window-in-group window (current-group)))
+ (adapt-window-to-group (current-window) (current-group))
+ (focus-window (current-window))
+ (show-all-group (current-workspace)))
+
+(defun circulate-group-up-copy-window ()
+ "Circulate up in group copying the current window in the next group"
+ (banish-pointer)
+ (minimize-group (current-group))
+ (no-focus)
+ (let ((window (current-window)))
+ (setf (workspace-group-list (current-workspace))
+ (rotate-list (workspace-group-list (current-workspace))))
+ (unless (window-already-in-workspace window (current-workspace))
+ (add-window-in-group window (current-group))))
+ (adapt-window-to-group (current-window) (current-group))
+ (focus-window (current-window))
+ (show-all-group (current-workspace)))
+
+
+
+(defun circulate-group-down ()
+ "Circulate down in group"
+ (banish-pointer)
+ (minimize-group (current-group))
+ (no-focus)
+ (setf (workspace-group-list (current-workspace))
+ (anti-rotate-list (workspace-group-list (current-workspace))))
+ (adapt-window-to-group (current-window) (current-group))
+ (focus-window (current-window))
+ (show-all-group (current-workspace)))
+
+(defun circulate-group-down-move-window ()
+ "Circulate down in group moving the current window in the next group"
+ (banish-pointer)
+ (minimize-group (current-group))
+ (no-focus)
+ (let ((window (current-window)))
+ (remove-window-in-group window (current-group))
+ (focus-window (current-window))
+ (setf (workspace-group-list (current-workspace))
+ (anti-rotate-list (workspace-group-list (current-workspace))))
+ (add-window-in-group window (current-group)))
+ (adapt-window-to-group (current-window) (current-group))
+ (focus-window (current-window))
+ (show-all-group (current-workspace)))
+
+(defun circulate-group-down-copy-window ()
+ "Circulate down in group copying the current window in the next group"
+ (banish-pointer)
+ (minimize-group (current-group))
+ (no-focus)
+ (let ((window (current-window)))
+ (setf (workspace-group-list (current-workspace))
+ (anti-rotate-list (workspace-group-list (current-workspace))))
+ (unless (window-already-in-workspace window (current-workspace))
+ (add-window-in-group window (current-group))))
+ (adapt-window-to-group (current-window) (current-group))
+ (focus-window (current-window))
+ (show-all-group (current-workspace)))
-(defun add-default-group ()
- "Add a default group"
- (when (group-p *current-child*)
- (let ((name (query-string "Group name")))
- (push (create-group :name name) (group-child *current-child*))))
- (leave-second-mode))
-
-
-(defun add-placed-group ()
- "Add a placed group"
- (when (group-p *current-child*)
- (let ((name (query-string "Group name"))
- (x (/ (query-number "Group x in percent (%)") 100))
- (y (/ (query-number "Group y in percent (%)") 100))
- (w (/ (query-number "Group width in percent (%)") 100))
- (h (/ (query-number "Group height in percent (%)") 100)))
- (push (create-group :name name :x x :y y :w w :h h)
- (group-child *current-child*))))
- (leave-second-mode))
-(defun delete-focus-window ()
- "Delete the focus window in all groups and workspaces"
- (let ((window (xlib:input-focus *display*)))
- (when (and window (not (xlib:window-equal window *no-focus-window*)))
- (setf *current-child* *current-root*)
- (remove-child-in-all-groups window)
- (send-client-message window :WM_PROTOCOLS
- (xlib:intern-atom *display* "WM_DELETE_WINDOW"))
- (show-all-childs))))
-(defun destroy-focus-window ()
- "Destroy the focus window in all groups and workspaces"
- (let ((window (xlib:input-focus *display*)))
- (when (and window (not (xlib:window-equal window *no-focus-window*)))
- (setf *current-child* *current-root*)
- (remove-child-in-all-groups window)
- (xlib:kill-client *display* (xlib:window-id window))
- (show-all-childs))))
-
-(defun remove-focus-window ()
- "Remove the focus window in the current group"
- (let ((window (xlib:input-focus *display*)))
- (when (and window (not (xlib:window-equal window *no-focus-window*)))
- (setf *current-child* *current-root*)
- (hide-child window)
- (remove-child-in-group window (find-father-group window))
- (show-all-childs))))
-
-
-(defun unhide-all-windows-in-current-child ()
- "Unhide all hidden windows into the current child"
- (with-xlib-protect
- (dolist (window (get-hidden-windows))
- (unhide-window window)
- (process-new-window window)
- (xlib:map-window window)))
- (show-all-childs))
-
-
-
-
-(defun find-child-under-mouse (x y)
- "Return the child window under the mouse"
- (with-xlib-protect
- (let ((win nil))
- (with-all-windows-groups (*current-root* child)
- (when (and (<= (xlib:drawable-x child) x (+ (xlib:drawable-x child) (xlib:drawable-width child)))
- (<= (xlib:drawable-y child) y (+ (xlib:drawable-y child) (xlib:drawable-height child))))
- (setf win child))
- (when (and (<= (group-rx child) x (+ (group-rx child) (group-rw child)))
- (<= (group-ry child) y (+ (group-ry child) (group-rh child))))
- (setf win (group-window child))))
- win)))
+(defun circulate-workspace-by-number (number)
+ "Focus a workspace given its number"
+ (no-focus)
+ (hide-all-windows-in-workspace (current-workspace))
+ (dotimes (i (length *workspace-list*))
+ (when (= (workspace-number (current-workspace)) number)
+ (return))
+ (setf *workspace-list* (rotate-list *workspace-list*)))
+ (show-all-windows-in-workspace (current-workspace)))
+
+(defun circulate-workspace-up ()
+ "Circulate up in workspace"
+ (no-focus)
+ (hide-all-windows-in-workspace (current-workspace))
+ (setf *workspace-list* (rotate-list *workspace-list*))
+ (show-all-windows-in-workspace (current-workspace)))
+
+(defun circulate-workspace-up-move-group ()
+ "Circulate up in workspace moving current group in the next workspace"
+ (no-focus)
+ (hide-all-windows-in-workspace (current-workspace))
+ (let ((group (current-group)))
+ (remove-group-in-workspace group (current-workspace))
+ (setf *workspace-list* (rotate-list *workspace-list*))
+ (add-group-in-workspace (copy-group group) (current-workspace)))
+ (show-all-windows-in-workspace (current-workspace)))
+
+(defun circulate-workspace-up-copy-group ()
+ "Circulate up in workspace copying current group in the next workspace"
+ (no-focus)
+ (hide-all-windows-in-workspace (current-workspace))
+ (let ((group (current-group)))
+ (setf *workspace-list* (rotate-list *workspace-list*))
+ (unless (group-windows-already-in-workspace group (current-workspace))
+ (add-group-in-workspace (copy-group group) (current-workspace))))
+ (show-all-windows-in-workspace (current-workspace)))
+
+
+
+(defun circulate-workspace-down ()
+ "Circulate down in workspace"
+ (no-focus)
+ (hide-all-windows-in-workspace (current-workspace))
+ (setf *workspace-list* (anti-rotate-list *workspace-list*))
+ (show-all-windows-in-workspace (current-workspace)))
+
+(defun circulate-workspace-down-move-group ()
+ "Circulate down in workspace moving current group in the next workspace"
+ (no-focus)
+ (hide-all-windows-in-workspace (current-workspace))
+ (let ((group (current-group)))
+ (remove-group-in-workspace group (current-workspace))
+ (setf *workspace-list* (anti-rotate-list *workspace-list*))
+ (add-group-in-workspace (copy-group group) (current-workspace)))
+ (show-all-windows-in-workspace (current-workspace)))
+
+(defun circulate-workspace-down-copy-group ()
+ "Circulate down in workspace copying current group in the next workspace"
+ (no-focus)
+ (hide-all-windows-in-workspace (current-workspace))
+ (let ((group (current-group)))
+ (setf *workspace-list* (anti-rotate-list *workspace-list*))
+ (unless (group-windows-already-in-workspace group (current-workspace))
+ (add-group-in-workspace (copy-group group) (current-workspace))))
+ (show-all-windows-in-workspace (current-workspace)))
+
+
+
+(defun delete-current-window ()
+ "Delete the current window in all groups and workspaces"
+ (let ((window (current-window)))
+ (when window
+ (no-focus)
+ (remove-window-in-all-workspace window)
+ (send-client-message window :WM_PROTOCOLS
+ (intern-atom *display* "WM_DELETE_WINDOW"))))
+ (focus-window (current-window))
+ (show-all-group (current-workspace)))
+
+
+(defun destroy-current-window ()
+ "Destroy the current window in all groups and workspaces"
+ (let ((window (current-window)))
+ (when window
+ (no-focus)
+ (remove-window-in-all-workspace window)
+ (kill-client *display* (window-id window))))
+ (focus-window (current-window))
+ (show-all-group (current-workspace)))
+
+(defun remove-current-window ()
+ "Remove the current window in the current group"
+ (let ((window (current-window)))
+ (when window
+ (no-focus)
+ (hide-window window)
+ (remove-window-in-group (current-window) (current-group))))
+ (focus-window (current-window))
+ (show-all-group (current-workspace)))
+
+(defun remove-current-group ()
+ "Remove the current group in the current workspace"
+ (minimize-group (current-group))
+ (let ((group (current-group)))
+ (when group
+ (no-focus)
+ (dolist (window (group-window-list group))
+ (when window
+ (hide-window window)))
+ (remove-group-in-workspace group (current-workspace))))
+ (focus-window (current-window))
+ (show-all-group (current-workspace)))
+
+(defun remove-current-workspace ()
+ "Remove the current workspace"
+ (let ((workspace (current-workspace)))
+ (when workspace
+ (hide-all-windows-in-workspace workspace)
+ (remove-workspace workspace)
+ (show-all-windows-in-workspace (current-workspace)))))
+
+
+(defun unhide-all-windows-in-current-group ()
+ "Unhide all hidden windows into the current group"
+ (let ((all-windows (get-all-windows))
+ (hidden-windows (remove-if-not #'window-hidden-p
+ (copy-list (query-tree *root*))))
+ (current-group (current-group)))
+ (dolist (window (set-difference hidden-windows all-windows))
+ (unhide-window window)
+ (process-new-window window)
+ (map-window window)
+ (adapt-window-to-group window current-group)))
+ (focus-window (current-window))
+ (show-all-group (current-workspace)))
+
+
+
+
+(defun create-new-default-group ()
+ "Create a new default group"
+ (minimize-group (current-group))
+ (add-group-in-workspace (copy-group *default-group*)
+ (current-workspace))
+ (show-all-windows-in-workspace (current-workspace)))
[864 lines skipped]
--- /project/clfswm/cvsroot/clfswm/clfswm.asd 2008/02/24 20:53:37 1.7
+++ /project/clfswm/cvsroot/clfswm/clfswm.asd 2008/05/02 19:56:08 1.8
@@ -2,7 +2,7 @@
;;;; Author: Philippe Brochard <hocwp at free.fr>
;;;; ASDF System Definition
;;;
-;;; #date#: Fri Feb 22 21:39:37 2008
+;;; #date#: Wed Jan 2 23:30:31 2008
(in-package #:asdf)
@@ -13,36 +13,43 @@
:licence "GNU Public License (GPL)"
:components ((:file "tools")
(:file "my-html"
- :depends-on ("tools"))
+ :depends-on ("tools"))
(:file "package"
- :depends-on ("my-html" "tools"))
+ :depends-on ("my-html" "tools"))
(:file "config"
- :depends-on ("package"))
+ :depends-on ("package"))
(:file "keysyms"
- :depends-on ("package"))
+ :depends-on ("package"))
(:file "xlib-util"
- :depends-on ("package" "keysyms" "config"))
+ :depends-on ("package" "keysyms" "config"))
(:file "netwm-util"
- :depends-on ("package" "xlib-util"))
+ :depends-on ("package" "xlib-util"))
(:file "clfswm-keys"
- :depends-on ("package" "config" "xlib-util" "keysyms"))
+ :depends-on ("package" "config" "xlib-util" "keysyms"))
(:file "clfswm-internal"
- :depends-on ("xlib-util" "clfswm-keys" "netwm-util" "tools"))
- (:file "clfswm"
- :depends-on ("xlib-util" "netwm-util" "clfswm-keys" "config"
- "clfswm-internal" "tools"))
+ :depends-on ("xlib-util" "clfswm-keys" "netwm-util" "tools"))
(:file "clfswm-second-mode"
- :depends-on ("package" "clfswm-internal"))
- (:file "clfswm-info"
- :depends-on ("package" "xlib-util" "config" "clfswm-keys" "clfswm" "clfswm-internal"))
+ :depends-on ("package" "clfswm-internal"))
+ (:file "clfswm"
+ :depends-on ("xlib-util" "netwm-util" "clfswm-keys" "config"
+ "clfswm-internal" "clfswm-second-mode" "tools"))
(:file "clfswm-util"
- :depends-on ("clfswm" "keysyms" "clfswm-info" "clfswm-second-mode"))
- (:file "clfswm-layout"
- :depends-on ("package" "clfswm-util" "clfswm-info"))
+ :depends-on ("clfswm" "keysyms"))
+ (:file "clfswm-pack"
+ :depends-on ("clfswm" "clfswm-util"))
+ (:file "clfswm-pager"
+ :depends-on ("clfswm" "clfswm-util" "clfswm-pack"))
+ (:file "clfswm-info"
+ :depends-on ("clfswm" "clfswm-pager"))
(:file "bindings"
- :depends-on ("clfswm" "clfswm-internal"))
+ :depends-on ("clfswm" "clfswm-util" "clfswm-pack" "clfswm-info"))
(:file "bindings-second-mode"
- :depends-on ("clfswm" "clfswm-util"))))
+ :depends-on ("clfswm" "clfswm-util" "clfswm-pack" "clfswm-info"))
+ (:file "bindings-pager"
+ :depends-on ("clfswm" "clfswm-util" "clfswm-pack" "clfswm-pager"
+ "clfswm-info" "bindings"))))
+
+
--- /project/clfswm/cvsroot/clfswm/clfswm.lisp 2008/02/29 23:05:56 1.16
+++ /project/clfswm/cvsroot/clfswm/clfswm.lisp 2008/05/02 19:56:08 1.17
@@ -1,7 +1,7 @@
;;; --------------------------------------------------------------------------
;;; CLFSWM - FullScreen Window Manager
;;;
-;;; #Date#: Sat Mar 1 00:02:34 2008
+;;; #Date#: Sat Jan 5 15:16:21 2008
;;;
;;; --------------------------------------------------------------------------
;;; Documentation: Main functions
@@ -38,6 +38,46 @@
+;;(defun handle-configure-request (&rest event-slots &key stack-mode #|parent|# window #|above-sibling|#
+;; x y width height border-width value-mask &allow-other-keys)
+;; (declare (ignore event-slots))
+;; (labels ((has-x (mask) (= 1 (logand mask 1)))
+;; (has-y (mask) (= 2 (logand mask 2)))
+;; (has-w (mask) (= 4 (logand mask 4)))
+;; (has-h (mask) (= 8 (logand mask 8)))
+;; (has-bw (mask) (= 16 (logand mask 16)))
+;; (has-stackmode (mask) (= 64 (logand mask 64))))
+;; (handler-case
+;; (progn
+;; (with-state (window)
+;; (when (has-x value-mask)
+;; (setf (drawable-x window) x))
+;; (when (has-y value-mask)
+;; (setf (drawable-y window) y))
+;; (when (has-h value-mask)
+;; (setf (drawable-height window) height))
+;; (when (has-w value-mask)
+;; (setf (drawable-width window) width))
+;; (when (has-bw value-mask)
+;; (setf (drawable-border-width window) border-width)))
+;; ;; The ICCCM says with have to send a fake configure-notify if
+;; ;; the window is moved but not resized.
+;; (when (member window (group-window-list (current-group)))
+;; (unless (or (logbitp 2 value-mask) (logbitp 3 value-mask))
+;; (send-configuration-notify window))
+;; (adapt-window-to-group window (current-group))
+;; (when (has-stackmode value-mask)
+;; (case stack-mode
+;; (:above (raise-window window))))))
+;; ((or match-error window-error drawable-error) (c)
+;; (declare (ignore c))))))
+;; ;;(dbg "Configure Error" c)))))
+;;
+;;
+;;
+;;(defun handle-configure-notify (&rest event-slots)
+;; (declare (ignore event-slots))
+;; (adapt-all-window-in-workspace (current-workspace)))
(defun handle-configure-request (&rest event-slots &key stack-mode #|parent|# window #|above-sibling|#
x y width height border-width value-mask &allow-other-keys)
@@ -47,26 +87,29 @@
(has-w (mask) (= 4 (logand mask 4)))
(has-h (mask) (= 8 (logand mask 8)))
(has-bw (mask) (= 16 (logand mask 16)))
- (has-stackmode (mask) (= 64 (logand mask 64)))
+ (has-stackmode (mask) (= 64 (logand mask 64)))
(adjust-from-request ()
- (when (has-x value-mask) (setf (xlib:drawable-x window) x))
- (when (has-y value-mask) (setf (xlib:drawable-y window) y))
- (when (has-h value-mask) (setf (xlib:drawable-height window) height))
- (when (has-w value-mask) (setf (xlib:drawable-width window) width))))
- (with-xlib-protect
- (xlib:with-state (window)
- (when (has-bw value-mask)
- (setf (xlib:drawable-border-width window) border-width))
- (if (find-child window *current-root*)
- (case (window-type window)
- (:normal (adapt-child-to-father window (find-father-group window *current-root*))
- (send-configuration-notify window))
- (t (adjust-from-request)))
- (adjust-from-request))
- (when (has-stackmode value-mask)
- (case stack-mode
- (:above (raise-window window))))))))
-
+ (when (has-x value-mask) (setf (drawable-x window) x))
+ (when (has-y value-mask) (setf (drawable-y window) y))
+ (when (has-h value-mask) (setf (drawable-height window) height))
+ (when (has-w value-mask) (setf (drawable-width window) width))))
+ (handler-case
+ (progn
+ (with-state (window)
+ (when (has-bw value-mask)
+ (setf (drawable-border-width window) border-width))
+ (if (window-already-in-workspace window (current-workspace))
+ (case (window-type window)
+ (:normal (adapt-window-to-group window (find-window-group window (current-workspace)))
+ (send-configuration-notify window))
+ (t (adjust-from-request)))
+ (adjust-from-request))
+ (when (has-stackmode value-mask)
+ (case stack-mode
+ (:above (raise-window window))))))
+ ((or match-error window-error drawable-error) (c)
+ (declare (ignore c))))))
+ ;;(dbg "Configure Error" c)))))
@@ -79,41 +122,43 @@
(defun handle-map-request (&rest event-slots &key window send-event-p &allow-other-keys)
(declare (ignore event-slots))
(unless send-event-p
- ;; (unhide-window window)
+ (unhide-window window)
(process-new-window window)
- (xlib:map-window window)
- ;; (focus-window window)
- (show-all-childs)))
+ (map-window window)
+ (focus-window window)
+ (show-all-group (current-workspace))))
(defun handle-unmap-notify (&rest event-slots &key send-event-p event-window window &allow-other-keys)
(declare (ignore event-slots))
(unless (and (not send-event-p)
- (not (xlib:window-equal window event-window)))
- (when (find-child window *root-group*)
- (remove-child-in-all-groups window)
- (show-all-childs))))
+ (not (window-equal window event-window)))
+ (let ((found-p (find window (get-all-windows) :test 'window-equal)))
+ (remove-window-in-all-workspace window)
+ (when found-p
+ (show-all-windows-in-workspace (current-workspace))))))
+
(defun handle-destroy-notify (&rest event-slots &key send-event-p event-window window &allow-other-keys)
(declare (ignore event-slots))
(unless (or send-event-p
- (xlib:window-equal window event-window))
- (when (find-child window *root-group*)
- (remove-child-in-all-groups window)
- (show-all-childs))))
+ (window-equal event-window window))
+ (let ((found-p (find window (get-all-windows) :test 'window-equal)))
+ (remove-window-in-all-workspace window)
+ (when found-p
+ (show-all-windows-in-workspace (current-workspace))))))
(defun handle-enter-notify (&rest event-slots &key root-x root-y &allow-other-keys)
- (declare (ignore event-slots root-x root-y)))
-
-
+ (declare (ignore event-slots))
+ (unless (group-fullscreenp (current-group))
+ (focus-group-under-mouse root-x root-y)))
-(defun handle-exposure (&rest event-slots &key window &allow-other-keys)
+(defun handle-exposure (&rest event-slots)
(declare (ignore event-slots))
- (awhen (find-group-window window *current-root*)
- (display-group-info it)))
+ (show-all-group (current-workspace) *root* *root-gc* nil))
(defun handle-create-notify (&rest event-slots)
@@ -121,43 +166,17 @@
-;; PHIL: TODO: focus-policy par group
-;; :click, :sloppy, :nofocus
-(defun handle-click-to-focus (window)
- (let ((to-replay t)
- (child window)
- (father (find-father-group window *current-root*)))
- (unless father
- (setf child (find-group-window window *current-root*)
- father (find-father-group child *current-root*)))
- (when (and child father (focus-all-childs child father))
- (show-all-childs)
- (setf to-replay nil))
- (if to-replay (replay-button-event) (stop-button-event))))
-
-
-(defun handle-button-press (&rest event-slots &key code state window &allow-other-keys)
- (declare (ignore event-slots))
- (if (and (= code 1) (= state 0))
- (handle-click-to-focus window)
- (replay-button-event)))
-
-
-
-
-
-
;;; CONFIG: Main mode hooks
(setf *key-press-hook* #'handle-key-press
*configure-request-hook* #'handle-configure-request
*configure-notify-hook* #'handle-configure-notify
- *destroy-notify-hook* 'handle-destroy-notify
+ *destroy-notify-hook* #'handle-destroy-notify
*enter-notify-hook* #'handle-enter-notify
- *exposure-hook* 'handle-exposure
+ *exposure-hook* #'handle-exposure
*map-request-hook* #'handle-map-request
- *unmap-notify-hook* 'handle-unmap-notify
- *create-notify-hook* #'handle-create-notify
- *button-press-hook* 'handle-button-press)
+ *unmap-notify-hook* #'handle-unmap-notify
+ *create-notify-hook* #'handle-create-notify)
+
@@ -165,10 +184,9 @@
(defun handle-event (&rest event-slots &key display event-key &allow-other-keys)
(declare (ignore display))
;;(dbg event-key)
- (with-xlib-protect
+ (handler-case
(case event-key
(:button-press (call-hook *button-press-hook* event-slots))
- (:motion-notify (call-hook *button-motion-notify-hook* event-slots))
(:key-press (call-hook *key-press-hook* event-slots))
(:configure-request (call-hook *configure-request-hook* event-slots))
(:configure-notify (call-hook *configure-notify-hook* event-slots))
@@ -179,84 +197,110 @@
(:property-notify (call-hook *property-notify-hook* event-slots))
(:create-notify (call-hook *create-notify-hook* event-slots))
(:enter-notify (call-hook *enter-notify-hook* event-slots))
- (:exposure (call-hook *exposure-hook* event-slots))))
+ (:exposure (call-hook *exposure-hook* event-slots)))
+ ((or drawable-error window-error) (c)
+ (declare (ignore c))))
+ ;;(dbg "Ignore handle event" c event-slots)))
t)
(defun main-loop ()
(loop
- (with-xlib-protect
- (xlib:display-finish-output *display*)
- (xlib:process-event *display* :handler #'handle-event))))
-;;(dbg "Main loop finish" c)))))
+ (handler-case
+ (progn
+ (display-finish-output *display*)
+ (process-event *display* :handler #'handle-event))
+ ((or match-error window-error drawable-error) (c)
+ (declare (ignore c))))))
+ ;;(dbg "Main loop finish" c)))))
-(defun open-display (display-str protocol)
- (multiple-value-bind (host display-num) (parse-display-string display-str)
- (setf *display* (xlib:open-display host :display display-num :protocol protocol)
- (getenv "DISPLAY") display-str)))
+(defun process-existing-windows (screen)
+ "Windows present when clfswm starts up must be absorbed by clfswm."
+ (let ((children (query-tree (screen-root screen)))
+ (id-list nil))
+ (dolist (win children)
+ (let ((map-state (window-map-state win))
+ (wm-state (window-state win)))
+ (unless (or (eql (window-override-redirect win) :on)
+ (eql win *no-focus-window*))
+ (when (or (eql map-state :viewable)
+ (eql wm-state +iconic-state+))
+ (format t "Processing ~S ~S~%" (wm-name win) win)
+ (unhide-window win)
+ (process-new-window win)
+ (map-window win)
+ (push (window-id win) id-list)))))
+ (netwm-set-client-list id-list)))
-(defun init-display ()
- (setf *screen* (first (xlib:display-roots *display*))
- *root* (xlib:screen-root *screen*)
- *no-focus-window* (xlib:create-window :parent *root* :x 0 :y 0 :width 1 :height 1)
- *root-gc* (xlib:create-gcontext :drawable *root*
- :foreground (get-color *color-unselected*)
- :background (get-color "Black")
- :line-style :solid)
- *default-font* (xlib:open-font *display* *default-font-string*))
+
+
+
+
+
+(defun parse-display-string (display)
+ "Parse an X11 DISPLAY string and return the host and display from it."
+ (let* ((colon (position #\: display))
+ (host (subseq display 0 colon))
+ (rest (subseq display (1+ colon)))
+ (dot (position #\. rest))
+ (num (parse-integer (subseq rest 0 dot))))
+ (values host num)))
+
+
+
+(defun init-display (display-str protocol)
+ (multiple-value-bind (host display-num) (parse-display-string display-str)
+ (setf *display* (open-display host :display display-num :protocol protocol)
+ *screen* (first (display-roots *display*))
+ *root* (screen-root *screen*)
+ *no-focus-window* (create-window :parent *root* :x 0 :y 0 :width 1 :height 1)
+ *root-gc* (create-gcontext :drawable *root*
+ :foreground (get-color *color-unselected*)
+ :background (get-color "Black")
+ :line-style :solid)))
(xgrab-init-pointer)
(xgrab-init-keyboard)
- ;;(xgrab-pointer *root* 66 67 '(:enter-window :button-press :button-release) t) ;; PHIL
- ;;(grab-pointer *root* '(:button-press :button-release)
- ;; :owner-p t :sync-keyboard-p nil :sync-pointer-p nil)
- ;;(grab-button *root* 1 nil ;;'(:button-press :button-release)
- ;; :owner-p nil :sync-keyboard-p nil :sync-pointer-p nil)
- ;;(xlib:grab-pointer *root* nil :owner-p nil)
- (xlib:map-window *no-focus-window*)
+ (map-window *no-focus-window*)
+ (setf *workspace-list* nil
+ *current-workspace-number* 0
+ *open-next-window-in-new-workspace* nil
+ *open-next-window-in-new-group* nil
+ *arrow-action* nil
+ *pager-arrow-action* nil)
+ (destructuring-bind (x y width height) *fullscreen*
+ (setf *default-group* (make-group :x x :y y :width width :height height :fullscreenp nil)))
+ (add-workspace (make-workspace :number (incf *current-workspace-number*)
+ :group-list (list (copy-group *default-group*))))
+ (setf (group-fullscreenp (current-group)) t)
(dbg *display*)
- (setf (xlib:window-event-mask *root*) (xlib:make-event-mask :substructure-redirect
- :substructure-notify
- :property-change
- :exposure
- :button-press))
- ;;(intern-atoms *display*)
+ (setf (getenv "DISPLAY") display-str)
+ (setf (window-event-mask *root*)
+ '(:substructure-redirect
+ :substructure-notify
+ :property-change
+ :exposure))
(netwm-set-properties)
- (xlib:display-force-output *display*)
- (setf *child-selection* nil)
- (setf *root-group* (create-group :name "Root" :number 0 :layout #'tile-space-layout)
- *current-root* *root-group*
- *current-child* *current-root*)
- (call-hook *init-hook*)
+ (display-force-output *display*)
(process-existing-windows *screen*)
- (show-all-childs)
+ (focus-window (current-window))
+ (show-all-group (current-workspace))
(grab-main-keys)
- (xlib:display-finish-output *display*))
-
-
-
-(defun xdg-config-home ()
- (pathname-directory (concatenate 'string (or (getenv "XDG_CONFIG_HOME")
- (getenv "HOME"))
- "/")))
+ (display-finish-output *display*))
(defun read-conf-file ()
(let* ((user-conf (probe-file (merge-pathnames (user-homedir-pathname) #p".clfswmrc")))
(etc-conf (probe-file #p"/etc/clfswmrc"))
- (config-user-conf (probe-file (make-pathname :directory (append (xdg-config-home) '("clfswm"))
- :name "clfswmrc")))
- (conf (or user-conf etc-conf config-user-conf)))
+ (conf (or user-conf etc-conf)))
(if conf
(handler-case (load conf)
(error (c)
(format t "~2%*** Error loading configurtion file: ~A ***~&~A~%" conf c)
(values nil (format nil "~s" c) conf))
- (:no-error (&rest args)
- (declare (ignore args))
- (values t nil conf)))
+ (:no-error (&rest args) (declare (ignore args)) (values t nil conf)))
(values t nil nil))))
@@ -264,45 +308,18 @@
(defun main (&optional (display-str (or (getenv "DISPLAY") ":0")) protocol)
(read-conf-file)
(handler-case
- (open-display display-str protocol)
- (xlib:access-error (c)
- (format t "~&~A~&Maybe another window manager is running.~%" c)
[44 lines skipped]
--- /project/clfswm/cvsroot/clfswm/config.lisp 2008/02/27 22:34:55 1.9
+++ /project/clfswm/cvsroot/clfswm/config.lisp 2008/05/02 19:56:08 1.10
@@ -1,7 +1,7 @@
;;; --------------------------------------------------------------------------
;;; CLFSWM - FullScreen Window Manager
;;;
-;;; #Date#: Wed Feb 27 22:15:01 2008
+;;; #Date#: Wed Jan 2 23:40:41 2008
;;;
;;; --------------------------------------------------------------------------
;;; Documentation: Configuration file
@@ -41,22 +41,16 @@
;;; CONFIG - Screen size
-(defun get-fullscreen-size ()
- "Return the size of root child (values rx ry rw rh raise-p)
-You can tweak this to what you want"
- (values -1 -1 (xlib:screen-width *screen*) (xlib:screen-height *screen*) nil))
-;; (values -1 -1 1024 768))
-;; (values 100 100 800 600))
-
-
-
-
+;;(defparameter *fullscreen* '(0 0 1024 600))
+(defparameter *fullscreen* '(0 0 1024 768))
+;;(defparameter *fullscreen* '(0 0 1280 960))
+;;(defparameter *fullscreen* '(100 0 1180 960)) ;; Example with a space on left.
+;;(defparameter *fullscreen* '(0 0 800 600))
;;; CONFIG: Main mode colors
(defparameter *color-selected* "Red")
-(defparameter *color-unselected* "Blue")
-(defparameter *color-maybe-selected* "Yellow")
+(defparameter *color-unselected* "Yellow")
;;; CONFIG: Second mode colors and fonts
(defparameter *sm-border-color* "Green")
@@ -95,7 +89,7 @@
;;; CONFIG - Identify key colors
-(defparameter *identify-font-string* "9x15")
+(defparameter *identify-font-string* "9x15bold")
(defparameter *identify-background* "black")
(defparameter *identify-foreground* "green")
(defparameter *identify-border* "red")
@@ -113,7 +107,7 @@
(defparameter *info-foreground* "green")
(defparameter *info-border* "red")
(defparameter *info-line-cursor* "white")
-(defparameter *info-font-string* "9x15")
+(defparameter *info-font-string* "9x15bold")
--- /project/clfswm/cvsroot/clfswm/dot-clfswmrc 2008/01/07 20:08:54 1.8
+++ /project/clfswm/cvsroot/clfswm/dot-clfswmrc 2008/05/02 19:56:08 1.9
@@ -146,7 +146,7 @@
;;;; Uncomment the lines below if you want to enable the larswm,
;;;; dwm, wmii... cycling style.
;;;;
-;;;; This leave the main window in one side of the screen and tile others
+;;;; This leave the main window in on side of the screen and tile others
;;;; on the other side. It can be configured in the rc file or interactively
;;;; with the function 'reconfigure-tile-workspace'.
;;;;
--- /project/clfswm/cvsroot/clfswm/keysyms.lisp 2008/02/24 20:53:37 1.2
+++ /project/clfswm/cvsroot/clfswm/keysyms.lisp 2008/05/02 19:56:08 1.3
@@ -49,8 +49,8 @@
(declare (ignore present-p))
value))
-(cl-define-keysym #xffffff "VoidSymbol") ;Void symbol
-(cl-define-keysym #xff08 "BackSpace") ;Back space, back char
+(cl-define-keysym #xffffff "VoidSymbol") ;Void symbol
+(cl-define-keysym #xff08 "BackSpace") ;Back space, back char
(cl-define-keysym #xff09 "Tab")
(cl-define-keysym #xff0a "Linefeed") ;Linefeed, LF
(cl-define-keysym #xff0b "Clear")
@@ -59,60 +59,60 @@
(cl-define-keysym #xff14 "Scroll_Lock")
(cl-define-keysym #xff15 "Sys_Req")
(cl-define-keysym #xff1b "Escape")
-(cl-define-keysym #xffff "Delete") ;Delete, rubout
+(cl-define-keysym #xffff "Delete") ;Delete, rubout
(cl-define-keysym #xff20 "Multi_key") ;Multi-key character compose
(cl-define-keysym #xff37 "Codeinput")
(cl-define-keysym #xff3c "SingleCandidate")
(cl-define-keysym #xff3d "MultipleCandidate")
(cl-define-keysym #xff3e "PreviousCandidate")
-(cl-define-keysym #xff21 "Kanji") ;Kanji, Kanji convert
+(cl-define-keysym #xff21 "Kanji") ;Kanji, Kanji convert
(cl-define-keysym #xff22 "Muhenkan") ;Cancel Conversion
(cl-define-keysym #xff23 "Henkan_Mode") ;Start/Stop Conversion
-(cl-define-keysym #xff23 "Henkan") ;Alias for Henkan_Mode
-(cl-define-keysym #xff24 "Romaji") ;to Romaji
+(cl-define-keysym #xff23 "Henkan") ;Alias for Henkan_Mode
+(cl-define-keysym #xff24 "Romaji") ;to Romaji
(cl-define-keysym #xff25 "Hiragana") ;to Hiragana
(cl-define-keysym #xff26 "Katakana") ;to Katakana
(cl-define-keysym #xff27 "Hiragana_Katakana") ;Hiragana/Katakana toggle
-(cl-define-keysym #xff28 "Zenkaku") ;to Zenkaku
-(cl-define-keysym #xff29 "Hankaku") ;to Hankaku
+(cl-define-keysym #xff28 "Zenkaku") ;to Zenkaku
+(cl-define-keysym #xff29 "Hankaku") ;to Hankaku
(cl-define-keysym #xff2a "Zenkaku_Hankaku") ;Zenkaku/Hankaku toggle
-(cl-define-keysym #xff2b "Touroku") ;Add to Dictionary
-(cl-define-keysym #xff2c "Massyo") ;Delete from Dictionary
-(cl-define-keysym #xff2d "Kana_Lock") ;Kana Lock
-(cl-define-keysym #xff2e "Kana_Shift") ;Kana Shift
-(cl-define-keysym #xff2f "Eisu_Shift") ;Alphanumeric Shift
-(cl-define-keysym #xff30 "Eisu_toggle") ;Alphanumeric toggle
-(cl-define-keysym #xff37 "Kanji_Bangou") ;Codeinput
+(cl-define-keysym #xff2b "Touroku") ;Add to Dictionary
+(cl-define-keysym #xff2c "Massyo") ;Delete from Dictionary
+(cl-define-keysym #xff2d "Kana_Lock") ;Kana Lock
+(cl-define-keysym #xff2e "Kana_Shift") ;Kana Shift
+(cl-define-keysym #xff2f "Eisu_Shift") ;Alphanumeric Shift
+(cl-define-keysym #xff30 "Eisu_toggle") ;Alphanumeric toggle
+(cl-define-keysym #xff37 "Kanji_Bangou") ;Codeinput
(cl-define-keysym #xff3d "Zen_Koho") ;Multiple/All Candidate(s)
(cl-define-keysym #xff3e "Mae_Koho") ;Previous Candidate
(cl-define-keysym #xff50 "Home")
-(cl-define-keysym #xff51 "Left") ;Move left, left arrow
+(cl-define-keysym #xff51 "Left") ;Move left, left arrow
(cl-define-keysym #xff52 "Up") ;Move up, up arrow
-(cl-define-keysym #xff53 "Right") ;Move right, right arrow
-(cl-define-keysym #xff54 "Down") ;Move down, down arrow
-(cl-define-keysym #xff55 "Prior") ;Prior, previous
+(cl-define-keysym #xff53 "Right") ;Move right, right arrow
+(cl-define-keysym #xff54 "Down") ;Move down, down arrow
+(cl-define-keysym #xff55 "Prior") ;Prior, previous
(cl-define-keysym #xff55 "Page_Up")
-(cl-define-keysym #xff56 "Next") ;Next
+(cl-define-keysym #xff56 "Next") ;Next
(cl-define-keysym #xff56 "Page_Down")
-(cl-define-keysym #xff57 "End") ;EOL
+(cl-define-keysym #xff57 "End") ;EOL
(cl-define-keysym #xff58 "Begin") ;BOL
(cl-define-keysym #xff60 "Select") ;Select, mark
(cl-define-keysym #xff61 "Print")
-(cl-define-keysym #xff62 "Execute") ;Execute, run, do
+(cl-define-keysym #xff62 "Execute") ;Execute, run, do
(cl-define-keysym #xff63 "Insert") ;Insert, insert here
(cl-define-keysym #xff65 "Undo")
-(cl-define-keysym #xff66 "Redo") ;Redo, again
+(cl-define-keysym #xff66 "Redo") ;Redo, again
(cl-define-keysym #xff67 "Menu")
(cl-define-keysym #xff68 "Find") ;Find, search
-(cl-define-keysym #xff69 "Cancel") ;Cancel, stop, abort, exit
-(cl-define-keysym #xff6a "Help") ;Help
+(cl-define-keysym #xff69 "Cancel") ;Cancel, stop, abort, exit
+(cl-define-keysym #xff6a "Help") ;Help
(cl-define-keysym #xff6b "Break")
-(cl-define-keysym #xff7e "Mode_switch") ;Character set switch
-(cl-define-keysym #xff7e "script_switch") ;Alias for mode_switch
+(cl-define-keysym #xff7e "Mode_switch") ;Character set switch
+(cl-define-keysym #xff7e "script_switch") ;Alias for mode_switch
(cl-define-keysym #xff7f "Num_Lock")
(cl-define-keysym #xff80 "KP_Space") ;Space
(cl-define-keysym #xff89 "KP_Tab")
-(cl-define-keysym #xff8d "KP_Enter") ;Enter
+(cl-define-keysym #xff8d "KP_Enter") ;Enter
(cl-define-keysym #xff91 "KP_F1") ;PF1, KP_A, ...
(cl-define-keysym #xff92 "KP_F2")
(cl-define-keysym #xff93 "KP_F3")
@@ -133,7 +133,7 @@
(cl-define-keysym #xffbd "KP_Equal") ;Equals
(cl-define-keysym #xffaa "KP_Multiply")
(cl-define-keysym #xffab "KP_Add")
-(cl-define-keysym #xffac "KP_Separator") ;Separator, often comma
+(cl-define-keysym #xffac "KP_Separator") ;Separator, often comma
(cl-define-keysym #xffad "KP_Subtract")
(cl-define-keysym #xffae "KP_Decimal")
(cl-define-keysym #xffaf "KP_Divide")
@@ -213,10 +213,10 @@
(cl-define-keysym #xffe4 "Control_R") ;Right control
(cl-define-keysym #xffe5 "Caps_Lock") ;Caps lock
(cl-define-keysym #xffe6 "Shift_Lock") ;Shift lock
-(cl-define-keysym #xffe7 "Meta_L") ;Left meta
-(cl-define-keysym #xffe8 "Meta_R") ;Right meta
-(cl-define-keysym #xffe9 "Alt_L") ;Left alt
-(cl-define-keysym #xffea "Alt_R") ;Right alt
+(cl-define-keysym #xffe7 "Meta_L") ;Left meta
+(cl-define-keysym #xffe8 "Meta_R") ;Right meta
+(cl-define-keysym #xffe9 "Alt_L") ;Left alt
+(cl-define-keysym #xffea "Alt_R") ;Right alt
(cl-define-keysym #xffeb "Super_L") ;Left super
(cl-define-keysym #xffec "Super_R") ;Right super
(cl-define-keysym #xffed "Hyper_L") ;Left hyper
@@ -354,10 +354,10 @@
(cl-define-keysym #xfd1d "3270_PrintScreen")
(cl-define-keysym #xfd1e "3270_Enter")
(cl-define-keysym #x0020 "space") ;U+0020 SPACE
-(cl-define-keysym #x0021 "exclam") ;U+0021 EXCLAMATION MARK
+(cl-define-keysym #x0021 "exclam") ;U+0021 EXCLAMATION MARK
(cl-define-keysym #x0022 "quotedbl") ;U+0022 QUOTATION MARK
(cl-define-keysym #x0023 "numbersign") ;U+0023 NUMBER SIGN
-(cl-define-keysym #x0024 "dollar") ;U+0024 DOLLAR SIGN
+(cl-define-keysym #x0024 "dollar") ;U+0024 DOLLAR SIGN
(cl-define-keysym #x0025 "percent") ;U+0025 PERCENT SIGN
(cl-define-keysym #x0026 "ampersand") ;U+0026 AMPERSAND
(cl-define-keysym #x0027 "apostrophe") ;U+0027 APOSTROPHE
@@ -365,11 +365,11 @@
(cl-define-keysym #x0028 "parenleft") ;U+0028 LEFT PARENTHESIS
(cl-define-keysym #x0029 "parenright") ;U+0029 RIGHT PARENTHESIS
(cl-define-keysym #x002a "asterisk") ;U+002A ASTERISK
-(cl-define-keysym #x002b "plus") ;U+002B PLUS SIGN
-(cl-define-keysym #x002c "comma") ;U+002C COMMA
-(cl-define-keysym #x002d "minus") ;U+002D HYPHEN-MINUS
-(cl-define-keysym #x002e "period") ;U+002E FULL STOP
-(cl-define-keysym #x002f "slash") ;U+002F SOLIDUS
+(cl-define-keysym #x002b "plus") ;U+002B PLUS SIGN
+(cl-define-keysym #x002c "comma") ;U+002C COMMA
+(cl-define-keysym #x002d "minus") ;U+002D HYPHEN-MINUS
+(cl-define-keysym #x002e "period") ;U+002E FULL STOP
+(cl-define-keysym #x002f "slash") ;U+002F SOLIDUS
(cl-define-keysym #x0030 "0") ;U+0030 DIGIT ZERO
(cl-define-keysym #x0031 "1") ;U+0031 DIGIT ONE
(cl-define-keysym #x0032 "2") ;U+0032 DIGIT TWO
@@ -380,79 +380,79 @@
(cl-define-keysym #x0037 "7") ;U+0037 DIGIT SEVEN
(cl-define-keysym #x0038 "8") ;U+0038 DIGIT EIGHT
(cl-define-keysym #x0039 "9") ;U+0039 DIGIT NINE
-(cl-define-keysym #x003a "colon") ;U+003A COLON
+(cl-define-keysym #x003a "colon") ;U+003A COLON
(cl-define-keysym #x003b "semicolon") ;U+003B SEMICOLON
-(cl-define-keysym #x003c "less") ;U+003C LESS-THAN SIGN
-(cl-define-keysym #x003d "equal") ;U+003D EQUALS SIGN
+(cl-define-keysym #x003c "less") ;U+003C LESS-THAN SIGN
+(cl-define-keysym #x003d "equal") ;U+003D EQUALS SIGN
(cl-define-keysym #x003e "greater") ;U+003E GREATER-THAN SIGN
(cl-define-keysym #x003f "question") ;U+003F QUESTION MARK
(cl-define-keysym #x0040 "at") ;U+0040 COMMERCIAL AT
-(cl-define-keysym #x0041 "A") ;U+0041 LATIN CAPITAL LETTER A
-(cl-define-keysym #x0042 "B") ;U+0042 LATIN CAPITAL LETTER B
-(cl-define-keysym #x0043 "C") ;U+0043 LATIN CAPITAL LETTER C
-(cl-define-keysym #x0044 "D") ;U+0044 LATIN CAPITAL LETTER D
-(cl-define-keysym #x0045 "E") ;U+0045 LATIN CAPITAL LETTER E
-(cl-define-keysym #x0046 "F") ;U+0046 LATIN CAPITAL LETTER F
-(cl-define-keysym #x0047 "G") ;U+0047 LATIN CAPITAL LETTER G
-(cl-define-keysym #x0048 "H") ;U+0048 LATIN CAPITAL LETTER H
-(cl-define-keysym #x0049 "I") ;U+0049 LATIN CAPITAL LETTER I
-(cl-define-keysym #x004a "J") ;U+004A LATIN CAPITAL LETTER J
-(cl-define-keysym #x004b "K") ;U+004B LATIN CAPITAL LETTER K
-(cl-define-keysym #x004c "L") ;U+004C LATIN CAPITAL LETTER L
-(cl-define-keysym #x004d "M") ;U+004D LATIN CAPITAL LETTER M
-(cl-define-keysym #x004e "N") ;U+004E LATIN CAPITAL LETTER N
-(cl-define-keysym #x004f "O") ;U+004F LATIN CAPITAL LETTER O
-(cl-define-keysym #x0050 "P") ;U+0050 LATIN CAPITAL LETTER P
-(cl-define-keysym #x0051 "Q") ;U+0051 LATIN CAPITAL LETTER Q
-(cl-define-keysym #x0052 "R") ;U+0052 LATIN CAPITAL LETTER R
-(cl-define-keysym #x0053 "S") ;U+0053 LATIN CAPITAL LETTER S
-(cl-define-keysym #x0054 "T") ;U+0054 LATIN CAPITAL LETTER T
-(cl-define-keysym #x0055 "U") ;U+0055 LATIN CAPITAL LETTER U
-(cl-define-keysym #x0056 "V") ;U+0056 LATIN CAPITAL LETTER V
-(cl-define-keysym #x0057 "W") ;U+0057 LATIN CAPITAL LETTER W
-(cl-define-keysym #x0058 "X") ;U+0058 LATIN CAPITAL LETTER X
-(cl-define-keysym #x0059 "Y") ;U+0059 LATIN CAPITAL LETTER Y
-(cl-define-keysym #x005a "Z") ;U+005A LATIN CAPITAL LETTER Z
+(cl-define-keysym #x0041 "A") ;U+0041 LATIN CAPITAL LETTER A
+(cl-define-keysym #x0042 "B") ;U+0042 LATIN CAPITAL LETTER B
+(cl-define-keysym #x0043 "C") ;U+0043 LATIN CAPITAL LETTER C
+(cl-define-keysym #x0044 "D") ;U+0044 LATIN CAPITAL LETTER D
+(cl-define-keysym #x0045 "E") ;U+0045 LATIN CAPITAL LETTER E
+(cl-define-keysym #x0046 "F") ;U+0046 LATIN CAPITAL LETTER F
+(cl-define-keysym #x0047 "G") ;U+0047 LATIN CAPITAL LETTER G
+(cl-define-keysym #x0048 "H") ;U+0048 LATIN CAPITAL LETTER H
+(cl-define-keysym #x0049 "I") ;U+0049 LATIN CAPITAL LETTER I
+(cl-define-keysym #x004a "J") ;U+004A LATIN CAPITAL LETTER J
+(cl-define-keysym #x004b "K") ;U+004B LATIN CAPITAL LETTER K
+(cl-define-keysym #x004c "L") ;U+004C LATIN CAPITAL LETTER L
+(cl-define-keysym #x004d "M") ;U+004D LATIN CAPITAL LETTER M
+(cl-define-keysym #x004e "N") ;U+004E LATIN CAPITAL LETTER N
+(cl-define-keysym #x004f "O") ;U+004F LATIN CAPITAL LETTER O
+(cl-define-keysym #x0050 "P") ;U+0050 LATIN CAPITAL LETTER P
+(cl-define-keysym #x0051 "Q") ;U+0051 LATIN CAPITAL LETTER Q
+(cl-define-keysym #x0052 "R") ;U+0052 LATIN CAPITAL LETTER R
+(cl-define-keysym #x0053 "S") ;U+0053 LATIN CAPITAL LETTER S
+(cl-define-keysym #x0054 "T") ;U+0054 LATIN CAPITAL LETTER T
+(cl-define-keysym #x0055 "U") ;U+0055 LATIN CAPITAL LETTER U
+(cl-define-keysym #x0056 "V") ;U+0056 LATIN CAPITAL LETTER V
+(cl-define-keysym #x0057 "W") ;U+0057 LATIN CAPITAL LETTER W
+(cl-define-keysym #x0058 "X") ;U+0058 LATIN CAPITAL LETTER X
+(cl-define-keysym #x0059 "Y") ;U+0059 LATIN CAPITAL LETTER Y
+(cl-define-keysym #x005a "Z") ;U+005A LATIN CAPITAL LETTER Z
(cl-define-keysym #x005b "bracketleft") ;U+005B LEFT SQUARE BRACKET
(cl-define-keysym #x005c "backslash") ;U+005C REVERSE SOLIDUS
-(cl-define-keysym #x005d "bracketright") ;U+005D RIGHT SQUARE BRACKET
-(cl-define-keysym #x005e "asciicircum") ;U+005E CIRCUMFLEX ACCENT
-(cl-define-keysym #x005f "underscore") ;U+005F LOW LINE
-(cl-define-keysym #x0060 "grave") ;U+0060 GRAVE ACCENT
-(cl-define-keysym #x0060 "quoteleft") ;deprecated
-(cl-define-keysym #x0061 "a") ;U+0061 LATIN SMALL LETTER A
-(cl-define-keysym #x0062 "b") ;U+0062 LATIN SMALL LETTER B
-(cl-define-keysym #x0063 "c") ;U+0063 LATIN SMALL LETTER C
-(cl-define-keysym #x0064 "d") ;U+0064 LATIN SMALL LETTER D
-(cl-define-keysym #x0065 "e") ;U+0065 LATIN SMALL LETTER E
-(cl-define-keysym #x0066 "f") ;U+0066 LATIN SMALL LETTER F
-(cl-define-keysym #x0067 "g") ;U+0067 LATIN SMALL LETTER G
-(cl-define-keysym #x0068 "h") ;U+0068 LATIN SMALL LETTER H
-(cl-define-keysym #x0069 "i") ;U+0069 LATIN SMALL LETTER I
-(cl-define-keysym #x006a "j") ;U+006A LATIN SMALL LETTER J
-(cl-define-keysym #x006b "k") ;U+006B LATIN SMALL LETTER K
-(cl-define-keysym #x006c "l") ;U+006C LATIN SMALL LETTER L
-(cl-define-keysym #x006d "m") ;U+006D LATIN SMALL LETTER M
-(cl-define-keysym #x006e "n") ;U+006E LATIN SMALL LETTER N
-(cl-define-keysym #x006f "o") ;U+006F LATIN SMALL LETTER O
-(cl-define-keysym #x0070 "p") ;U+0070 LATIN SMALL LETTER P
-(cl-define-keysym #x0071 "q") ;U+0071 LATIN SMALL LETTER Q
-(cl-define-keysym #x0072 "r") ;U+0072 LATIN SMALL LETTER R
-(cl-define-keysym #x0073 "s") ;U+0073 LATIN SMALL LETTER S
-(cl-define-keysym #x0074 "t") ;U+0074 LATIN SMALL LETTER T
-(cl-define-keysym #x0075 "u") ;U+0075 LATIN SMALL LETTER U
-(cl-define-keysym #x0076 "v") ;U+0076 LATIN SMALL LETTER V
-(cl-define-keysym #x0077 "w") ;U+0077 LATIN SMALL LETTER W
-(cl-define-keysym #x0078 "x") ;U+0078 LATIN SMALL LETTER X
-(cl-define-keysym #x0079 "y") ;U+0079 LATIN SMALL LETTER Y
-(cl-define-keysym #x007a "z") ;U+007A LATIN SMALL LETTER Z
-(cl-define-keysym #x007b "braceleft") ;U+007B LEFT CURLY BRACKET
-(cl-define-keysym #x007c "bar") ;U+007C VERTICAL LINE
-(cl-define-keysym #x007d "braceright") ;U+007D RIGHT CURLY BRACKET
-(cl-define-keysym #x007e "asciitilde") ;U+007E TILDE
-(cl-define-keysym #x00a0 "nobreakspace") ;U+00A0 NO-BREAK SPACE
-(cl-define-keysym #x00a1 "exclamdown") ;U+00A1 INVERTED EXCLAMATION MARK
-(cl-define-keysym #x00a2 "cent") ;U+00A2 CENT SIGN
+(cl-define-keysym #x005d "bracketright") ;U+005D RIGHT SQUARE BRACKET
+(cl-define-keysym #x005e "asciicircum") ;U+005E CIRCUMFLEX ACCENT
+(cl-define-keysym #x005f "underscore") ;U+005F LOW LINE
+(cl-define-keysym #x0060 "grave") ;U+0060 GRAVE ACCENT
+(cl-define-keysym #x0060 "quoteleft") ;deprecated
+(cl-define-keysym #x0061 "a") ;U+0061 LATIN SMALL LETTER A
+(cl-define-keysym #x0062 "b") ;U+0062 LATIN SMALL LETTER B
+(cl-define-keysym #x0063 "c") ;U+0063 LATIN SMALL LETTER C
+(cl-define-keysym #x0064 "d") ;U+0064 LATIN SMALL LETTER D
+(cl-define-keysym #x0065 "e") ;U+0065 LATIN SMALL LETTER E
+(cl-define-keysym #x0066 "f") ;U+0066 LATIN SMALL LETTER F
+(cl-define-keysym #x0067 "g") ;U+0067 LATIN SMALL LETTER G
+(cl-define-keysym #x0068 "h") ;U+0068 LATIN SMALL LETTER H
+(cl-define-keysym #x0069 "i") ;U+0069 LATIN SMALL LETTER I
+(cl-define-keysym #x006a "j") ;U+006A LATIN SMALL LETTER J
+(cl-define-keysym #x006b "k") ;U+006B LATIN SMALL LETTER K
+(cl-define-keysym #x006c "l") ;U+006C LATIN SMALL LETTER L
+(cl-define-keysym #x006d "m") ;U+006D LATIN SMALL LETTER M
+(cl-define-keysym #x006e "n") ;U+006E LATIN SMALL LETTER N
+(cl-define-keysym #x006f "o") ;U+006F LATIN SMALL LETTER O
+(cl-define-keysym #x0070 "p") ;U+0070 LATIN SMALL LETTER P
+(cl-define-keysym #x0071 "q") ;U+0071 LATIN SMALL LETTER Q
+(cl-define-keysym #x0072 "r") ;U+0072 LATIN SMALL LETTER R
+(cl-define-keysym #x0073 "s") ;U+0073 LATIN SMALL LETTER S
+(cl-define-keysym #x0074 "t") ;U+0074 LATIN SMALL LETTER T
+(cl-define-keysym #x0075 "u") ;U+0075 LATIN SMALL LETTER U
+(cl-define-keysym #x0076 "v") ;U+0076 LATIN SMALL LETTER V
+(cl-define-keysym #x0077 "w") ;U+0077 LATIN SMALL LETTER W
+(cl-define-keysym #x0078 "x") ;U+0078 LATIN SMALL LETTER X
+(cl-define-keysym #x0079 "y") ;U+0079 LATIN SMALL LETTER Y
+(cl-define-keysym #x007a "z") ;U+007A LATIN SMALL LETTER Z
+(cl-define-keysym #x007b "braceleft") ;U+007B LEFT CURLY BRACKET
+(cl-define-keysym #x007c "bar") ;U+007C VERTICAL LINE
+(cl-define-keysym #x007d "braceright") ;U+007D RIGHT CURLY BRACKET
+(cl-define-keysym #x007e "asciitilde") ;U+007E TILDE
+(cl-define-keysym #x00a0 "nobreakspace") ;U+00A0 NO-BREAK SPACE
+(cl-define-keysym #x00a1 "exclamdown") ;U+00A1 INVERTED EXCLAMATION MARK
+(cl-define-keysym #x00a2 "cent") ;U+00A2 CENT SIGN
(cl-define-keysym #x00a3 "sterling") ;U+00A3 POUND SIGN
(cl-define-keysym #x00a4 "currency") ;U+00A4 CURRENCY SIGN
(cl-define-keysym #x00a5 "yen") ;U+00A5 YEN SIGN
@@ -461,630 +461,630 @@
(cl-define-keysym #x00a8 "diaeresis") ;U+00A8 DIAERESIS
(cl-define-keysym #x00a9 "copyright") ;U+00A9 COPYRIGHT SIGN
(cl-define-keysym #x00aa "ordfeminine") ;U+00AA FEMININE ORDINAL INDICATOR
-(cl-define-keysym #x00ab "guillemotleft") ;U+00AB LEFT-POINTING DOUBLE ANGLE QUOTATION MARK
-(cl-define-keysym #x00ac "notsign") ;U+00AC NOT SIGN
-(cl-define-keysym #x00ad "hyphen") ;U+00AD SOFT HYPHEN
-(cl-define-keysym #x00ae "registered") ;U+00AE REGISTERED SIGN
-(cl-define-keysym #x00af "macron") ;U+00AF MACRON
-(cl-define-keysym #x00b0 "degree") ;U+00B0 DEGREE SIGN
-(cl-define-keysym #x00b1 "plusminus") ;U+00B1 PLUS-MINUS SIGN
-(cl-define-keysym #x00b2 "twosuperior") ;U+00B2 SUPERSCRIPT TWO
-(cl-define-keysym #x00b3 "threesuperior") ;U+00B3 SUPERSCRIPT THREE
-(cl-define-keysym #x00b4 "acute") ;U+00B4 ACUTE ACCENT
-(cl-define-keysym #x00b5 "mu") ;U+00B5 MICRO SIGN
-(cl-define-keysym #x00b6 "paragraph") ;U+00B6 PILCROW SIGN
-(cl-define-keysym #x00b7 "periodcentered") ;U+00B7 MIDDLE DOT
-(cl-define-keysym #x00b8 "cedilla") ;U+00B8 CEDILLA
-(cl-define-keysym #x00b9 "onesuperior") ;U+00B9 SUPERSCRIPT ONE
-(cl-define-keysym #x00ba "masculine") ;U+00BA MASCULINE ORDINAL INDICATOR
-(cl-define-keysym #x00bb "guillemotright") ;U+00BB RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK
-(cl-define-keysym #x00bc "onequarter") ;U+00BC VULGAR FRACTION ONE QUARTER
-(cl-define-keysym #x00bd "onehalf") ;U+00BD VULGAR FRACTION ONE HALF
-(cl-define-keysym #x00be "threequarters") ;U+00BE VULGAR FRACTION THREE QUARTERS
-(cl-define-keysym #x00bf "questiondown") ;U+00BF INVERTED QUESTION MARK
-(cl-define-keysym #x00c0 "Agrave") ;U+00C0 LATIN CAPITAL LETTER A WITH GRAVE
-(cl-define-keysym #x00c1 "Aacute") ;U+00C1 LATIN CAPITAL LETTER A WITH ACUTE
+(cl-define-keysym #x00ab "guillemotleft") ;U+00AB LEFT-POINTING DOUBLE ANGLE QUOTATION MARK
+(cl-define-keysym #x00ac "notsign") ;U+00AC NOT SIGN
+(cl-define-keysym #x00ad "hyphen") ;U+00AD SOFT HYPHEN
+(cl-define-keysym #x00ae "registered") ;U+00AE REGISTERED SIGN
+(cl-define-keysym #x00af "macron") ;U+00AF MACRON
+(cl-define-keysym #x00b0 "degree") ;U+00B0 DEGREE SIGN
+(cl-define-keysym #x00b1 "plusminus") ;U+00B1 PLUS-MINUS SIGN
+(cl-define-keysym #x00b2 "twosuperior") ;U+00B2 SUPERSCRIPT TWO
+(cl-define-keysym #x00b3 "threesuperior") ;U+00B3 SUPERSCRIPT THREE
+(cl-define-keysym #x00b4 "acute") ;U+00B4 ACUTE ACCENT
+(cl-define-keysym #x00b5 "mu") ;U+00B5 MICRO SIGN
+(cl-define-keysym #x00b6 "paragraph") ;U+00B6 PILCROW SIGN
+(cl-define-keysym #x00b7 "periodcentered") ;U+00B7 MIDDLE DOT
+(cl-define-keysym #x00b8 "cedilla") ;U+00B8 CEDILLA
+(cl-define-keysym #x00b9 "onesuperior") ;U+00B9 SUPERSCRIPT ONE
+(cl-define-keysym #x00ba "masculine") ;U+00BA MASCULINE ORDINAL INDICATOR
+(cl-define-keysym #x00bb "guillemotright") ;U+00BB RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK
+(cl-define-keysym #x00bc "onequarter") ;U+00BC VULGAR FRACTION ONE QUARTER
+(cl-define-keysym #x00bd "onehalf") ;U+00BD VULGAR FRACTION ONE HALF
+(cl-define-keysym #x00be "threequarters") ;U+00BE VULGAR FRACTION THREE QUARTERS
+(cl-define-keysym #x00bf "questiondown") ;U+00BF INVERTED QUESTION MARK
+(cl-define-keysym #x00c0 "Agrave") ;U+00C0 LATIN CAPITAL LETTER A WITH GRAVE
+(cl-define-keysym #x00c1 "Aacute") ;U+00C1 LATIN CAPITAL LETTER A WITH ACUTE
(cl-define-keysym #x00c2 "Acircumflex") ;U+00C2 LATIN CAPITAL LETTER A WITH CIRCUMFLEX
-(cl-define-keysym #x00c3 "Atilde") ;U+00C3 LATIN CAPITAL LETTER A WITH TILDE
-(cl-define-keysym #x00c4 "Adiaeresis") ;U+00C4 LATIN CAPITAL LETTER A WITH DIAERESIS
-(cl-define-keysym #x00c5 "Aring") ;U+00C5 LATIN CAPITAL LETTER A WITH RING ABOVE
-(cl-define-keysym #x00c6 "AE") ;U+00C6 LATIN CAPITAL LETTER AE
-(cl-define-keysym #x00c7 "Ccedilla") ;U+00C7 LATIN CAPITAL LETTER C WITH CEDILLA
-(cl-define-keysym #x00c8 "Egrave") ;U+00C8 LATIN CAPITAL LETTER E WITH GRAVE
-(cl-define-keysym #x00c9 "Eacute") ;U+00C9 LATIN CAPITAL LETTER E WITH ACUTE
+(cl-define-keysym #x00c3 "Atilde") ;U+00C3 LATIN CAPITAL LETTER A WITH TILDE
+(cl-define-keysym #x00c4 "Adiaeresis") ;U+00C4 LATIN CAPITAL LETTER A WITH DIAERESIS
+(cl-define-keysym #x00c5 "Aring") ;U+00C5 LATIN CAPITAL LETTER A WITH RING ABOVE
+(cl-define-keysym #x00c6 "AE") ;U+00C6 LATIN CAPITAL LETTER AE
+(cl-define-keysym #x00c7 "Ccedilla") ;U+00C7 LATIN CAPITAL LETTER C WITH CEDILLA
+(cl-define-keysym #x00c8 "Egrave") ;U+00C8 LATIN CAPITAL LETTER E WITH GRAVE
+(cl-define-keysym #x00c9 "Eacute") ;U+00C9 LATIN CAPITAL LETTER E WITH ACUTE
(cl-define-keysym #x00ca "Ecircumflex") ;U+00CA LATIN CAPITAL LETTER E WITH CIRCUMFLEX
-(cl-define-keysym #x00cb "Ediaeresis") ;U+00CB LATIN CAPITAL LETTER E WITH DIAERESIS
-(cl-define-keysym #x00cc "Igrave") ;U+00CC LATIN CAPITAL LETTER I WITH GRAVE
-(cl-define-keysym #x00cd "Iacute") ;U+00CD LATIN CAPITAL LETTER I WITH ACUTE
+(cl-define-keysym #x00cb "Ediaeresis") ;U+00CB LATIN CAPITAL LETTER E WITH DIAERESIS
+(cl-define-keysym #x00cc "Igrave") ;U+00CC LATIN CAPITAL LETTER I WITH GRAVE
+(cl-define-keysym #x00cd "Iacute") ;U+00CD LATIN CAPITAL LETTER I WITH ACUTE
(cl-define-keysym #x00ce "Icircumflex") ;U+00CE LATIN CAPITAL LETTER I WITH CIRCUMFLEX
-(cl-define-keysym #x00cf "Idiaeresis") ;U+00CF LATIN CAPITAL LETTER I WITH DIAERESIS
-(cl-define-keysym #x00d0 "ETH") ;U+00D0 LATIN CAPITAL LETTER ETH
-(cl-define-keysym #x00d0 "Eth") ;deprecated
-(cl-define-keysym #x00d1 "Ntilde") ;U+00D1 LATIN CAPITAL LETTER N WITH TILDE
-(cl-define-keysym #x00d2 "Ograve") ;U+00D2 LATIN CAPITAL LETTER O WITH GRAVE
-(cl-define-keysym #x00d3 "Oacute") ;U+00D3 LATIN CAPITAL LETTER O WITH ACUTE
+(cl-define-keysym #x00cf "Idiaeresis") ;U+00CF LATIN CAPITAL LETTER I WITH DIAERESIS
+(cl-define-keysym #x00d0 "ETH") ;U+00D0 LATIN CAPITAL LETTER ETH
+(cl-define-keysym #x00d0 "Eth") ;deprecated
+(cl-define-keysym #x00d1 "Ntilde") ;U+00D1 LATIN CAPITAL LETTER N WITH TILDE
+(cl-define-keysym #x00d2 "Ograve") ;U+00D2 LATIN CAPITAL LETTER O WITH GRAVE
+(cl-define-keysym #x00d3 "Oacute") ;U+00D3 LATIN CAPITAL LETTER O WITH ACUTE
(cl-define-keysym #x00d4 "Ocircumflex") ;U+00D4 LATIN CAPITAL LETTER O WITH CIRCUMFLEX
-(cl-define-keysym #x00d5 "Otilde") ;U+00D5 LATIN CAPITAL LETTER O WITH TILDE
-(cl-define-keysym #x00d6 "Odiaeresis") ;U+00D6 LATIN CAPITAL LETTER O WITH DIAERESIS
+(cl-define-keysym #x00d5 "Otilde") ;U+00D5 LATIN CAPITAL LETTER O WITH TILDE
+(cl-define-keysym #x00d6 "Odiaeresis") ;U+00D6 LATIN CAPITAL LETTER O WITH DIAERESIS
(cl-define-keysym #x00d7 "multiply") ;U+00D7 MULTIPLICATION SIGN
-(cl-define-keysym #x00d8 "Oslash") ;U+00D8 LATIN CAPITAL LETTER O WITH STROKE
-(cl-define-keysym #x00d8 "Ooblique") ;U+00D8 LATIN CAPITAL LETTER O WITH STROKE
-(cl-define-keysym #x00d9 "Ugrave") ;U+00D9 LATIN CAPITAL LETTER U WITH GRAVE
-(cl-define-keysym #x00da "Uacute") ;U+00DA LATIN CAPITAL LETTER U WITH ACUTE
+(cl-define-keysym #x00d8 "Oslash") ;U+00D8 LATIN CAPITAL LETTER O WITH STROKE
+(cl-define-keysym #x00d8 "Ooblique") ;U+00D8 LATIN CAPITAL LETTER O WITH STROKE
+(cl-define-keysym #x00d9 "Ugrave") ;U+00D9 LATIN CAPITAL LETTER U WITH GRAVE
+(cl-define-keysym #x00da "Uacute") ;U+00DA LATIN CAPITAL LETTER U WITH ACUTE
[2215 lines skipped]
--- /project/clfswm/cvsroot/clfswm/load.lisp 2008/02/26 22:02:24 1.8
+++ /project/clfswm/cvsroot/clfswm/load.lisp 2008/05/02 19:56:08 1.9
@@ -1,7 +1,7 @@
;;; --------------------------------------------------------------------------
;;; CLFSWM - FullScreen Window Manager
;;;
-;;; #Date#: Tue Feb 26 23:00:22 2008
+;;; #Date#: Fri Dec 21 23:00:32 2007
;;;
;;; --------------------------------------------------------------------------
;;; Documentation: System loading functions
@@ -38,9 +38,6 @@
(require :asdf)
#+SBCL
-(require :sb-posix)
-
-#+SBCL
(require :clx)
#-ASDF
@@ -56,4 +53,4 @@
(in-package :clfswm)
-(clfswm:main ":0")
+(clfswm:main)
--- /project/clfswm/cvsroot/clfswm/netwm-util.lisp 2008/02/24 20:53:37 1.4
+++ /project/clfswm/cvsroot/clfswm/netwm-util.lisp 2008/05/02 19:56:08 1.5
@@ -1,7 +1,7 @@
;;; --------------------------------------------------------------------------
;;; CLFSWM - FullScreen Window Manager
;;;
-;;; #Date#: Wed Feb 20 23:26:21 2008
+;;; #Date#: Fri Dec 21 23:00:38 2007
;;;
;;; --------------------------------------------------------------------------
;;; Documentation: NetWM functions
@@ -31,36 +31,36 @@
;;; Client List functions
(defun netwm-set-client-list (id-list)
- (xlib:change-property *root* :_NET_CLIENT_LIST id-list :window 32))
+ (change-property *root* :_NET_CLIENT_LIST id-list :window 32))
(defun netwm-get-client-list ()
- (xlib:get-property *root* :_NET_CLIENT_LIST))
+ (get-property *root* :_NET_CLIENT_LIST))
(defun netwm-add-in-client-list (window)
(let ((last-list (netwm-get-client-list)))
- (pushnew (xlib:window-id window) last-list)
+ (pushnew (window-id window) last-list)
(netwm-set-client-list last-list)))
(defun netwm-remove-in-client-list (window)
- (netwm-set-client-list (remove (xlib:window-id window) (netwm-get-client-list))))
+ (netwm-set-client-list (remove (window-id window) (netwm-get-client-list))))
-
-;;; Desktop functions ;; +PHIL
+
+;;; Desktop functions
(defun netwm-update-desktop-property ()
- ;; (xlib:change-property *root* :_NET_NUMBER_OF_DESKTOPS
- ;; (list (length *workspace-list*)) :cardinal 32)
- ;; (xlib:change-property *root* :_NET_DESKTOP_GEOMETRY
- ;; (list (xlib:screen-width *screen*)
- ;; (xlib:screen-height *screen*))
- ;; :cardinal 32)
- ;; (xlib:change-property *root* :_NET_DESKTOP_VIEWPORT
- ;; (list 0 0) :cardinal 32)
- ;; (xlib:change-property *root* :_NET_CURRENT_DESKTOP
- ;; (list 1) :cardinal 32)
-;;; TODO
- ;;(xlib:change-property *root* :_NET_DESKTOP_NAMES
- ;; (list "toto" "klm" "poi") :string 8 :transform #'xlib:char->card8))
+ (change-property *root* :_NET_NUMBER_OF_DESKTOPS
+ (list (length *workspace-list*)) :cardinal 32)
+ (change-property *root* :_NET_DESKTOP_GEOMETRY
+ (list (screen-width *screen*)
+ (screen-height *screen*))
+ :cardinal 32)
+ (change-property *root* :_NET_DESKTOP_VIEWPORT
+ (list 0 0) :cardinal 32)
+ (change-property *root* :_NET_CURRENT_DESKTOP
+ (list 1) :cardinal 32)
+ ;;; TODO
+ ;;(change-property *root* :_NET_DESKTOP_NAMES
+ ;; (list "toto" "klm" "poi") :string 8 :transform #'char->card8))
)
@@ -71,25 +71,20 @@
"Set NETWM properties on the root window of the specified screen.
FOCUS-WINDOW is an extra window used for _NET_SUPPORTING_WM_CHECK."
;; _NET_SUPPORTED
- (xlib:change-property *root* :_NET_SUPPORTED
- (mapcar (lambda (a)
- (xlib:intern-atom *display* a))
- (append +netwm-supported+
- (mapcar 'car +netwm-window-types+)))
- :atom 32)
+ (change-property *root* :_NET_SUPPORTED
+ (mapcar (lambda (a)
+ (xlib:intern-atom *display* a))
+ (append +netwm-supported+
+ (mapcar 'car +netwm-window-types+)))
+ :atom 32)
;; _NET_SUPPORTING_WM_CHECK
- (xlib:change-property *root* :_NET_SUPPORTING_WM_CHECK
- (list *no-focus-window*) :window 32
- :transform #'xlib:drawable-id)
- (xlib:change-property *no-focus-window* :_NET_SUPPORTING_WM_CHECK
- (list *no-focus-window*) :window 32
- :transform #'xlib:drawable-id)
- (xlib:change-property *no-focus-window* :_NET_WM_NAME
- "clfswm"
- :string 8 :transform #'xlib:char->card8)
- (netwm-update-desktop-property))
-
-
-
-
-
+ (change-property *root* :_NET_SUPPORTING_WM_CHECK
+ (list *no-focus-window*) :window 32
+ :transform #'drawable-id)
+ (change-property *no-focus-window* :_NET_SUPPORTING_WM_CHECK
+ (list *no-focus-window*) :window 32
+ :transform #'drawable-id)
+ (change-property *no-focus-window* :_NET_WM_NAME
+ "clfswm"
+ :string 8 :transform #'char->card8)
+ (netwm-update-desktop-property))
\ No newline at end of file
--- /project/clfswm/cvsroot/clfswm/package.lisp 2008/02/26 22:02:02 1.11
+++ /project/clfswm/cvsroot/clfswm/package.lisp 2008/05/02 19:56:08 1.12
@@ -1,7 +1,7 @@
;;; --------------------------------------------------------------------------
;;; CLFSWM - FullScreen Window Manager
;;;
-;;; #Date#: Mon Feb 25 21:33:22 2008
+;;; #Date#: Tue Jan 1 20:11:50 2008
;;;
;;; --------------------------------------------------------------------------
;;; Documentation: Package definition
@@ -28,12 +28,15 @@
(in-package :cl-user)
(defpackage clfswm
- (:use :common-lisp :my-html :tools)
+ (:use :common-lisp :xlib :my-html :tools)
;;(:shadow :defun)
(:export :main))
(in-package :clfswm)
+(defstruct workspace number group-list)
+(defstruct group x y width height window-list fullscreenp)
+
(defparameter *display* nil)
(defparameter *screen* nil)
@@ -41,53 +44,12 @@
(defparameter *no-focus-window* nil)
(defparameter *root-gc* nil)
-(defparameter *default-font* nil)
-;;(defparameter *default-font-string* "9x15")
-(defparameter *default-font-string* "fixed")
-
-
-(defparameter *child-selection* nil)
-
-(defparameter *layout-list* nil)
-
-
-;;(defstruct group (number (incf *current-group-number*)) name
-;; (x 0) (y 0) (w 1) (h 1) rx ry rw rh
-;; layout window gc child)
-
-(defclass group ()
- ((name :initarg :name :accessor group-name :initform nil)
- (number :initarg :number :accessor group-number :initform 0)
- ;;; Float size between 0 and 1 - Manipulate only this variable and not real size
- (x :initarg :x :accessor group-x :initform 0.1)
- (y :initarg :y :accessor group-y :initform 0.1)
- (w :initarg :w :accessor group-w :initform 0.8)
- (h :initarg :h :accessor group-h :initform 0.8)
- ;;; Real size (integer) in screen size - Don't set directly this variables
- ;;; they may be recalculated by the layout manager.
- (rx :initarg :rx :accessor group-rx :initform 0)
- (ry :initarg :ry :accessor group-ry :initform 0)
- (rw :initarg :rw :accessor group-rw :initform 800)
- (rh :initarg :rh :accessor group-rh :initform 600)
- (layout :initarg :layout :accessor group-layout :initform nil)
- (window :initarg :window :accessor group-window :initform nil)
- (gc :initarg :gc :accessor group-gc :initform nil)
- (child :initarg :child :accessor group-child :initform nil)
- (data :initarg :data :accessor group-data
- :initform (list '(:tile-size 0.8) '(:tile-space-size 0.1))
- :documentation "An assoc list to store additional data")))
-
-(defparameter *root-group* nil
- "Root of the root - ie the root group")
-(defparameter *current-root* nil
- "The current fullscreen maximized child")
-(defparameter *current-child* nil
- "The current child with the focus")
-
-(defparameter *show-root-group-p* nil)
+(defparameter *default-group* nil)
+(defparameter *workspace-list* nil)
+(defparameter *current-workspace-number* 0)
(defparameter *main-keys* (make-hash-table :test 'equal))
(defparameter *second-keys* (make-hash-table :test 'equal))
@@ -125,12 +87,8 @@
;;;
;;; See clfswm.lisp for hooks examples.
-;;; Init hook. This hook is run just after the first root group is created
-(defparameter *init-hook* nil)
-
;;; Main mode hooks (set in clfswm.lisp)
(defparameter *button-press-hook* nil)
-(defparameter *button-motion-notify-hook* nil)
(defparameter *key-press-hook* nil)
(defparameter *configure-request-hook* nil)
(defparameter *configure-notify-hook* nil)
@@ -199,5 +157,5 @@
;; (error (c)
;; (format t "New defun: Error in ~A : ~A~%" ',name c)
;; (format t "Root tree=~A~%All windows=~A~%"
-;; (xlib:query-tree *root*) (get-all-windows))
+;; (query-tree *root*) (get-all-windows))
;; (force-output))))))
--- /project/clfswm/cvsroot/clfswm/tools.lisp 2008/02/26 22:02:02 1.7
+++ /project/clfswm/cvsroot/clfswm/tools.lisp 2008/05/02 19:56:08 1.8
@@ -1,7 +1,7 @@
;;; --------------------------------------------------------------------------
;;; CLFSWM - FullScreen Window Manager
;;;
-;;; #Date#: Tue Feb 26 21:53:55 2008
+;;; #Date#: Thu Jan 3 22:53:59 2008
;;;
;;; --------------------------------------------------------------------------
;;; Documentation: General tools
@@ -30,10 +30,7 @@
(defpackage tools
(:use common-lisp)
- (:export :it
- :awhen
- :aif
- :dbg
+ (:export :dbg
:dbgnl
:setf/=
:create-symbol
@@ -84,13 +81,6 @@
-(defmacro awhen (test &body body)
- `(let ((it ,test))
- (when it
- , at body)))
-
-(defmacro aif (test then &optional else)
- `(let ((it ,test)) (if it ,then ,else)))
;;;,-----
@@ -102,36 +92,36 @@
(defmacro dbg (&rest forms)
`(progn
- ,@(mapcar #'(lambda (form)
- (typecase form
- (string `(setf *%dbg-name%* ,form))
- (number `(setf *%dbg-count%* ,form))))
- forms)
- (format t "~&DEBUG[~A - ~A] " (incf *%dbg-count%*) *%dbg-name%*)
- ,@(mapcar #'(lambda (form)
- (typecase form
- ((or string number) nil)
- (t `(format t "~A=~S " ',form ,form))))
- forms)
- (format t "~%")
- (force-output)
- , at forms))
+ ,@(mapcar #'(lambda (form)
+ (typecase form
+ (string `(setf *%dbg-name%* ,form))
+ (number `(setf *%dbg-count%* ,form))))
+ forms)
+ (format t "~&DEBUG[~A - ~A] " (incf *%dbg-count%*) *%dbg-name%*)
+ ,@(mapcar #'(lambda (form)
+ (typecase form
+ ((or string number) nil)
+ (t `(format t "~A=~S " ',form ,form))))
+ forms)
+ (format t "~%")
+ (force-output)
+ , at forms))
(defmacro dbgnl (&rest forms)
`(progn
- ,@(mapcar #'(lambda (form)
- (typecase form
- (string `(setf *%dbg-name%* ,form))
- (number `(setf *%dbg-count%* ,form))))
- forms)
- (format t "~&DEBUG[~A - ~A] --------------------~%" (incf *%dbg-count%*) *%dbg-name%*)
- ,@(mapcar #'(lambda (form)
- (typecase form
- ((or string number) nil)
- (t `(format t " - ~A=~S~%" ',form ,form))))
- forms)
- (force-output)
- , at forms))
+ ,@(mapcar #'(lambda (form)
+ (typecase form
+ (string `(setf *%dbg-name%* ,form))
+ (number `(setf *%dbg-count%* ,form))))
+ forms)
+ (format t "~&DEBUG[~A - ~A] --------------------~%" (incf *%dbg-count%*) *%dbg-name%*)
+ ,@(mapcar #'(lambda (form)
+ (typecase form
+ ((or string number) nil)
+ (t `(format t " - ~A=~S~%" ',form ,form))))
+ forms)
+ (force-output)
+ , at forms))
@@ -157,10 +147,10 @@
(defun split-string (string &optional (separator #\Space))
"Return a list from a string splited at each separators"
(loop for i = 0 then (1+ j)
- as j = (position separator string :start i)
- as sub = (subseq string i j)
- unless (string= sub "") collect sub
- while j))
+ as j = (position separator string :start i)
+ as sub = (subseq string i j)
+ unless (string= sub "") collect sub
+ while j))
(defun expand-newline (list)
@@ -212,13 +202,13 @@
(zerop (or (search word string) -1)))
-(defun find-free-number (l) ; stolen from stumpwm - thanks
+(defun find-free-number (l) ; stolen from stumpwm - thanks
"Return a number that is not in the list l."
(let* ((nums (sort l #'<))
(new-num (loop for n from 0 to (or (car (last nums)) 0)
- for i in nums
- when (/= n i)
- do (return n))))
+ for i in nums
+ when (/= n i)
+ do (return n))))
(if new-num
new-num
;; there was no space between the numbers, so use the last + 1
@@ -240,21 +230,21 @@
(dolist (a args)
(setf fullstring (concatenate 'string fullstring " " a)))
#+:cmu (let ((proc (ext:run-program program args :input :stream
- :output :stream :wait wt)))
+ :output :stream :wait wt)))
(unless proc
(error "Cannot create process."))
(make-two-way-stream
(ext:process-output proc)
(ext:process-input proc)))
#+:clisp (let ((proc (ext:run-program program :arguments args
- :input :stream :output
- :stream :wait (or wt t))))
+ :input :stream :output
+ :stream :wait (or wt t))))
(unless proc
(error "Cannot create process."))
proc)
#+:sbcl (let ((proc (sb-ext:run-program program args :input
- :stream :output
- :stream :wait wt)))
+ :stream :output
+ :stream :wait wt)))
(unless proc
(error "Cannot create process."))
(make-two-way-stream
@@ -270,8 +260,8 @@
#+:ecl(ext:run-program program args :input :stream :output :stream
:error :output)
#+:openmcl (let ((proc (ccl:run-program program args :input
- :stream :output
- :stream :wait wt)))
+ :stream :output
+ :stream :wait wt)))
(unless proc
(error "Cannot create process."))
(make-two-way-stream
@@ -309,7 +299,7 @@
#+clisp (setf (ext:getenv (string var)) (string val))
#+(or cmu scl)
(let ((cell (assoc (string var) ext:*environment-list* :test #'equalp
- :key #'string)))
+ :key #'string)))
(if cell
(setf (cdr cell) (string val))
(push (cons (intern (string var) "KEYWORD") (string val))
@@ -402,14 +392,14 @@
(defun ushell-loop (&optional (shell-fun #'ushell))
(loop
- (format t "UNI-SHELL> ")
- (let* ((line (read-line)))
- (cond ((zerop (or (search "quit" line) -1)) (return))
- ((zerop (or (position #\! line) -1))
- (funcall shell-fun (subseq line 1)))
- (t (format t "~{~A~^ ;~%~}~%"
- (multiple-value-list
- (ignore-errors (eval (read-from-string line))))))))))
+ (format t "UNI-SHELL> ")
+ (let* ((line (read-line)))
+ (cond ((zerop (or (search "quit" line) -1)) (return))
+ ((zerop (or (position #\! line) -1))
+ (funcall shell-fun (subseq line 1)))
+ (t (format t "~{~A~^ ;~%~}~%"
+ (multiple-value-list
+ (ignore-errors (eval (read-from-string line))))))))))
@@ -435,10 +425,10 @@
(index (position split-char str :start start)
(position split-char str :start start))
(accum nil))
- ((null index)
- (unless (string= (subseq str start) "")
- (push (subseq str start) accum))
- (nreverse accum))
+ ((null index)
+ (unless (string= (subseq str start) "")
+ (push (subseq str start) accum))
+ (nreverse accum))
(when (/= start index)
(push (subseq str start index) accum))))
@@ -452,10 +442,10 @@
(if ret
(if (< pos ret)
pos
- ret)
- pos)
- ret)))
- ((null char) ret)))
+ ret)
+ pos)
+ ret)))
+ ((null char) ret)))
;;;(defun near-position2 (chars str &key (start 0))
@@ -476,10 +466,10 @@
(index (near-position split-chars str :start start)
(near-position split-chars str :start start))
(accum nil))
- ((null index)
- (unless (string= (subseq str start) "")
- (push (subseq str start) accum))
- (nreverse accum))
+ ((null index)
+ (unless (string= (subseq str start) "")
+ (push (subseq str start) accum))
+ (nreverse accum))
(let ((retstr (subseq str start (if preserve (1+ index) index))))
(unless (string= retstr "")
(push retstr accum)))))
@@ -606,7 +596,7 @@
;; ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun find-string (substr str &key (start 0) (end nil)
- (test nil) (ignore-case nil))
+ (test nil) (ignore-case nil))
"Find substr in str. Return begin and end of substr in str as two values.
Start and end set the findinq region. Ignore-case make find-string case
insensitive.
@@ -623,7 +613,7 @@
(do ((done nil))
(done (if (functionp test)
(funcall test str pos1 pos2)
- (values pos1 pos2)))
+ (values pos1 pos2)))
(setq pos1 (position (aref substr 0) str :start (+ pos1 1) :end end))
(unless pos1
(return-from find-string nil))
@@ -634,16 +624,16 @@
(defun find-all-strings (substr str &key (start 0) (end nil)
- (test nil) (ignore-case nil))
+ (test nil) (ignore-case nil))
"Find all substr in str. Parameters are the same as find-string.
Return a list with all begin and end positions of substr in str
ie: '((pos1.1 pos1.2) (pos2.1 pos2.2))..."
(do ((pos (multiple-value-list
(find-string substr str :start start :end end
- :test test :ignore-case ignore-case))
+ :test test :ignore-case ignore-case))
(multiple-value-list
(find-string substr str :start (second pos) :end end
- :test test :ignore-case ignore-case)))
+ :test test :ignore-case ignore-case)))
(accum nil))
((equal pos '(nil)) (nreverse accum))
(push pos accum)))
@@ -651,7 +641,7 @@
(defun subst-strings (new substr str &key (start 0) (end nil)
- (test nil) (ignore-case nil))
+ (test nil) (ignore-case nil))
"Substitute all substr strings in str with new.
New must be a string or a function witch takes str pos1 pos2
as parameters and return a string to replace substr"
@@ -674,20 +664,20 @@
(subseq str pos1 pos2)
(if (functionp new)
(funcall new str pos2 newpos)
- new)))
+ new)))
(setq pos1 (if (and newpos (<= newpos end))
newpos
- end)))
- (progn
- (setq outstr (concatenate 'string
- outstr (subseq str pos1)))
- (setq done t))))))
+ end)))
+ (progn
+ (setq outstr (concatenate 'string
+ outstr (subseq str pos1)))
+ (setq done t))))))
(defun my-find-string-test (str pos1 pos2)
(multiple-value-bind
- (npos1 npos2)
+ (npos1 npos2)
(find-string "=>" str :start pos2)
(declare (ignore npos1))
(values pos1 npos2)))
@@ -709,7 +699,7 @@
(format t "[3] Find with test (ie '<=.*=>'): ~A~%"
(multiple-value-bind
- (pos1 pos2)
+ (pos1 pos2)
(find-string "<=" str :test #'my-find-string-test)
(subseq str pos1 pos2)))
@@ -741,7 +731,7 @@
"<=" str
:test #'(lambda (str pos1 pos2)
(multiple-value-bind
- (npos1 npos2)
+ (npos1 npos2)
(find-string "=>" str :start pos2)
(declare (ignore npos1))
(values pos1 npos2)))))))
--- /project/clfswm/cvsroot/clfswm/xlib-util.lisp 2008/02/29 23:05:56 1.7
+++ /project/clfswm/cvsroot/clfswm/xlib-util.lisp 2008/05/02 19:56:08 1.8
@@ -1,7 +1,7 @@
;;; --------------------------------------------------------------------------
;;; CLFSWM - FullScreen Window Manager
;;;
-;;; #Date#: Thu Feb 28 21:55:00 2008
+;;; #Date#: Thu Jan 3 17:50:59 2008
;;;
;;; --------------------------------------------------------------------------
;;; Documentation: Utility functions
@@ -38,10 +38,7 @@
:property-change
:colormap-change
:focus-change
- :enter-window
- :exposure)
- ;;:button-press
- ;;:button-release)
+ :enter-window)
"The events to listen for on managed windows.")
@@ -57,64 +54,33 @@
Window types are in +WINDOW-TYPES+.")
(defparameter +netwm-window-types+
- '((:_NET_WM_WINDOW_TYPE_DESKTOP . :desktop)
- (:_NET_WM_WINDOW_TYPE_DOCK . :dock)
- (:_NET_WM_WINDOW_TYPE_TOOLBAR . :toolbar)
- (:_NET_WM_WINDOW_TYPE_MENU . :menu)
- (:_NET_WM_WINDOW_TYPE_UTILITY . :utility)
- (:_NET_WM_WINDOW_TYPE_SPLASH . :splash)
+ '(
+ ;; (:_NET_WM_WINDOW_TYPE_DESKTOP . :desktop)
+ ;; (:_NET_WM_WINDOW_TYPE_DOCK . :dock)
+ ;; (:_NET_WM_WINDOW_TYPE_TOOLBAR . :toolbar)
+ ;; (:_NET_WM_WINDOW_TYPE_MENU . :menu)
+ ;; (:_NET_WM_WINDOW_TYPE_UTILITY . :utility)
+ ;; (:_NET_WM_WINDOW_TYPE_SPLASH . :splash)
(:_NET_WM_WINDOW_TYPE_DIALOG . :dialog)
(:_NET_WM_WINDOW_TYPE_NORMAL . :normal))
- "Alist mapping NETWM window types to keywords.")
-
-
-(defmacro with-xlib-protect (&body body)
- "Prevent Xlib errors"
- `(handler-case
- (progn
- , at body)
- ((or xlib:match-error xlib:window-error xlib:drawable-error) (c)
- (declare (ignore c)))))
-
-
-
-(defun parse-display-string (display)
- "Parse an X11 DISPLAY string and return the host and display from it."
- (let* ((colon (position #\: display))
- (host (subseq display 0 colon))
- (rest (subseq display (1+ colon)))
- (dot (position #\. rest))
- (num (parse-integer (subseq rest 0 dot))))
- (values host num)))
-
-
-(defun banish-pointer ()
- "Move the pointer to the lower right corner of the screen"
- (xlib:warp-pointer *root*
- (1- (xlib:screen-width *screen*))
- (1- (xlib:screen-height *screen*))))
-
-
+ "Alist mapping NETWM window types to keywords.
+Include only those we are ready to support.")
+(defun set-window-state (win state)
+ "Set the state (iconic, normal, withdrawn) of a window."
+ (change-property win
+ :WM_STATE
+ (list state)
+ :WM_STATE
+ 32))
(defun window-state (win)
"Get the state (iconic, normal, withdraw of a window."
- (first (xlib:get-property win :WM_STATE)))
-
-
-(defun set-window-state (win state)
- "Set the state (iconic, normal, withdrawn) of a window."
- (xlib:change-property win
- :WM_STATE
- (list state)
- :WM_STATE
- 32))
+ (first (get-property win :WM_STATE)))
(defsetf window-state set-window-state)
-
-
(defun window-hidden-p (window)
(eql (window-state window) +iconic-state+))
@@ -122,182 +88,66 @@
(defun unhide-window (window)
(when window
- (with-xlib-protect
- (xlib:map-window window)
- (setf (window-state window) +normal-state+
- (xlib:window-event-mask window) *window-events*))))
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-;;(defconstant +exwm-atoms+
-;; (list "_NET_SUPPORTED" "_NET_CLIENT_LIST"
-;; "_NET_CLIENT_LIST_STACKING" "_NET_NUMBER_OF_DESKTOPS"
-;; "_NET_CURRENT_DESKTOP" "_NET_DESKTOP_GEOMETRY"
-;; "_NET_DESKTOP_VIEWPORT" "_NET_DESKTOP_NAMES"
-;; "_NET_ACTIVE_WINDOW" "_NET_WORKAREA"
-;; "_NET_SUPPORTING_WM_CHECK" "_NET_VIRTUAL_ROOTS"
-;; "_NET_DESKTOP_LAYOUT"
-;;
-;; "_NET_RESTACK_WINDOW" "_NET_REQUEST_FRAME_EXTENTS"
-;; "_NET_MOVERESIZE_WINDOW" "_NET_CLOSE_WINDOW"
-;; "_NET_WM_MOVERESIZE"
-;;
-;; "_NET_WM_SYNC_REQUEST" "_NET_WM_PING"
-;;
-;; "_NET_WM_NAME" "_NET_WM_VISIBLE_NAME"
-;; "_NET_WM_ICON_NAME" "_NET_WM_VISIBLE_ICON_NAME"
-;; "_NET_WM_DESKTOP" "_NET_WM_WINDOW_TYPE"
-;; "_NET_WM_STATE" "_NET_WM_STRUT"
-;; "_NET_WM_ICON_GEOMETRY" "_NET_WM_ICON"
-;; "_NET_WM_PID" "_NET_WM_HANDLED_ICONS"
-;; "_NET_WM_USER_TIME" "_NET_FRAME_EXTENTS"
-;; ;; "_NET_WM_MOVE_ACTIONS"
-;;
-;; "_NET_WM_WINDOW_TYPE_DESKTOP" "_NET_WM_STATE_MODAL"
-;; "_NET_WM_WINDOW_TYPE_DOCK" "_NET_WM_STATE_STICKY"
-;; "_NET_WM_WINDOW_TYPE_TOOLBAR" "_NET_WM_STATE_MAXIMIZED_VERT"
-;; "_NET_WM_WINDOW_TYPE_MENU" "_NET_WM_STATE_MAXIMIZED_HORZ"
-;; "_NET_WM_WINDOW_TYPE_UTILITY" "_NET_WM_STATE_SHADED"
-;; "_NET_WM_WINDOW_TYPE_SPLASH" "_NET_WM_STATE_SKIP_TASKBAR"
-;; "_NET_WM_WINDOW_TYPE_DIALOG" "_NET_WM_STATE_SKIP_PAGER"
-;; "_NET_WM_WINDOW_TYPE_NORMAL" "_NET_WM_STATE_HIDDEN"
-;; "_NET_WM_STATE_FULLSCREEN"
-;; "_NET_WM_STATE_ABOVE"
-;; "_NET_WM_STATE_BELOW"
-;; "_NET_WM_STATE_DEMANDS_ATTENTION"
-;;
-;; "_NET_WM_ALLOWED_ACTIONS"
-;; "_NET_WM_ACTION_MOVE"
-;; "_NET_WM_ACTION_RESIZE"
-;; "_NET_WM_ACTION_SHADE"
-;; "_NET_WM_ACTION_STICK"
-;; "_NET_WM_ACTION_MAXIMIZE_HORZ"
-;; "_NET_WM_ACTION_MAXIMIZE_VERT"
-;; "_NET_WM_ACTION_FULLSCREEN"
-;; "_NET_WM_ACTION_CHANGE_DESKTOP"
-;; "_NET_WM_ACTION_CLOSE"
-;;
-;; ))
-;;
-;;
-;;(defun intern-atoms (display)
-;; (declare (type xlib:display display))
-;; (mapcar #'(lambda (atom-name) (xlib:intern-atom display atom-name))
-;; +exwm-atoms+)
-;; (values))
-;;
-;;
-;;
-;;(defun get-atoms-property (window property-atom atom-list-p)
-;; "Returns a list of atom-name (if atom-list-p is t) otherwise returns
-;; a list of atom-id."
-;; (xlib:get-property window property-atom
-;; :transform (when atom-list-p
-;; (lambda (id)
-;; (xlib:atom-name (xlib:drawable-display window) id)))))
-;;
-;;(defun set-atoms-property (window atoms property-atom &key (mode :replace))
-;; "Sets the property designates by `property-atom'. ATOMS is a list of atom-id
-;; or a list of keyword atom-names."
-;; (xlib:change-property window property-atom atoms :ATOM 32
-;; :mode mode
-;; :transform (unless (integerp (car atoms))
-;; (lambda (atom-key)
-;; (xlib:find-atom (xlib:drawable-display window) atom-key)))))
-;;
-;;
-;;
-;;
-;;(defun net-wm-state (window)
-;; (get-atoms-property window :_NET_WM_STATE t))
-;;
-;;(defsetf net-wm-state (window &key (mode :replace)) (states)
-;; `(set-atoms-property ,window ,states :_NET_WM_STATE :mode ,mode))
-;;
-;;
-;;
-;;(defun hide-window (window)
-;; (when window
-;; (with-xlib-protect
-;; (let ((net-wm-state (net-wm-state window)))
-;; (dbg net-wm-state)
-;; (pushnew :_net_wm_state_hidden net-wm-state)
-;; (setf (net-wm-state window) net-wm-state)
-;; (dbg (net-wm-state window)))
-;; (setf (window-state window) +iconic-state+
-;; (xlib:window-event-mask window) (remove :structure-notify *window-events*))
-;; (xlib:unmap-window window)
-;; (setf (xlib:window-event-mask window) *window-events*))))
+ (handler-case
+ (progn
+ (map-window window)
+ (setf (window-state window) +normal-state+))
+ ((or match-error window-error drawable-error) (c)
+ (declare (ignore c))))))
+ ;;(dbg "Unhide window" window c)))))
(defun hide-window (window)
(when window
- (with-xlib-protect
- (setf (window-state window) +iconic-state+
- (xlib:window-event-mask window) (remove :structure-notify *window-events*))
- (xlib:unmap-window window)
- (setf (xlib:window-event-mask window) *window-events*))))
-
+ (handler-case
+ (progn
+ (setf (window-state window) +iconic-state+
+ (window-event-mask window) (remove :structure-notify *window-events*))
+ (unmap-window window)
+ (setf (window-event-mask window) *window-events*))
+ ((or match-error window-error drawable-error) (c)
+ (declare (ignore c))))))
+ ;;(dbg "Hide window" window c)))))
(defun window-type (window)
- "Return one of :desktop, :dock, :toolbar, :utility, :splash,
-:dialog, :transient, :maxsize and :normal."
- (or (and (let ((hints (xlib:wm-normal-hints window)))
- (and hints (or (xlib:wm-size-hints-max-width hints)
- (xlib:wm-size-hints-max-height hints)
- (xlib:wm-size-hints-min-aspect hints)
- (xlib:wm-size-hints-max-aspect hints))))
- :maxsize)
- (let ((net-wm-window-type (xlib:get-property window :_NET_WM_WINDOW_TYPE)))
- (when net-wm-window-type
- (dolist (type-atom net-wm-window-type)
- (when (assoc (xlib:atom-name *display* type-atom) +netwm-window-types+)
- (return (cdr (assoc (xlib:atom-name *display* type-atom) +netwm-window-types+)))))))
- (and (xlib:get-property window :WM_TRANSIENT_FOR)
- :transient)
+ "Return one of :maxsize, :transient, or :normal."
+ (or (and (get-property window :WM_TRANSIENT_FOR)
+ :transient)
+ (and (let ((hints (wm-normal-hints window)))
+ (and hints (or (wm-size-hints-max-width hints)
+ (wm-size-hints-max-height hints))))
+ :maxsize)
:normal))
-
;; Stolen from Eclipse
(defun send-configuration-notify (window)
"Send a synthetic configure notify event to the given window (ICCCM 4.1.5)"
(multiple-value-bind (x y)
- (xlib:translate-coordinates window 0 0 (xlib:drawable-root window))
- (xlib:send-event window
- :configure-notify
- (xlib:make-event-mask :structure-notify)
- :event-window window :window window
- :x x :y y
- :override-redirect-p nil
- :border-width (xlib:drawable-border-width window)
- :width (xlib:drawable-width window)
- :height (xlib:drawable-height window)
- :propagate-p nil)))
+ (translate-coordinates window 0 0 (drawable-root window))
+ (send-event window
+ :configure-notify
+ (make-event-mask :structure-notify)
+ :event-window window :window window
+ :x x :y y
+ :override-redirect-p nil
+ :border-width (drawable-border-width window)
+ :width (drawable-width window)
+ :height (drawable-height window)
+ :propagate-p nil)))
(defun send-client-message (window type &rest data)
"Send a client message to a client's window."
- (xlib:send-event window
- :client-message nil
- :window window
- :type type
- :format 32
- :data data))
+ (send-event window
+ :client-message nil
+ :window window
+ :type type
+ :format 32
+ :data data))
@@ -306,19 +156,26 @@
(defun raise-window (window)
"Map the window if needed and bring it to the top of the stack. Does not affect focus."
(when window
- (with-xlib-protect
- (when (window-hidden-p window)
- (unhide-window window))
- (setf (xlib:window-priority window) :top-if))))
+ (handler-case
+ (progn
+ (when (window-hidden-p window)
+ (unhide-window window))
+ (setf (window-priority window) :top-if))
+ ((or match-error window-error drawable-error) (c)
+ (declare (ignore c))))))
+ ;;(dbg "Raise error" c window)))))
+
(defun focus-window (window)
"Give the window focus."
(when window
- (with-xlib-protect
- (raise-window window)
- (xlib:set-input-focus *display* window :parent))))
- ;;(xlib:set-input-focus *display* :pointer-root :pointer-root)) ;;PHIL
-
+ (handler-case
+ (progn
+ (raise-window window)
+ (set-input-focus *display* window :pointer-root))
+ ((or match-error window-error drawable-error) (c)
+ (declare (ignore c))))))
+ ;;(dbg "Focus error" c window)))))
@@ -326,7 +183,7 @@
(defun no-focus ()
"don't focus any window but still read keyboard events."
- (xlib:set-input-focus *display* *no-focus-window* :pointer-root))
+ (set-input-focus *display* *no-focus-window* :pointer-root))
@@ -336,10 +193,10 @@
(pointer-grabbed nil))
(labels ((free-grab-pointer ()
(when cursor
- (xlib:free-cursor cursor)
+ (free-cursor cursor)
(setf cursor nil))
(when cursor-font
- (xlib:close-font cursor-font)
+ (close-font cursor-font)
(setf cursor-font nil))))
(defun xgrab-init-pointer ()
(setf pointer-grabbed nil))
@@ -347,28 +204,27 @@
(defun xgrab-pointer-p ()
pointer-grabbed)
- (defun xgrab-pointer (root cursor-char cursor-mask-char
- &optional (pointer-mask '(:enter-window :pointer-motion
- :button-press :button-release)) owner-p)
+ (defun xgrab-pointer (root cursor-char cursor-mask-char)
"Grab the pointer and set the pointer shape."
(free-grab-pointer)
(setf pointer-grabbed t)
- (let* ((white (xlib:make-color :red 1.0 :green 1.0 :blue 1.0))
- (black (xlib:make-color :red 0.0 :green 0.0 :blue 0.0)))
- (setf cursor-font (xlib:open-font *display* "cursor")
[156 lines skipped]
More information about the clfswm-cvs
mailing list