src/clfswm.lisp

   1 ;;; --------------------------------------------------------------------------
   2 ;;; CLFSWM - FullScreen Window Manager
   3 ;;;
   4 ;;; --------------------------------------------------------------------------
   5 ;;; Documentation: Main functions
   6 ;;; --------------------------------------------------------------------------
   7 ;;;
   8 ;;; (C) 2005 Philippe Brochard <hocwp@free.fr>
   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
  30
  31
  32 ;;; Main mode hooks
  33 (defun handle-key-press (&rest event-slots &key root code state &allow-other-keys)
  34   (declare (ignore event-slots root))
  35   (funcall-key-from-code *main-keys* code state))
  36
  37
  38 (defun handle-button-press (&rest event-slots &key code state window root-x root-y &allow-other-keys)
  39   (declare (ignore event-slots))
  40   (unless (funcall-button-from-code *main-mouse* code state window root-x root-y *fun-press*)
  41     (replay-button-event)))
  42
  43
  44
  45 (defun handle-button-release (&rest event-slots &key code state window root-x root-y &allow-other-keys)
  46   (declare (ignore event-slots))
  47   (unless (funcall-button-from-code *main-mouse* code state window root-x root-y *fun-release*)
  48     (replay-button-event)))
  49
  50 (defun handle-motion-notify (&rest event-slots &key window root-x root-y &allow-other-keys)
  51   (declare (ignore event-slots))
  52   (unless (compress-motion-notify)
  53     (funcall-button-from-code *main-mouse* 'motion
  54                               (modifiers->state *default-modifiers*)
  55                               window root-x root-y *fun-press*)))
  56
  57
  58 (defun handle-configure-request (&rest event-slots &key stack-mode #|parent|# window #|above-sibling|#
  59                                  x y width height border-width value-mask &allow-other-keys)
  60   (declare (ignore event-slots))
  61   (labels ((has-x (mask) (= 1 (logand mask 1)))
  62            (has-y (mask) (= 2 (logand mask 2)))
  63            (has-w (mask) (= 4 (logand mask 4)))
  64            (has-h (mask) (= 8 (logand mask 8)))
  65            (has-bw (mask) (= 16 (logand mask 16)))
  66            (has-stackmode (mask) (= 64 (logand mask 64)))
  67            (adjust-from-request ()
  68              (when (has-x value-mask) (setf (xlib:drawable-x window) x))
  69              (when (has-y value-mask) (setf (xlib:drawable-y window) y))
  70              (when (has-h value-mask) (setf (xlib:drawable-height window) height))
  71              (when (has-w value-mask) (setf (xlib:drawable-width window) width))))
  72     (with-xlib-protect
  73       (xlib:with-state (window)
  74         (when (has-bw value-mask)
  75           (setf (xlib:drawable-border-width window) border-width))
  76         (if (find-child window *current-root*)
  77             (let ((parent (find-parent-frame window *current-root*)))
  78               (if (and parent (managed-window-p window parent))
  79                   (progn
  80                     (adapt-child-to-parent window parent)
  81                     (send-configuration-notify window))
  82                   (adjust-from-request)))
  83             (adjust-from-request))
  84         (when (has-stackmode value-mask)
  85           (case stack-mode
  86             (:above (raise-window window))))))))
  87
  88
  89
  90
  91 (defun handle-configure-notify (&rest event-slots)
  92   (declare (ignore event-slots)))
  93
  94
  95
  96
  97 (defun handle-map-request (&rest event-slots &key window send-event-p &allow-other-keys)
  98   (declare (ignore event-slots))
  99   (unless send-event-p
 100     (unhide-window window)
 101     (process-new-window window)
 102     (map-window window)
 103     (unless (null-size-window-p window)
 104       (show-all-children))))
 105
 106
 107
 108 (defun handle-unmap-notify (&rest event-slots &key send-event-p event-window window &allow-other-keys)
 109   (declare (ignore event-slots))
 110   (unless (and (not send-event-p)
 111                (not (xlib:window-equal window event-window)))
 112     (when (find-child window *root-frame*)
 113       (remove-child-in-all-frames window)
 114       (show-all-children))))
 115
 116
 117 (defun handle-destroy-notify (&rest event-slots &key send-event-p event-window window &allow-other-keys)
 118   (declare (ignore event-slots))
 119   (unless (or send-event-p
 120               (xlib:window-equal window event-window))
 121     (when (find-child window *root-frame*)
 122       (remove-child-in-all-frames window)
 123       (show-all-children))))
 124
 125
 126
 127 (defun handle-enter-notify  (&rest event-slots &key window root-x root-y &allow-other-keys)
 128   (declare (ignore event-slots))
 129   (unless (and (> root-x (- (xlib:screen-width *screen*) 3))
 130                (> root-y (- (xlib:screen-height *screen*) 3)))
 131     (case (if (frame-p *current-child*)
 132               (frame-focus-policy *current-child*)
 133               *default-focus-policy*)
 134       (:sloppy (focus-window window))
 135       (:sloppy-strict (when (and (frame-p *current-child*)
 136                                  (member window (frame-child *current-child*)))
 137                         (focus-window window)))
 138       (:sloppy-select (let* ((child (find-child-under-mouse root-x root-y))
 139                              (parent (find-parent-frame child)))
 140                         (unless (or (equal child *current-root*)
 141                                     (equal (typecase child
 142                                              (xlib:window parent)
 143                                              (t child))
 144                                            *current-child*))
 145                             (focus-all-children child parent)
 146                             (show-all-children)))))))
 147
 148
 149
 150
 151 (defun handle-exposure   (&rest event-slots &key window &allow-other-keys)
 152   (declare (ignore event-slots))
 153   (awhen (find-frame-window window *current-root*)
 154     (display-frame-info it)))
 155
 156
 157 (defun handle-create-notify (&rest event-slots)
 158   (declare (ignore event-slots)))
 159
 160
 161
 162
 163
 164
 165 ;;; CONFIG: Main mode hooks
 166 (setf *key-press-hook* 'handle-key-press
 167       *configure-request-hook* 'handle-configure-request
 168       *configure-notify-hook* 'handle-configure-notify
 169       *destroy-notify-hook* 'handle-destroy-notify
 170       *enter-notify-hook* 'handle-enter-notify
 171       *exposure-hook* 'handle-exposure
 172       *map-request-hook* 'handle-map-request
 173       *unmap-notify-hook* 'handle-unmap-notify
 174       *create-notify-hook* 'handle-create-notify
 175       *button-press-hook* 'handle-button-press
 176       *button-release-hook* 'handle-button-release
 177       *motion-notify-hook* 'handle-motion-notify)
 178
 179
 180
 181
 182 (defun handle-event (&rest event-slots &key display event-key &allow-other-keys)
 183   (declare (ignore display))
 184   ;;(dbg  event-key)
 185   (with-xlib-protect
 186     (case event-key
 187       (:button-press (call-hook *button-press-hook* event-slots))
 188       (:button-release (call-hook *button-release-hook* event-slots))
 189       (:motion-notify (call-hook *motion-notify-hook* event-slots))
 190       (:key-press (call-hook *key-press-hook* event-slots))
 191       (:configure-request (call-hook *configure-request-hook* event-slots))
 192       (:configure-notify (call-hook *configure-notify-hook* event-slots))
 193       (:map-request (call-hook *map-request-hook* event-slots))
 194       (:unmap-notify (call-hook *unmap-notify-hook* event-slots))
 195       (:destroy-notify (call-hook *destroy-notify-hook* event-slots))
 196       (:mapping-notify (call-hook *mapping-notify-hook* event-slots))
 197       (:property-notify (call-hook *property-notify-hook* event-slots))
 198       (:create-notify (call-hook *create-notify-hook* event-slots))
 199       (:enter-notify (call-hook *enter-notify-hook* event-slots))
 200       (:exposure (call-hook *exposure-hook* event-slots))))
 201   t)
 202
 203
 204
 205 (defun main-loop ()
 206   (loop
 207      (with-xlib-protect
 208        (xlib:display-finish-output *display*)
 209        (xlib:process-event *display* :handler #'handle-event))))
 210 ;;(dbg "Main loop finish" c)))))
 211
 212
 213 (defun open-display (display-str protocol)
 214   (multiple-value-bind (host display-num) (parse-display-string display-str)
 215     (setf *display* (xlib:open-display host :display display-num :protocol protocol)
 216           (getenv "DISPLAY") display-str)))
 217
 218
 219
 220 (defun default-init-hook ()
 221   (let ((frame (add-frame (create-frame :name "Default"
 222                                         :layout nil :x 0.05 :y 0.05
 223                                         :w 0.9 :h 0.9) *root-frame*)))
 224     (setf *current-child* frame)))
 225
 226
 227 (defun init-display ()
 228   (setf *screen* (first (xlib:display-roots *display*))
 229         *root* (xlib:screen-root *screen*)
 230         *no-focus-window* (xlib:create-window :parent *root* :x 0 :y 0 :width 1 :height 1)
 231         *default-font* (xlib:open-font *display* *default-font-string*)
 232         *pixmap-buffer* (xlib:create-pixmap :width (xlib:screen-width *screen*)
 233                                             :height (xlib:screen-height *screen*)
 234                                             :depth (xlib:screen-root-depth *screen*)
 235                                             :drawable *root*)
 236         *in-second-mode* nil
 237         *clfswm-terminal* nil
 238         *vt-keyboard-on* nil)
 239   (init-modifier-list)
 240   (xgrab-init-pointer)
 241   (xgrab-init-keyboard)
 242   (init-last-child)
 243   (call-hook *binding-hook*)
 244   (map-window *no-focus-window*)
 245   (dbg *display*)
 246   (setf (xlib:window-event-mask *root*) (xlib:make-event-mask :substructure-redirect
 247                                                               :substructure-notify
 248                                                               :property-change
 249                                                               :exposure
 250                                                               :button-press
 251                                                               :button-release
 252                                                               :pointer-motion))
 253   ;;(intern-atoms *display*)
 254   (netwm-set-properties)
 255   (xlib:display-force-output *display*)
 256   (setf *child-selection* nil)
 257   (setf *root-frame* (create-frame :name "Root" :number 0) ;; :layout #'tile-space-layout)
 258         *current-root* *root-frame*
 259         *current-child* *current-root*)
 260   (call-hook *init-hook*)
 261   (process-existing-windows *screen*)
 262   (show-all-children *current-root*)
 263   (grab-main-keys)
 264   (xlib:display-finish-output *display*))
 265
 266
 267
 268 (defun xdg-config-home ()
 269   (pathname-directory (concatenate 'string (or (getenv "XDG_CONFIG_HOME")
 270                                                (getenv "HOME"))
 271                                    "/")))
 272
 273
 274 (defun read-conf-file ()
 275   (let* ((user-conf (probe-file (merge-pathnames (user-homedir-pathname) #p".clfswmrc")))
 276          (etc-conf (probe-file #p"/etc/clfswmrc"))
 277          (config-user-conf (probe-file (make-pathname :directory (append (xdg-config-home) '("clfswm"))
 278                                                       :name "clfswmrc")))
 279          (conf (or config-user-conf user-conf etc-conf)))
 280     (if conf
 281         (handler-case (load conf)
 282           (error (c)
 283             (format t "~2%*** Error loading configurtion file: ~A ***~&~A~%" conf c)
 284             (values nil (format nil "~s" c) conf))
 285           (:no-error (&rest args)
 286             (declare (ignore args))
 287             (values t nil conf)))
 288         (values t nil nil))))
 289
 290
 291
 292
 293
 294
 295 (defun exit-clfswm ()
 296   "Exit clfswm"
 297   (throw 'exit-clfswm nil))
 298
 299 (defun reset-clfswm ()
 300   "Reset clfswm"
 301   (throw 'exit-main-loop nil))
 302
 303
 304
 305
 306 (defun main-unprotected (&key (display (or (getenv "DISPLAY") ":0")) protocol
 307                          (base-dir (directory-namestring (or *load-truename* "")))
 308                          error-msg)
 309   (setf *contrib-dir* base-dir)
 310   (read-conf-file)
 311   (handler-case
 312       (open-display display protocol)
 313     (xlib:access-error (c)
 314       (format t "~&~A~&Maybe another window manager is running. [1]~%" c)
 315       (force-output)
 316       (exit-clfswm)))
 317   (handler-case
 318       (init-display)
 319     (xlib:access-error (c)
 320       (ungrab-main-keys)
 321       (xlib:destroy-window *no-focus-window*)
 322       (xlib:close-display *display*)
 323       (format t "~&~A~&Maybe another window manager is running. [2]~%" c)
 324       (force-output)
 325       (exit-clfswm)))
 326   (when error-msg
 327     (info-mode error-msg))
 328   (unwind-protect
 329        (catch 'exit-main-loop
 330          (main-loop))
 331     (ungrab-main-keys)
 332     (xlib:destroy-window *no-focus-window*)
 333     (xlib:free-pixmap *pixmap-buffer*)
 334     (xlib:close-display *display*)))
 335
 336
 337
 338 (defun main (&key (display (or (getenv "DISPLAY") ":0")) protocol
 339              (base-dir (directory-namestring (or *load-truename* ""))))
 340   (let (error-msg)
 341     (catch 'exit-clfswm
 342       (loop
 343          (handler-case
 344              (main-unprotected :display display :protocol protocol :base-dir base-dir
 345                                :error-msg error-msg)
 346            (error (c)
 347              (let ((msg (format nil "CLFSWM Error: ~A." c)))
 348                (format t "~&~A~%Reinitializing...~%" msg)
 349                (setf error-msg (list (list msg *info-color-title*)
 350                                      "Reinitializing...")))))))))
 351
 352
 353