src/clfswm.lisp

   1 ;;; --------------------------------------------------------------------------
   2 ;;; CLFSWM - FullScreen Window Manager
   3 ;;;
   4 ;;; --------------------------------------------------------------------------
   5 ;;; Documentation: Main functions
   6 ;;; --------------------------------------------------------------------------
   7 ;;;
   8 ;;; (C) 2010 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 (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 (xlib:drawable-x window) x))
  55              (when (has-y value-mask) (setf (xlib:drawable-y window) y))
  56              (when (has-h value-mask) (setf (xlib:drawable-height window) height))
  57              (when (has-w value-mask) (setf (xlib:drawable-width window) width))))
  58     (with-xlib-protect
  59       (xlib:with-state (window)
  60         (when (has-bw value-mask)
  61           (setf (xlib:drawable-border-width window) border-width))
  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 (xlib:drawable-x window) (xlib:drawable-y window)
  69                                    (xlib:drawable-width window) (xlib:drawable-height window)
  70                                    (xlib:drawable-border-width window))
  71         (when (has-stackmode value-mask)
  72           (case stack-mode
  73             (:above (raise-window window))))))))
  74
  75 (define-handler main-mode :map-request (window send-event-p)
  76   (unless send-event-p
  77     (unhide-window window)
  78     (process-new-window window)
  79     (map-window window)
  80     (unless (null-size-window-p window)
  81       (show-all-children))))
  82
  83 (define-handler main-mode :unmap-notify (send-event-p event-window window)
  84   (unless (and (not send-event-p)
  85                (not (xlib:window-equal window event-window)))
  86     (when (find-child window *root-frame*)
  87       (delete-child-in-all-frames window)
  88       (show-all-children))))
  89
  90 (define-handler main-mode :destroy-notify (send-event-p event-window window)
  91   (unless (or send-event-p
  92               (xlib:window-equal window event-window))
  93     (when (find-child window *root-frame*)
  94       (delete-child-in-all-frames window)
  95       (show-all-children))))
  96
  97 (define-handler main-mode :enter-notify  (window root-x root-y)
  98   (unless (and (> root-x (- (xlib:screen-width *screen*) 3))
  99                (> root-y (- (xlib:screen-height *screen*) 3)))
 100     (case (if (frame-p *current-child*)
 101               (frame-focus-policy *current-child*)
 102               *default-focus-policy*)
 103       (:sloppy (focus-window window))
 104       (:sloppy-strict (when (and (frame-p *current-child*)
 105                                  (member window (frame-child *current-child*)))
 106                         (focus-window window)))
 107       (:sloppy-select (let* ((child (find-child-under-mouse root-x root-y))
 108                              (parent (find-parent-frame child)))
 109                         (unless (or (equal child *current-root*)
 110                                     (equal (typecase child
 111                                              (xlib:window parent)
 112                                              (t child))
 113                                            *current-child*))
 114                             (focus-all-children child parent)
 115                             (show-all-children)))))))
 116
 117 (define-handler main-mode :exposure (window)
 118   (awhen (find-frame-window window *current-root*)
 119     (display-frame-info it)))
 120
 121
 122 (defun main-loop ()
 123   (loop
 124      (with-xlib-protect
 125          (call-hook *loop-hook*)
 126        (xlib:display-finish-output *display*)
 127        (xlib:process-event *display* :handler #'handle-event :timeout *loop-timeout*))))
 128 ;;(dbg "Main loop finish" c)))))
 129
 130
 131 (defun open-display (display-str protocol)
 132   (multiple-value-bind (host display-num) (parse-display-string display-str)
 133     (setf *display* (xlib:open-display host :display display-num :protocol protocol)
 134           (getenv "DISPLAY") display-str)))
 135
 136
 137
 138 (defun default-init-hook ()
 139   (let ((frame (add-frame (create-frame :name "Default"
 140                                         :layout nil :x 0.05 :y 0.05
 141                                         :w 0.9 :h 0.9) *root-frame*)))
 142     (setf *current-child* frame)))
 143
 144
 145 (defun init-display ()
 146   (assoc-keyword-handle-event 'main-mode)
 147   (setf *screen* (first (xlib:display-roots *display*))
 148         *root* (xlib:screen-root *screen*)
 149         *no-focus-window* (xlib:create-window :parent *root* :x 0 :y 0 :width 1 :height 1)
 150         *default-font* (xlib:open-font *display* *default-font-string*)
 151         *pixmap-buffer* (xlib:create-pixmap :width (xlib:screen-width *screen*)
 152                                             :height (xlib:screen-height *screen*)
 153                                             :depth (xlib:screen-root-depth *screen*)
 154                                             :drawable *root*)
 155         *in-second-mode* nil
 156         *clfswm-terminal* nil
 157         *vt-keyboard-on* nil)
 158   (init-modifier-list)
 159   (xgrab-init-pointer)
 160   (xgrab-init-keyboard)
 161   (init-last-child)
 162   (call-hook *binding-hook*)
 163   (map-window *no-focus-window*)
 164   (dbg *display*)
 165   (setf (xlib:window-event-mask *root*) (xlib:make-event-mask :substructure-redirect
 166                                                               :substructure-notify
 167                                                               :property-change
 168                                                               :exposure
 169                                                               :button-press
 170                                                               :button-release
 171                                                               :pointer-motion))
 172   ;;(intern-atoms *display*)
 173   (netwm-set-properties)
 174   (xlib:display-force-output *display*)
 175   (setf *child-selection* nil)
 176   (setf *root-frame* (create-frame :name "Root" :number 0) ;; :layout #'tile-space-layout)
 177         *current-root* *root-frame*
 178         *current-child* *current-root*)
 179   (call-hook *init-hook*)
 180   (process-existing-windows *screen*)
 181   (show-all-children *current-root*)
 182   (grab-main-keys)
 183   (xlib:display-finish-output *display*))
 184
 185
 186
 187
 188 (defun read-conf-file ()
 189   (let* ((conf (conf-file-name)))
 190     (if conf
 191         (handler-case (load conf)
 192           (error (c)
 193             (format t "~2%*** Error loading configurtion file: ~A ***~&~A~%" conf c)
 194             (values nil (format nil "~s" c) conf))
 195           (:no-error (&rest args)
 196             (declare (ignore args))
 197             (values t nil conf)))
 198         (values t nil nil))))
 199
 200
 201
 202
 203
 204
 205 (defun exit-clfswm ()
 206   "Exit clfswm"
 207   (throw 'exit-clfswm nil))
 208
 209 (defun reset-clfswm ()
 210   "Reset clfswm"
 211   (throw 'exit-main-loop nil))
 212
 213
 214
 215
 216 (defun main-unprotected (&key (display (or (getenv "DISPLAY") ":0")) protocol
 217                          (base-dir (directory-namestring (or *load-truename* "")))
 218                          (read-conf-file-p t) (alternate-conf nil)
 219                          error-msg)
 220   (setf *contrib-dir* base-dir)
 221   (conf-file-name alternate-conf)
 222   (when read-conf-file-p
 223     (read-conf-file))
 224   (handler-case
 225       (open-display display protocol)
 226     (xlib:access-error (c)
 227       (format t "~&~A~&Maybe another window manager is running. [1]~%" c)
 228       (force-output)
 229       (exit-clfswm)))
 230   (handler-case
 231       (init-display)
 232     (xlib:access-error (c)
 233       (ungrab-main-keys)
 234       (xlib:destroy-window *no-focus-window*)
 235       (xlib:close-display *display*)
 236       (format t "~&~A~&Maybe another window manager is running. [2]~%" c)
 237       (force-output)
 238       (exit-clfswm)))
 239   (when error-msg
 240     (info-mode error-msg))
 241   (unwind-protect
 242        (catch 'exit-main-loop
 243          (main-loop))
 244     (ungrab-main-keys)
 245     (xlib:destroy-window *no-focus-window*)
 246     (xlib:free-pixmap *pixmap-buffer*)
 247     (xlib:close-display *display*)
 248     #+:event-debug
 249     (format t "~2&Unhandled events: ~A~%" *unhandled-events*)))
 250
 251
 252 (defun main (&key (display (or (getenv "DISPLAY") ":0")) protocol
 253              (base-dir (directory-namestring (or *load-truename* "")))
 254              (read-conf-file-p t)
 255              (alternate-conf nil))
 256   (let (error-msg)
 257     (catch 'exit-clfswm
 258       (loop
 259          (handler-case
 260              (if *other-window-manager*
 261                  (run-other-window-manager)
 262                  (main-unprotected :display display :protocol protocol :base-dir base-dir
 263                                    :read-conf-file-p read-conf-file-p
 264                                    :alternate-conf alternate-conf
 265                                    :error-msg error-msg))
 266            (error (c)
 267              (let ((msg (format nil "CLFSWM Error: ~A." c)))
 268                (format t "~&~A~%Reinitializing...~%" msg)
 269                (setf error-msg (list (list msg *info-color-title*)
 270                                      "Reinitializing...")))))))))
 271
 272
 273