src/package.lisp

   1 ;;; --------------------------------------------------------------------------
   2 ;;; CLFSWM - FullScreen Window Manager
   3 ;;;
   4 ;;; --------------------------------------------------------------------------
   5 ;;; Documentation: Package definition
   6 ;;; --------------------------------------------------------------------------
   7 ;;;
   8 ;;; (C) 2005-2015 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 :cl-user)
  27
  28 (defpackage clfswm
  29   (:use :common-lisp :my-html :tools :version)
  30 ;;  (:shadow :defun)
  31   (:export :main
  32            :reload-clfswm
  33            :reset-clfswm
  34            :exit-clfswm))
  35
  36
  37 ;;;;; Uncomment the line below if you want to see all ignored X errors
  38 ;;(pushnew :xlib-debug *features*)
  39
  40 ;;;;; Uncomment the line below if you want to see all event debug messages
  41 ;;(pushnew :event-debug *features*)
  42
  43 (in-package :clfswm)
  44
  45 ;;; CONFIG - Compress motion notify ?
  46 ;; This variable may be useful to speed up some slow version of CLX.
  47 ;; It is particulary useful with CLISP/MIT-CLX (and others).
  48 (defconfig *have-to-compress-notify* t
  49   nil "Compress event notify?
  50 This variable may be useful to speed up some slow version of CLX.
  51 It is particulary useful with CLISP/MIT-CLX.")
  52
  53 (defconfig *transparent-background* t
  54   nil "Enable transparent background: one of nil, :pseudo, t (xcompmgr must be started)")
  55
  56 (defconfig *default-transparency* 0.8
  57   nil "Default transparency for all windows when in xcompmgr transparency mode")
  58
  59 (defconfig *show-root-frame-p* nil
  60   nil "Show the root frame information or not")
  61
  62
  63 (defconfig *border-size* 1
  64   nil "Windows and frames border size")
  65
  66
  67
  68 (defparameter *modifier-alias* '((:alt :mod-1)     (:alt-l :mod-1)
  69                                  (:numlock :mod-2)
  70                                  (:super_l :mod-4)
  71                                  (:alt-r :mod-5)   (:alt-gr :mod-5)
  72                                  (:capslock :lock))
  73   "Syntax: (modifier-alias effective-modifier)")
  74
  75
  76 (defparameter *display* nil)
  77 (defparameter *screen* nil)
  78 (defparameter *root* nil)
  79 (defparameter *no-focus-window* nil)
  80
  81 (defparameter *sm-window* nil)
  82 (defparameter *sm-font* nil)
  83 (defparameter *sm-gc* nil)
  84
  85
  86 (defparameter *background-image* nil)
  87 (defparameter *background-gc* nil)
  88
  89 (defparameter *expose-child-list* nil)
  90
  91 (defconfig *loop-timeout* 1 nil
  92            "Maximum time (in seconds) to wait before calling *loop-hook*")
  93
  94 (defparameter *pixmap-buffer* nil)
  95
  96 (defparameter *contrib-dir* "contrib/")
  97
  98 (defparameter *default-font* nil)
  99 ;;(defparameter *default-font-string* "9x15")
 100 (defconfig *default-font-string* "fixed" nil
 101            "The default font used in clfswm")
 102
 103 (defconfig *color-move-window* "DeepPink" 'Main-mode
 104            "Color when moving or resizing a windows")
 105
 106 (defparameter *child-selection* nil)
 107
 108 ;;; CONFIG - Default frame datas
 109 (defconfig *default-frame-data*
 110   (list '(:tile-size 0.8) '(:tile-space-size 0.1)
 111         '(:fast-layout (tile-left-layout tile-layout))
 112         '(:main-layout-windows nil))
 113   nil
 114   "Default slots set in frame date")
 115
 116
 117 ;;; CONFIG - Default managed window type for a frame
 118 ;;; type can be  :all, :normal, :transient, :maxsize, :desktop, :dock, :toolbar, :menu, :utility, :splash, :dialog
 119 (defconfig *default-managed-type* '(:normal) nil
 120   "Default managed window types")
 121 ;;(defparameter *default-managed-type* '(:normal :maxsize :transient))
 122 ;;(defparameter *default-managed-type* '(:normal :transient :maxsize :desktop :dock :toolbar :menu :utility :splash :dialog))
 123 ;;(defparameter *default-managed-type* '())
 124 ;;(defparameter *default-managed-type* '(:all))
 125
 126
 127 ;;; CONFIG - Default focus policy
 128 (defconfig *default-focus-policy* :click nil
 129            "Default mouse focus policy. One of :click, :sloppy, :sloppy-strict, :sloppy-select or
 130 :sloppy-select-window.")
 131
 132
 133 (defconfig *show-hide-policy* #'<=
 134   nil "'NIL': always display all children (better with transparency support).
 135 '<': Hide only children less than children above.
 136 '<=': Hide children less or equal to children above (better for performance on slow machine).")
 137
 138 (defconfig *show-hide-policy-type* '(:normal)
 139   nil "Windows types which are optimized by the show hide policy")
 140
 141 (defstruct child-rect child parent selected-p x y w h)
 142
 143 (defstruct root child original current-child x y w h)
 144
 145 (defclass frame ()
 146   ((name :initarg :name :accessor frame-name :initform nil)
 147    (number :initarg :number :accessor frame-number :initform 0)
 148    ;;; Float size between 0 and 1 - Manipulate only those variables and not real size
 149    (x :initarg :x :accessor frame-x :initform 0.1)
 150    (y :initarg :y :accessor frame-y :initform 0.1)
 151    (w :initarg :w :accessor frame-w :initform 0.8)
 152    (h :initarg :h :accessor frame-h :initform 0.8)
 153    ;;; Real size (integer) in screen size - Don't set directly those variables
 154    ;;; they may be recalculated by the layout manager.
 155    (rx :initarg :rx :accessor frame-rx :initform 0)
 156    (ry :initarg :ry :accessor frame-ry :initform 0)
 157    (rw :initarg :rw :accessor frame-rw :initform 800)
 158    (rh :initarg :rh :accessor frame-rh :initform 600)
 159 ;;   (root :initarg :root :accessor frame-root :initform nil
 160 ;;         :documentation "A list a physical coordinates (x y w h) if frame is a root frame. Nil otherwise")
 161    (layout :initarg :layout :accessor frame-layout :initform nil
 162            :documentation "Layout to display windows on a frame")
 163    (nw-hook :initarg :nw-hook :accessor frame-nw-hook :initform nil
 164             :documentation "Hook done by the frame when a new window is mapped")
 165    (managed-type :initarg :managed-type :accessor frame-managed-type
 166                  :initform *default-managed-type*
 167                  :documentation "Managed window type")
 168    (forced-managed-window :initarg :forced-managed-window
 169                           :accessor frame-forced-managed-window
 170                           :initform nil
 171                           :documentation "A list of forced managed windows (xlib:wm-name or window)")
 172    (forced-unmanaged-window :initarg :forced-unmanaged-window
 173                           :accessor frame-forced-unmanaged-window
 174                           :initform nil
 175                           :documentation "A list of forced unmanaged windows (xlib:wm-name or window)")
 176    (show-window-p :initarg :show-window-p :accessor frame-show-window-p :initform t)
 177    (hidden-children :initarg :hidden-children :accessor frame-hidden-children :initform nil
 178                     :documentation "A list of hidden children")
 179    (selected-pos :initarg :selected-pos :accessor frame-selected-pos :initform 0
 180                  :documentation "The position in the child list of the selected child")
 181    (focus-policy :initarg :focus-policy :accessor frame-focus-policy
 182                  :initform *default-focus-policy*)
 183    (window :initarg :window :accessor frame-window :initform nil)
 184    (gc :initarg :gc :accessor frame-gc :initform nil)
 185    (child :initarg :child :accessor frame-child :initform nil)
 186    (data :initarg :data :accessor frame-data
 187          :initform *default-frame-data*
 188          :documentation "An assoc list to store additional data")))
 189
 190
 191
 192 (defparameter *root-frame* nil
 193   "Root of the root - ie the root frame")
 194
 195 (defparameter *main-keys* nil)
 196 (defparameter *main-mouse* nil)
 197 (defparameter *second-keys* nil)
 198 (defparameter *second-mouse* nil)
 199 (defparameter *info-keys* nil)
 200 (defparameter *info-mouse* nil)
 201 (defparameter *query-keys* nil)
 202 (defparameter *circulate-keys* nil)
 203 (defparameter *circulate-keys-release* nil)
 204 (defparameter *expose-keys* nil)
 205 (defparameter *expose-mouse* nil)
 206
 207
 208 (defparameter *other-window-manager* nil)
 209
 210
 211 (defstruct menu name item doc)
 212 (defstruct menu-item key value)
 213
 214
 215 (defparameter *menu* (make-menu :name 'main :doc "Main menu"))
 216
 217
 218
 219
 220 (defconfig *binding-hook* nil 'Hook
 221            "Hook executed when keys/buttons are bounds")
 222
 223 (defconfig *loop-hook* nil 'Hook
 224            "Hook executed on each event loop")
 225
 226 (defconfig *main-entrance-hook* nil 'Hook
 227            "Hook executed on the main function entrance after
 228 loading configuration file and before opening the display.")
 229
 230 (defconfig *root-size-change-hook* nil 'Hook
 231            "Hook executed when the root size has changed for example when adding/removing a monitor")
 232
 233
 234 (defparameter *in-second-mode* nil)
 235
 236
 237 ;;; Placement variables. A list of two absolute coordinates
 238 ;;; or a function: 'Y-X-placement' for absolute placement or
 239 ;;; 'Y-X-child-placement' for child relative placement or
 240 ;;; 'Y-X-root-placement' for root relative placement.
 241 ;;; Where Y-X are one of:
 242 ;;;
 243 ;;; top-left     top-middle     top-right
 244 ;;; middle-left  middle-middle  middle-right
 245 ;;; bottom-left  bottom-middle  bottom-right
 246 ;;;
 247 (defconfig *banish-pointer-placement* 'bottom-right-root-placement
 248   'Placement "Pointer banishment placement")
 249 (defconfig *second-mode-placement* 'top-middle-root-placement
 250   'Placement "Second mode window placement")
 251 (defconfig *info-mode-placement* 'top-left-root-placement
 252   'Placement "Info mode window placement")
 253 (defconfig *query-mode-placement* 'top-left-root-placement
 254   'Placement "Query mode window placement")
 255 (defconfig *circulate-mode-placement* 'bottom-middle-root-placement
 256   'Placement "Circulate mode window placement")
 257 (defconfig *expose-mode-placement* 'top-left-child-placement
 258   'Placement "Expose mode window placement (Selection keys position)")
 259 (defconfig *expose-query-placement* 'bottom-left-root-placement
 260   'Placement "Expose mode query window placement")
 261 (defconfig *fastswitch-mode-placement* 'top-left-root-placement
 262   'Placement "Fastswitch mode window placement")
 263 (defconfig *notify-window-placement* 'bottom-right-root-placement
 264   'Placement "Notify window placement")
 265 (defconfig *ask-close/kill-placement* 'top-right-root-placement
 266   'Placement "Ask close/kill window placement")
 267 (defconfig *unmanaged-window-placement* 'middle-middle-root-placement
 268   'Placement "Unmanager window placement")
 269
 270
 271 (defparameter *in-process-existing-windows* nil)
 272
 273 ;; For debug - redefine defun
 274 ;;(shadow :defun)
 275
 276 ;;(defmacro defun (name args &body body)
 277 ;;  `(progn
 278 ;;    (format t "defun: ~A ~A~%" ',name ',args)
 279 ;;    (force-output)
 280 ;;    (cl:defun ,name ,args
 281 ;;      (handler-case
 282 ;;        (progn
 283 ;;          ,@body)
 284 ;;      (error (c)
 285 ;;        (format t "New defun: Error in ~A : ~A~%" ',name c)
 286 ;;        (format t "Root tree=~A~%All windows=~A~%"
 287 ;;                (xlib:query-tree *root*) (get-all-windows))
 288 ;;        (force-output))))))
 289
 290
 291
 292
 293 (defmacro make-x-drawable (argname type)
 294   "Drawable wrapper to prevent type error in some CLX versions.
 295 Replace xlib:drawable-* functions with x-drawable-* equivalents"
 296   (let ((fun-symbol (create-symbol 'x-drawable- argname))
 297         (set-symbol (create-symbol 'set-x-drawable- argname))
 298         (xlib-equiv-symbol (create-symbol-in-package :xlib 'drawable- argname)))
 299     `(progn
 300        (declaim (inline ,fun-symbol))
 301        (defun ,fun-symbol (window)
 302          (,xlib-equiv-symbol window))
 303        (defun ,set-symbol (window ,argname)
 304          (if (typep ,argname ',type)
 305              (setf (,xlib-equiv-symbol window) ,argname)
 306              (dbg ',(create-symbol 'drawable-type-error- argname) window ,argname (xlib:wm-name window))))
 307        (defsetf ,fun-symbol ,set-symbol))))
 308
 309
 310
 311 (make-x-drawable x (signed-byte 16))
 312 (make-x-drawable y (signed-byte 16))
 313 (make-x-drawable width (unsigned-byte 16))
 314 (make-x-drawable height (unsigned-byte 16))
 315 (make-x-drawable border-width (unsigned-byte 16))