src/clfswm.lisp

   1 ;;; --------------------------------------------------------------------------
   2 ;;; CLFSWM - FullScreen Window Manager
   3 ;;;
   4 ;;; --------------------------------------------------------------------------
   5 ;;; Documentation: Main functions
   6 ;;; --------------------------------------------------------------------------
   7 ;;;
   8 ;;; (C) 2012 Philippe Brochard <pbrochard@common-lisp.net>
   9 ;;;
  10 ;;; This program is free software; you can redistribute it and/or modify
  11 ;;; it under the terms of the GNU General Public License as published by
  12 ;;; the Free Software Foundation; either version 3 of the License, or
  13 ;;; (at your option) any later version.
  14 ;;;
  15 ;;; This program is distributed in the hope that it will be useful,
  16 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;;; GNU General Public License for more details.
  19 ;;;
  20 ;;; You should have received a copy of the GNU General Public License
  21 ;;; along with this program; if not, write to the Free Software
  22 ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  23 ;;;
  24 ;;; --------------------------------------------------------------------------
  25
  26 (in-package :clfswm)
  27
  28
  29 (define-handler main-mode :key-press (code state)
  30   (funcall-key-from-code *main-keys* code state))
  31
  32 (define-handler main-mode :button-press (code state window root-x root-y)
  33   (unless (funcall-button-from-code *main-mouse* code state window root-x root-y *fun-press*)
  34     (replay-button-event)))
  35
  36 (define-handler main-mode :button-release (code state window root-x root-y)
  37   (unless (funcall-button-from-code *main-mouse* code state window root-x root-y *fun-release*)
  38     (replay-button-event)))
  39
  40 (define-handler main-mode :motion-notify (window root-x root-y)
  41   (unless (compress-motion-notify)
  42     (funcall-button-from-code *main-mouse* 'motion
  43                               (modifiers->state *default-modifiers*)
  44                               window root-x root-y *fun-press*)))
  45
  46 (define-handler main-mode :configure-request (stack-mode window x y width height border-width value-mask)
  47   (labels ((has-x (mask) (= 1 (logand mask 1)))
  48            (has-y (mask) (= 2 (logand mask 2)))
  49            (has-w (mask) (= 4 (logand mask 4)))
  50            (has-h (mask) (= 8 (logand mask 8)))
  51            (has-bw (mask) (= 16 (logand mask 16)))
  52            (has-stackmode (mask) (= 64 (logand mask 64)))
  53            (adjust-from-request ()
  54              (when (has-x value-mask) (setf (x-drawable-x window) x))
  55              (when (has-y value-mask) (setf (x-drawable-y window) y))
  56              (when (has-h value-mask) (setf (x-drawable-height window) height))
  57              (when (has-w value-mask) (setf (x-drawable-width window) width))))
  58     (xlib:with-state (window)
  59       (when (has-bw value-mask)
  60         (setf (x-drawable-border-width window) border-width))
  61       (let ((current-root (find-current-root)))
  62         (if (find-child window current-root)
  63             (let ((parent (find-parent-frame window current-root)))
  64               (if (and parent (managed-window-p window parent))
  65                   (adapt-child-to-parent window parent)
  66                   (adjust-from-request)))
  67             (adjust-from-request)))
  68       (send-configuration-notify window (x-drawable-x window) (x-drawable-y window)
  69                                  (x-drawable-width window) (x-drawable-height window)
  70                                  (x-drawable-border-width window))
  71       (when (has-stackmode value-mask)
  72         (case stack-mode
  73           (:above
  74            (unless (null-size-window-p window)
  75              (when (or (child-equal-p window (current-child))
  76                        (is-in-current-child-p window))
  77                (raise-window window)
  78                (focus-window window)
  79                (focus-all-children window (find-parent-frame window (find-current-root)))))))))))
  80
  81
  82 (define-handler main-mode :map-request (window send-event-p)
  83   (unless send-event-p
  84     (unhide-window window)
  85     (process-new-window window)
  86     (map-window window)
  87     (unless (null-size-window-p window)
  88       (multiple-value-bind (never-managed raise)
  89           (never-managed-window-p window)
  90         (unless (and never-managed raise)
  91           (show-all-children))))))
  92
  93
  94
  95 (define-handler main-mode :unmap-notify (send-event-p event-window window)
  96   (unless (and (not send-event-p)
  97                (not (xlib:window-equal window event-window)))
  98     (when (find-child window *root-frame*)
  99       (setf (window-state window) +withdrawn-state+)
 100       (xlib:unmap-window window)
 101       ;;(xlib:display-finish-output *display*)
 102       ;;(when (find-child window *root-frame*)
 103       ;;(clean-windows-in-all-frames)
 104       ;;(show-all-children)
 105       (delete-child-in-all-frames window)
 106       (show-all-children))))
 107
 108
 109
 110
 111
 112 (define-handler main-mode :destroy-notify (send-event-p event-window window)
 113   (unless (or send-event-p
 114               (xlib:window-equal window event-window))
 115     (when (find-child window *root-frame*)
 116       ;; (clean-windows-in-all-frames)
 117       ;; (show-all-children)
 118       (delete-child-in-all-frames window)
 119       (show-all-children))
 120     (xlib:destroy-window window)))
 121
 122 (define-handler main-mode :enter-notify  (window root-x root-y)
 123   (unless (and (> root-x (- (xlib:screen-width *screen*) 3))
 124                (> root-y (- (xlib:screen-height *screen*) 3)))
 125     (case (if (frame-p (current-child))
 126               (frame-focus-policy (current-child))
 127               *default-focus-policy*)
 128       (:sloppy (focus-window window))
 129       (:sloppy-strict (when (and (frame-p (current-child))
 130                                  (child-member window (frame-child (current-child))))
 131                         (focus-window window)))
 132       (:sloppy-select (let* ((child (find-child-under-mouse root-x root-y))
 133                              (parent (find-parent-frame child)))
 134                         (unless (or (child-root-p child)
 135                                     (equal (typecase child
 136                                              (xlib:window parent)
 137                                              (t child))
 138                                            (current-child)))
 139                             (focus-all-children child parent)
 140                             (show-all-children)))))))
 141
 142 (define-handler main-mode :exposure (window)
 143   (awhen (find-frame-window window)
 144     (display-frame-info it)))
 145
 146 (define-handler main-mode :resize-request (window)
 147   (dbg :resize-request window))
 148
 149
 150 (defun error-handler (display error-key &rest key-vals &key asynchronous &allow-other-keys)
 151   "Handle X errors"
 152   (cond
 153     ;; ignore asynchronous window errors
 154     ((and asynchronous
 155           (find error-key '(xlib:window-error xlib:drawable-error xlib:match-error)))
 156      (format t "~&Ignoring XLib asynchronous error: ~s~%" error-key))
 157     ((eq error-key 'xlib:access-error)
 158      (write-line "~&Another window manager is running.")
 159      (throw 'exit-clfswm nil))
 160      ;; all other asynchronous errors are printed.
 161      (asynchronous
 162       (format t "~&Caught Asynchronous X Error: ~s ~s" error-key key-vals))
 163      (t
 164       (apply 'error error-key :display display :error-key error-key key-vals))))
 165
 166
 167 (defun main-loop ()
 168   (loop
 169      (with-xlib-protect (:main-loop nil)
 170        (call-hook *loop-hook*)
 171        (process-timers)
 172        (when (xlib:event-listen *display* *loop-timeout*)
 173          (xlib:process-event *display* :handler #'handle-event))
 174        (xlib:display-finish-output *display*))))
 175
 176
 177
 178
 179 (defun open-display (display-str protocol)
 180   (multiple-value-bind (host display-num) (parse-display-string display-str)
 181     (setf *display* (xlib:open-display host :display display-num :protocol protocol)
 182           (xlib:display-error-handler *display*) 'error-handler
 183           (getenv "DISPLAY") display-str)))
 184
 185
 186
 187 (defun default-init-hook ()
 188   (let ((frame (add-frame (create-frame :name "Default"
 189                                         :layout nil :x 0.05 :y 0.05
 190                                         :w 0.9 :h 0.9)
 191                           *root-frame*)))
 192     (setf (current-child) frame)))
 193
 194
 195 (defun init-display ()
 196   (reset-root-list)
 197   (reset-bind-or-jump-slots)
 198   (reset-open-menu)
 199   (fill-handle-event-fun-symbols)
 200   (assoc-keyword-handle-event 'main-mode)
 201   (setf *screen* (first (xlib:display-roots *display*))
 202         *root* (xlib:screen-root *screen*)
 203         *no-focus-window* (xlib:create-window :parent *root* :x 0 :y 0 :width 1 :height 1)
 204         *default-font* (xlib:open-font *display* *default-font-string*)
 205         *pixmap-buffer* (xlib:create-pixmap :width (xlib:screen-width *screen*)
 206                                             :height (xlib:screen-height *screen*)
 207                                             :depth (xlib:screen-root-depth *screen*)
 208                                             :drawable *root*)
 209         *in-second-mode* nil)
 210   (store-root-background)
 211   (init-modifier-list)
 212   (xgrab-init-pointer)
 213   (xgrab-init-keyboard)
 214   (init-last-child)
 215   (call-hook *binding-hook*)
 216   (clear-timers)
 217   (map-window *no-focus-window*)
 218   (dbg *display*)
 219   (setf (xlib:window-event-mask *root*) (xlib:make-event-mask :substructure-redirect
 220                                                               :substructure-notify
 221                                                               :property-change
 222                                                               :resize-redirect
 223                                                               :exposure
 224                                                               :button-press
 225                                                               :button-release
 226                                                               :pointer-motion))
 227   ;;(intern-atoms *display*)
 228   (netwm-set-properties)
 229   (xlib:display-force-output *display*)
 230   (setf *child-selection* nil)
 231   (setf *root-frame* (create-frame :name "Root" :number 0)
 232         (current-child) *root-frame*)
 233   (call-hook *init-hook*)
 234   (unsure-at-least-one-root)
 235   (process-existing-windows *screen*)
 236   (show-all-children)
 237   (grab-main-keys)
 238   (xlib:display-finish-output *display*)
 239   (optimize-event-hook))
 240
 241
 242
 243
 244 (defun read-conf-file ()
 245   (let* ((conf (conf-file-name)))
 246     (if conf
 247         (handler-case (load conf)
 248           (error (c)
 249             (format t "~2%*** Error loading configuration file: ~A ***~&~A~%" conf c)
 250             (values nil (format nil "~s" c) conf))
 251           (:no-error (&rest args)
 252             (declare (ignore args))
 253             (values t nil conf)))
 254         (values t nil nil))))
 255
 256
 257
 258
 259
 260
 261 (defun exit-clfswm ()
 262   "Exit clfswm"
 263   (throw 'exit-clfswm nil))
 264
 265 (defun reset-clfswm ()
 266   "Reset clfswm"
 267   (throw 'exit-main-loop nil))
 268
 269
 270
 271
 272 (defun main-unprotected (&key (display (or (getenv "DISPLAY") ":0")) protocol
 273                          (base-dir (asdf:system-source-directory :clfswm))
 274                          (read-conf-file-p t) (alternate-conf nil)
 275                          error-msg)
 276   (setf *contrib-dir* (merge-pathnames "contrib/" base-dir))
 277   (conf-file-name alternate-conf)
 278   (when read-conf-file-p
 279     (read-conf-file))
 280   (create-configuration-menu :clear t)
 281   (call-hook *main-entrance-hook*)
 282   (handler-case
 283       (open-display display protocol)
 284     (xlib:access-error (c)
 285       (format t "~&~A~&Maybe another window manager is running. [1]~%" c)
 286       (force-output)
 287       (exit-clfswm)))
 288   (handler-case
 289       (init-display)
 290     (xlib:access-error (c)
 291       (ungrab-main-keys)
 292       (xlib:destroy-window *no-focus-window*)
 293       (xlib:close-display *display*)
 294       (format t "~&~A~&Maybe another window manager is running. [2]~%" c)
 295       (force-output)
 296       (exit-clfswm)))
 297   (when error-msg
 298     (info-mode error-msg))
 299   (catch 'exit-main-loop
 300       (unwind-protect
 301            (main-loop)
 302         (progn
 303           (ungrab-main-keys)
 304           (xlib:destroy-window *no-focus-window*)
 305           (xlib:free-pixmap *pixmap-buffer*)
 306           (destroy-all-frames-window)
 307           (call-hook *close-hook*)
 308           (clear-event-hooks)
 309           (xlib:close-display *display*)
 310           #+:event-debug
 311           (format t "~2&Unhandled events: ~A~%" *unhandled-events*)))))
 312
 313
 314
 315 (defun main (&key (display (or (getenv "DISPLAY") ":0")) protocol
 316              (base-dir (asdf:system-source-directory :clfswm))
 317              (read-conf-file-p t)
 318              (alternate-conf nil))
 319   (let (error-msg)
 320     (catch 'exit-clfswm
 321       (loop
 322          (handler-case
 323              (if *other-window-manager*
 324                  (run-other-window-manager)
 325                  (main-unprotected :display display :protocol protocol :base-dir base-dir
 326                                    :read-conf-file-p read-conf-file-p
 327                                    :alternate-conf alternate-conf
 328                                    :error-msg error-msg))
 329            (error (c)
 330              (let ((msg (format nil "CLFSWM Error: ~A." c)))
 331                (format t "~&~A~%Reinitializing...~%" msg)
 332                (setf error-msg (list (list msg *info-color-title*)
 333                                      "Reinitializing...")))))))))
 334
 335
 336