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
  47 (define-handler main-mode :configure-request (stack-mode window x y width height border-width value-mask)
  48   (let ((change nil))
  49     (labels ((has-x (mask) (= 1 (logand mask 1)))
  50              (has-y (mask) (= 2 (logand mask 2)))
  51              (has-w (mask) (= 4 (logand mask 4)))
  52              (has-h (mask) (= 8 (logand mask 8)))
  53              (has-bw (mask) (= 16 (logand mask 16)))
  54              (has-stackmode (mask) (= 64 (logand mask 64)))
  55              (adjust-from-request ()
  56                (when (has-x value-mask) (setf (x-drawable-x window) x
  57                                               change :moved))
  58                (when (has-y value-mask) (setf (x-drawable-y window) y
  59                                               change :moved))
  60                (when (has-h value-mask) (setf (x-drawable-height window) height
  61                                               change :resized))
  62                (when (has-w value-mask) (setf (x-drawable-width window) width
  63                                               change :resized))))
  64       (when window
  65         (xlib:with-state (window)
  66           (let ((current-root (find-current-root)))
  67             (if (find-child window current-root)
  68                 (let ((parent (find-parent-frame window current-root)))
  69                   (if (and parent (managed-window-p window parent))
  70                       (setf change (adapt-child-to-parent window parent))
  71                       (adjust-from-request)))
  72                 (adjust-from-request)))
  73           (when (has-bw value-mask)
  74             (setf (x-drawable-border-width window) border-width
  75                   change :resized))
  76           (when (has-stackmode value-mask)
  77             (case stack-mode
  78               (:above
  79                (when (or (child-equal-p window (current-child))
  80                          (is-in-current-child-p window))
  81                  (setf change (or change :moved))
  82                  (focus-window window)
  83                  (focus-all-children window (find-parent-frame window (find-current-root)))
  84                  (show-all-children))))))
  85         (unless (eq change :resized)
  86           ;; To be ICCCM compliant, send a fake configuration notify event only when
  87           ;; the window has moved and not when it has been resized or the border width has changed.
  88           (send-configuration-notify window (x-drawable-x window) (x-drawable-y window)
  89                                      (x-drawable-width window) (x-drawable-height window)
  90                                      (x-drawable-border-width window)))))))
  91
  92
  93 (define-handler main-mode :map-request (window send-event-p)
  94   (unless send-event-p
  95     (unless (find-child window *root-frame*)
  96       (unhide-window window)
  97       (process-new-window window)
  98       (map-window window)
  99       (multiple-value-bind (never-managed raise)
 100           (never-managed-window-p window)
 101         (unless (and never-managed raise)
 102           (show-all-children))))))
 103
 104
 105
 106 (define-handler main-mode :unmap-notify (send-event-p event-window window)
 107   (unless (and (not send-event-p)
 108                (not (xlib:window-equal window event-window)))
 109     (when (find-child window *root-frame*)
 110       (setf (window-state window) +withdrawn-state+)
 111       (remove-child-in-all-frames window)
 112       (show-all-children))))
 113
 114
 115 (define-handler main-mode :destroy-notify (send-event-p event-window window)
 116   (unless (or send-event-p
 117               (xlib:window-equal window event-window))
 118     (when (find-child window *root-frame*)
 119       (delete-child-in-all-frames window)
 120       (show-all-children))))
 121
 122
 123 (define-handler main-mode :enter-notify  (window root-x root-y)
 124   (unless (and (> root-x (- (xlib:screen-width *screen*) 3))
 125                (> root-y (- (xlib:screen-height *screen*) 3)))
 126     (case (if (frame-p (current-child))
 127               (frame-focus-policy (current-child))
 128               *default-focus-policy*)
 129       (:sloppy (focus-window window))
 130       (:sloppy-strict (when (and (frame-p (current-child))
 131                                  (child-member window (frame-child (current-child))))
 132                         (focus-window window)))
 133       (:sloppy-select (let* ((child (find-child-under-mouse root-x root-y))
 134                              (parent (find-parent-frame child)))
 135                         (unless (or (child-root-p child)
 136                                     (child-equal-p (typecase child
 137                                                      (xlib:window parent)
 138                                                      (t child))
 139                                                    (current-child)))
 140                             (focus-all-children child parent)
 141                             (show-all-children))))
 142       (:sloppy-select-window (let* ((child (find-child-under-mouse root-x root-y))
 143                                     (parent (find-parent-frame child))
 144                                     (need-warp-pointer (not (or (frame-p child)
 145                                                                 (child-equal-p child (frame-selected-child parent))))))
 146                                (unless (child-root-p child)
 147                                  (when (focus-all-children child parent)
 148                                    (show-all-children)
 149                                    (when need-warp-pointer
 150                                      (typecase child
 151                                        (xlib:window (xlib:warp-pointer *root*
 152                                                                        (truncate (+ (x-drawable-x child)
 153                                                                                     (/ (x-drawable-width child) 2)))
 154                                                                        (truncate (+ (x-drawable-y child)
 155                                                                                     (/ (x-drawable-height child) 2)))))
 156                                        (frame (xlib:warp-pointer *root*
 157                                                                  (+ (frame-rx child) 10)
 158                                                                  (+ (frame-ry child) 10))))))))))))
 159
 160 (define-handler main-mode :exposure (window)
 161   (awhen (find-frame-window window)
 162     (display-frame-info it)))
 163
 164
 165 (define-handler main-mode :configure-notify (window)
 166   (when (child-equal-p window *root*)
 167     (unless (eql (place-frames-from-xinerama-infos) :update)
 168       (finish-configuring-root))
 169     (show-all-children)
 170     (call-hook *root-size-change-hook*)))
 171
 172
 173 (defun error-handler (display error-key &rest key-vals &key asynchronous &allow-other-keys)
 174   "Handle X errors"
 175   (cond
 176     ;; ignore asynchronous window errors
 177     ((and asynchronous
 178           (find error-key '(xlib:window-error xlib:drawable-error xlib:match-error)))
 179      #+:xlib-debug (format t "~&Ignoring XLib asynchronous error: ~s~%" error-key))
 180     ((eq error-key 'xlib:access-error)
 181      (write-line "~&Another window manager is running.")
 182      (throw 'exit-clfswm nil))
 183     ;; all other asynchronous errors are printed.
 184     (asynchronous
 185      #+:xlib-debug (format t "~&Caught Asynchronous X Error: ~s ~s" error-key key-vals))
 186     ;;((find error-key '(xlib:window-error xlib:drawable-error xlib:match-error))
 187     ;; (format t "~&Ignoring Xlib error: ~S ~S~%" error-key key-vals))
 188     (t
 189      (apply 'error error-key :display display :error-key error-key key-vals))))
 190
 191
 192 (defun main-loop ()
 193   (loop
 194      (with-xlib-protect (:main-loop nil)
 195        (call-hook *loop-hook*)
 196        (process-timers)
 197        (when (xlib:event-listen *display* *loop-timeout*)
 198          (xlib:process-event *display* :handler #'handle-event))
 199        (xlib:display-finish-output *display*)
 200        (setf *x-error-count* 0))))
 201
 202
 203
 204
 205 (defun open-display (display-str protocol)
 206   (multiple-value-bind (host display-num) (parse-display-string display-str)
 207     (setf *display* (xlib:open-display host :display display-num :protocol protocol)
 208           (xlib:display-error-handler *display*) 'error-handler
 209           (getenv "DISPLAY") display-str)))
 210
 211
 212
 213 (defun default-init-hook ()
 214   (place-frames-from-xinerama-infos)
 215   (finish-configuring-root))
 216
 217
 218 (defun init-display ()
 219   (reset-root-list)
 220   (reset-last-head-size)
 221   (reset-bind-or-jump-slots)
 222   (reset-open-menu)
 223   (fill-handle-event-fun-symbols)
 224   (assoc-keyword-handle-event 'main-mode)
 225   (setf *screen* (first (xlib:display-roots *display*))
 226         *root* (xlib:screen-root *screen*)
 227         *no-focus-window* (xlib:create-window :parent *root* :x 0 :y 0 :width 1 :height 1)
 228         *default-font* (xlib:open-font *display* *default-font-string*)
 229         *pixmap-buffer* (xlib:create-pixmap :width (xlib:screen-width *screen*)
 230                                             :height (xlib:screen-height *screen*)
 231                                             :depth (xlib:screen-root-depth *screen*)
 232                                             :drawable *root*)
 233         *in-second-mode* nil
 234         *x-error-count* 0)
 235   (store-root-background)
 236   (init-modifier-list)
 237   (xgrab-init-pointer)
 238   (xgrab-init-keyboard)
 239   (init-last-child)
 240   (call-hook *binding-hook*)
 241   (clear-timers)
 242   (map-window *no-focus-window*)
 243   (dbg *display*)
 244   (setf (xlib:window-event-mask *root*) (xlib:make-event-mask :substructure-redirect
 245                                                               :substructure-notify
 246                                                               :structure-notify
 247                                                               :property-change
 248                                                               ;;:resize-redirect
 249                                                               :exposure
 250                                                               :button-press
 251                                                               :button-release
 252                                                               :pointer-motion))
 253   (xlib:display-finish-output *display*)
 254   ;;(intern-atoms *display*)
 255   (netwm-set-properties)
 256   (xlib:display-force-output *display*)
 257   (setf *child-selection* nil)
 258   (setf *root-frame* (create-frame :name "Root" :number 0)
 259         (current-child) *root-frame*)
 260   (call-hook *init-hook*)
 261   (process-existing-windows *screen*)
 262   (show-all-children)
 263   (grab-main-keys)
 264   (xlib:display-finish-output *display*)
 265   (optimize-event-hook))
 266
 267
 268
 269
 270 (defun read-conf-file ()
 271   (let* ((conf (conf-file-name)))
 272     (if conf
 273         (handler-case (load conf)
 274           (error (c)
 275             (format t "~2%*** Error loading configuration file: ~A ***~&~A~%" conf c)
 276             (values nil (format nil "~s" c) conf))
 277           (:no-error (&rest args)
 278             (declare (ignore args))
 279             (values t nil conf)))
 280         (values t nil nil))))
 281
 282
 283
 284
 285
 286
 287 (defun exit-clfswm ()
 288   "Exit clfswm"
 289   (throw 'exit-clfswm nil))
 290
 291 (defun reset-clfswm ()
 292   "Reset clfswm"
 293   (throw 'exit-main-loop nil))
 294
 295
 296
 297
 298 (defun main-unprotected (&key (display (or (getenv "DISPLAY") ":0")) protocol
 299                          (read-conf-file-p t) (alternate-conf nil)
 300                          error-msg)
 301   (conf-file-name alternate-conf)
 302   (when read-conf-file-p
 303     (read-conf-file))
 304   (create-configuration-menu :clear t)
 305   (call-hook *main-entrance-hook*)
 306   (handler-case
 307       (open-display display protocol)
 308     (xlib:access-error (c)
 309       (format t "~&~A~&Maybe another window manager is running. [1]~%" c)
 310       (force-output)
 311       (exit-clfswm)))
 312   (handler-case
 313       (init-display)
 314     (xlib:access-error (c)
 315       (ungrab-main-keys)
 316       (xlib:destroy-window *no-focus-window*)
 317       (xlib:close-display *display*)
 318       (format t "~&~A~&Maybe another window manager is running. [2]~%" c)
 319       (force-output)
 320       (exit-clfswm)))
 321   (when error-msg
 322     (info-mode error-msg))
 323   (catch 'exit-main-loop
 324       (unwind-protect
 325            (main-loop)
 326         (progn
 327           (ungrab-main-keys)
 328           (xlib:destroy-window *no-focus-window*)
 329           (xlib:free-pixmap *pixmap-buffer*)
 330           (destroy-all-frames-window)
 331           (call-hook *close-hook*)
 332           (clear-event-hooks)
 333           (xlib:close-display *display*)
 334           #+:event-debug
 335           (format t "~2&Unhandled events: ~A~%" *unhandled-events*)))))
 336
 337
 338
 339 (defun main (&key (display (or (getenv "DISPLAY") ":0")) protocol
 340              (read-conf-file-p t)
 341              (alternate-conf nil))
 342   (let (error-msg)
 343     (catch 'exit-clfswm
 344       (loop
 345          (handler-case
 346              (if *other-window-manager*
 347                  (run-other-window-manager)
 348                  (main-unprotected :display display :protocol protocol
 349                                    :read-conf-file-p read-conf-file-p
 350                                    :alternate-conf alternate-conf
 351                                    :error-msg error-msg))
 352            (error (c)
 353              (let ((msg (format nil "CLFSWM Error: ~A." c)))
 354                (format t "~&~A~%Reinitializing...~%" msg)
 355                (setf error-msg (list (list msg *info-color-title*)
 356                                      "Reinitializing...")))))))))
 357
 358
 359