cgit.sxemacs.org Git - packages/blob - xemacs-packages/xwem/lisp/xwem-rooticon.el

   1 ;;; xwem-rooticon.el --- Support Icons on root window.
   2
   3 ;; Copyright (C) 2004,2005 by XWEM Org.
   4
   5 ;; Author: Zajcev Evgeny <zevlg@yandex.ru>
   6 ;; Created:
   7 ;; Keywords: xwem
   8 ;; X-CVS: $Id: xwem-rooticon.el,v 1.8 2005-04-04 19:54:15 lg Exp $
   9
  10 ;; This file is part of XWEM.
  11
  12 ;; XWEM is free software; you can redistribute it and/or modify it
  13 ;; under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation; either version 2, or (at your option)
  15 ;; any later version.
  16
  17 ;; XWEM is distributed in the hope that it will be useful, but WITHOUT
  18 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
  19 ;; or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public
  20 ;; License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  24 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  25 ;; 02111-1307, USA.
  26
  27 ;;; Synched up with: Not in FSF
  28
  29 ;;; Commentary:
  30
  31 ;;
  32
  33 ;;; Code:
  34 \f
  35 (require 'xwem-load)
  36 (require 'xwem-misc)
  37
  38 (require 'xlib-xpm)
  39 (require 'xlib-xshape)
  40
  41 (defgroup xwem-rooticon nil
  42   "Group to customize rooticon behaviour."
  43   :prefix "xwem-rooticon-"
  44   :group 'xwem)
  45
  46 (defcustom xwem-rooticon-placing 'behind-minibuffer
  47   "*Placing behaviour."
  48   :type '(choice (const :tag "Behind minibuffer" behind-minibuffer)
  49                  (const :tag "Random" random))
  50   :group 'xwem-rooticon)
  51
  52 (defcustom xwem-rooticon-show-label nil
  53   "*Non-nil mean show Icon name in rooticon."
  54   :type 'boolean
  55   :group 'xwem-rooticon)
  56
  57 (defcustom xwem-rooticon-default-icon "root-icon.xpm"
  58   "*Default rooticon to use.
  59 This icon is used which client does not have its own icon."
  60   :type 'file
  61   :group 'xwem-rooticon)
  62
  63 (defcustom xwem-rooticon-default-show-label t
  64   "*Non-nil mean show label, when `xwem-rooticon-default-icon' is used."
  65   :type 'boolean
  66   :group 'xwem-rooticon)
  67
  68 (defcustom xwem-rooticon-always-on-top-spec '((((eval t)) . 15))
  69   "*List of cons cells in format:
  70 \(MATCH-SPEC . RANK) for always-on-top icons.
  71 If MATCH-SPEC matches rooticon's client - than RANK is set as always
  72 on top rank."
  73   :type 'sexp
  74   :group 'xwem-rooticon)
  75
  76 ;;; Internal variables
  77
  78 (defstruct xwem-rooticon
  79   cl
  80   xgeom
  81   xriwin
  82   xiconwin
  83   xpixmap
  84   xpixmask)
  85
  86 (define-xwem-face xwem-rooticon-face
  87   `((t (:foreground "black" :background "tan"
  88         :font "-misc-fixed-medium-r-*-*-10-*-*-*-*-*-*-*")))
  89   "Face to draw text on root icon.")
  90
  91 (defvar xwem-rooticon-map
  92   (let ((map (make-sparse-keymap)))
  93     (define-key map [button1] 'xwem-rooticon-smart-move)
  94     (define-key map [button1up] 'xwem-rooticon-select-cl)
  95     (define-key map [button3] 'xwem-rooticon-menu)
  96     map)
  97   "Keymap for rooticon windows.")
  98
  99 (defvar xwem-rooticon-default-pixmap nil)
 100
 101 (defun xwem-rooticon-ev-handler (xdpy xwin xev)
 102   (let ((ri (X-Win-get-prop xwin 'xwem-rooticon)))
 103     (when (xwem-rooticon-p ri)
 104       (X-Event-CASE xev
 105         ((:X-ButtonPress :X-ButtonRelease)
 106          (xwem-overriding-local-map xwem-rooticon-map
 107            (let ((xwem-click-rooticon ri))
 108              (declare (special xwem-click-rooticon))
 109              (xwem-dispatch-command-xevent xev))))
 110
 111         (:X-Expose
 112          (xwem-rooticon-draw
 113           ri (X-Event-xexpose-x xev) (X-Event-xexpose-y xev)
 114           (X-Event-xexpose-width xev) (X-Event-xexpose-height xev)))
 115
 116         (:X-DestroyNotify
 117          (xwem-cl-rem-sys-prop (xwem-rooticon-cl ri) 'xwem-rooticon)
 118          (xwem-misc-unset-always-on-top xwin)
 119          (X-invalidate-cl-struct ri))))))
 120
 121 (defun xwem-rooticon-icons ()
 122   "Return list of root icons sorted by X."
 123   (sort (delq nil (mapcar (lambda (cl)
 124                             (xwem-cl-get-sys-prop cl 'xwem-rooticon))
 125                           xwem-clients))
 126         (lambda (ri1 ri2)
 127           (> (X-Geom-x (xwem-rooticon-xgeom ri1))
 128              (X-Geom-x (xwem-rooticon-xgeom ri2))))))
 129
 130 (defun xwem-rooticon-select-place (cl w h)
 131   "Select place for rooticon."
 132   (or (xwem-client-property cl 'rooticon-position)
 133       (cond ((eq xwem-rooticon-placing 'behind-minibuffer)
 134              ;; Behind the minibuffer
 135              (let ((ris
 136                     (sort
 137                      (delq
 138                       nil
 139                       (mapcar
 140                        (lambda (cl)
 141                          (let ((ri (xwem-cl-get-sys-prop cl 'xwem-rooticon)))
 142                            (and ri (>= (+ (X-Geom-y (xwem-rooticon-xgeom ri))
 143                                           (X-Geom-height
 144                                            (xwem-rooticon-xgeom ri)))
 145                                        (- (X-Geom-height (xwem-rootgeom)) h))
 146                                 ri)))
 147                        xwem-clients))
 148                      (lambda (ri1 ri2)
 149                        (< (X-Geom-x (xwem-rooticon-xgeom ri1))
 150                           (X-Geom-x (xwem-rooticon-xgeom ri2))))))
 151                    ri1 ri2
 152                    (x 0))
 153                (while ris
 154                  (setq ri1 (car ris)
 155                        ri2 (cadr ris))
 156                  (setq x (+ (X-Geom-x (xwem-rooticon-xgeom ri1))
 157                             (X-Geom-width (xwem-rooticon-xgeom ri1))))
 158                  (when (and ri1 ri2
 159                             (>= (- (X-Geom-x (xwem-rooticon-xgeom ri2)) x) w))
 160                    (setq ris nil))
 161                  (setq ris (cdr ris)))
 162                (cons x (- (X-Geom-height (xwem-rootgeom)) h))))
 163
 164             ((eq xwem-rooticon-placing 'random)
 165              (cons (random (- (X-Geom-width (xwem-rootgeom)) w))
 166                    (random (- (X-Geom-height (xwem-rootgeom)) h)))))))
 167
 168 (defun xwem-rooticon-create (cl)
 169   "Create rooticon for CL."
 170   (let ((wmh (xwem-hints-wm-hints (xwem-cl-hints cl)))
 171         (ri (make-xwem-rooticon :cl cl))
 172         place)
 173     ;; Fill pixmap/mask fields
 174     (cond ((and (X-WMHints-iconpixmap-p wmh)
 175                 (= (XGetDepth (xwem-dpy) (xwem-rootwin))
 176                    (XGetDepth (xwem-dpy) (make-X-Pixmap
 177                                           :id (X-WMHints-icon-pixmap wmh)))))
 178            ;; Has a pixmap of same depth as root window
 179            (setf (xwem-rooticon-xpixmap ri)
 180                  (make-X-Pixmap :id (X-WMHints-icon-pixmap wmh)))
 181            (when (X-WMHints-iconmask-p wmh)
 182              (setf (xwem-rooticon-xpixmask ri)
 183                    (make-X-Pixmap :id (X-WMHints-icon-mask wmh)))))
 184           (t (unless xwem-rooticon-default-pixmap
 185                (setq xwem-rooticon-default-pixmap
 186                      (cons (X:xpm-pixmap-from-file
 187                             (xwem-dpy) (xwem-rootwin)
 188                             (expand-file-name
 189                              xwem-rooticon-default-icon xwem-icons-dir))
 190                            (X:xpm-pixmap-from-file
 191                             (xwem-dpy) (xwem-rootwin)
 192                             (expand-file-name
 193                              xwem-rooticon-default-icon xwem-icons-dir)
 194                             t))))
 195              (setf (xwem-rooticon-xpixmap ri)
 196                    (car xwem-rooticon-default-pixmap))
 197              (setf (xwem-rooticon-xpixmask ri)
 198                    (cdr xwem-rooticon-default-pixmap))))
 199
 200     (setf (xwem-rooticon-xgeom ri)
 201           (XGetGeometry (xwem-dpy) (xwem-rooticon-xpixmap ri)))
 202
 203     (setq place (xwem-rooticon-select-place
 204                  cl (X-Geom-width (xwem-rooticon-xgeom ri))
 205                  (X-Geom-height (xwem-rooticon-xgeom ri))))
 206     (setf (X-Geom-x (xwem-rooticon-xgeom ri)) (car place))
 207     (setf (X-Geom-y (xwem-rooticon-xgeom ri)) (cdr place))
 208     (setf (xwem-rooticon-xriwin ri)
 209           (XCreateWindow (xwem-dpy) (xwem-rootwin)
 210                          (X-Geom-x (xwem-rooticon-xgeom ri))
 211                          (X-Geom-y (xwem-rooticon-xgeom ri))
 212                          (X-Geom-width (xwem-rooticon-xgeom ri))
 213                          (X-Geom-height (xwem-rooticon-xgeom ri))
 214                          0
 215                          nil nil nil
 216                          (make-X-Attr :override-redirect t
 217                                       :event-mask (Xmask-or XM-ButtonPress
 218                                                             XM-ButtonRelease
 219                                                             XM-ButtonMotion
 220                                                             XM-Exposure))))
 221
 222     ;; Apply mask
 223     (when (xwem-rooticon-xpixmask ri)
 224       (X-XShapeMask (xwem-dpy) (xwem-rooticon-xriwin ri)
 225                     X-XShape-Bounding X-XShapeSet 0 0
 226                     (xwem-rooticon-xpixmask ri)))
 227
 228     (X-Win-EventHandler-add (xwem-rooticon-xriwin ri)
 229                             'xwem-rooticon-ev-handler nil
 230                             (list X-ButtonPress X-ButtonRelease
 231                                   X-DestroyNotify X-Expose))
 232     (X-Win-put-prop (xwem-rooticon-xriwin ri) 'xwem-rooticon ri)
 233     (xwem-cl-put-sys-prop cl 'xwem-rooticon ri)
 234     ri))
 235
 236 (defun xwem-rooticon-draw (ri &optional x y w h)
 237   (XCopyArea (xwem-dpy) (xwem-rooticon-xpixmap ri)
 238              (xwem-rooticon-xriwin ri) (XDefaultGC (xwem-dpy))
 239              (or x 0) (or y 0)
 240              (or w (X-Geom-width (xwem-rooticon-xgeom ri)))
 241              (or h (X-Geom-height (xwem-rooticon-xgeom ri)))
 242              (or x 0) (or y 0))
 243
 244   ;; Icon label
 245   (when (or xwem-rooticon-show-label
 246             (and xwem-rooticon-default-show-label
 247                  (eq (car xwem-rooticon-default-pixmap)
 248                      (xwem-rooticon-xpixmap ri))
 249                  (eq (cdr xwem-rooticon-default-pixmap)
 250                      (xwem-rooticon-xpixmask ri))))
 251     (XImageString (xwem-dpy) (xwem-rooticon-xriwin ri)
 252                   (xwem-face-get-gc 'xwem-rooticon-face nil
 253                                     (xwem-rooticon-cl ri))
 254                   0 (- (X-Geom-height (xwem-rooticon-xgeom ri))
 255                        (X-Font-fontdescent
 256                         (X-Gc-font (xwem-face-get-gc 'xwem-rooticon-face))))
 257                   (or (and (> (length (xwem-cl-wm-icon-name
 258                                        (xwem-rooticon-cl ri))) 0)
 259                            (xwem-cl-wm-icon-name (xwem-rooticon-cl ri)))
 260                       (xwem-cl-wm-name (xwem-rooticon-cl ri))))))
 261
 262 ;;; Hooking into clients handling
 263 (define-xwem-deffered xwem-rooticon-apply-state (ri)
 264   "Show/hide rooticon RI according to RI's client state."
 265   (when (and (xwem-rooticon-p ri)
 266              (xwem-cl-p (xwem-rooticon-cl ri)))
 267     (case (xwem-cl-state (xwem-rooticon-cl ri))
 268       (iconified
 269        (xwem-misc-lower-xwin (xwem-rooticon-xriwin ri))
 270        (XMapWindow (xwem-dpy) (xwem-rooticon-xriwin ri))
 271        (xwem-rooticon-draw ri))
 272
 273       (t (XUnmapWindow (xwem-dpy) (xwem-rooticon-xriwin ri))))))
 274
 275 (defun xwem-rooticon-cl-state-change-hook (cl old-state new-state)
 276   "Handle CL's state change."
 277   (let ((ri (xwem-cl-get-sys-prop cl 'xwem-rooticon)))
 278     ;; Create rooticon if not yet created
 279     (when (and (eq new-state 'iconified)
 280                (not ri))
 281       (setq ri (xwem-rooticon-create cl)))
 282     (when ri
 283       ;; Set always on top rank (if any)
 284       (let ((rank (find cl xwem-rooticon-always-on-top-spec
 285                         :key 'car :test 'xwem-cl-match-p)))
 286         (when rank
 287           (xwem-misc-set-xwin-always-on-top
 288            (xwem-rooticon-xriwin ri) (cdr rank))))
 289
 290       (xwem-rooticon-apply-state ri))))
 291
 292 (defun xwem-rooticon-cl-destroy (cl)
 293   (let ((ri (xwem-cl-get-sys-prop cl 'xwem-rooticon)))
 294     (when ri
 295       (xwem-cl-rem-sys-prop cl 'xwem-rooticon)
 296       (xwem-misc-unset-always-on-top (xwem-rooticon-xriwin ri))
 297       (XDestroyWindow (xwem-dpy) (xwem-rooticon-xriwin ri))
 298       (X-invalidate-cl-struct ri))))
 299
 300 (defun xwem-rooticon-init ()
 301   "Initialize root icons."
 302   (xwem-message 'init "Initializing root icons ...")
 303   (add-hook 'xwem-cl-state-change-hook 'xwem-rooticon-cl-state-change-hook)
 304   (add-hook 'xwem-cl-destroy-hook 'xwem-rooticon-cl-destroy)
 305   (xwem-message 'init "Initializing root icons ... done"))
 306
 307 ;;; Commands
 308 (define-xwem-command xwem-rooticon-smart-move ()
 309   "Interactively move rooticon.
 310 If only clicked(not moving) bypass button release event."
 311   (xwem-interactive)
 312
 313   (unless (button-press-event-p xwem-last-event)
 314     (error 'xwem-error
 315            "`xwem-rooticon-smart-move' must be bound to mouse event"))
 316
 317   (let ((xev (xwem-next-event nil (list X-ButtonRelease X-MotionNotify))))
 318     (X-Event-CASE xev
 319       (:X-ButtonRelease
 320        (xwem-dispatch-command-xevent xev))
 321
 322       (:X-MotionNotify
 323        (declare (special xwem-click-rooticon))
 324        (let ((sx (- (X-Event-xmotion-root-x xev)
 325                     (X-Geom-x (xwem-rooticon-xgeom xwem-click-rooticon))))
 326              (sy (- (X-Event-xmotion-root-y xev)
 327                     (X-Geom-y (xwem-rooticon-xgeom xwem-click-rooticon))))
 328              (done nil))
 329          (xwem-mouse-grab
 330           xwem-cursor-move (xwem-rooticon-xriwin xwem-click-rooticon)
 331           (Xmask-or XM-ButtonMotion XM-ButtonRelease))
 332          (xwem-unwind-protect
 333              (while (not done)
 334                (X-Event-CASE
 335                    (setq xev (xwem-next-event
 336                               nil (list X-MotionNotify X-ButtonRelease)))
 337                  (:X-ButtonRelease (setq done t))
 338
 339                  (:X-MotionNotify
 340                   (setf (X-Geom-x (xwem-rooticon-xgeom xwem-click-rooticon))
 341                         (- (X-Event-xmotion-root-x xev) sx))
 342                   (setf (X-Geom-y (xwem-rooticon-xgeom xwem-click-rooticon))
 343                         (- (X-Event-xmotion-root-y xev) sy))
 344                   (XMoveWindow
 345                    (xwem-dpy) (xwem-rooticon-xriwin xwem-click-rooticon)
 346                    (X-Geom-x (xwem-rooticon-xgeom xwem-click-rooticon))
 347                    (X-Geom-y (xwem-rooticon-xgeom xwem-click-rooticon))))))
 348            (xwem-mouse-ungrab)))))))
 349
 350 (define-xwem-command xwem-rooticon-select-cl ()
 351   "Select roowin client."
 352   (xwem-interactive)
 353
 354   (unless (or (button-press-event-p xwem-last-event)
 355               (button-release-event-p xwem-last-event))
 356     (error 'xwem-error
 357            "`xwem-rooticon-select-cl' must be bound to mouse event"))
 358
 359   (declare (special xwem-click-rooticon))
 360   (let ((ricl (xwem-rooticon-cl xwem-click-rooticon)))
 361     (when (and (xwem-cl-p ricl) (xwem-cl-managed-p ricl))
 362       (if (xwem-dummy-client-p ricl)
 363           (xwem-activate ricl)
 364         (xwem-select-client ricl)))))
 365
 366 (defun xwem-rooticon-genmenu (ri)
 367   "Generate menu for rooticon RI."
 368   ;; XXX menu title
 369   (list (if (> (length (xwem-cl-wm-icon-name (xwem-rooticon-cl ri))) 18)
 370             (concat (substring (xwem-cl-wm-icon-name (xwem-rooticon-cl ri)) 0 16) "..")
 371           (xwem-cl-wm-icon-name (xwem-rooticon-cl ri)))
 372         (vector "Select" `(xwem-select-client ,(xwem-rooticon-cl ri)))
 373         (vector "Info" `(xwem-client-info ,(xwem-rooticon-cl ri)))
 374         (vector "Mark" `(if (xwem-cl-marked-p ,(xwem-rooticon-cl ri))
 375                             (xwem-client-unset-mark ,(xwem-rooticon-cl ri))
 376                           (xwem-client-set-mark ,(xwem-rooticon-cl ri)))
 377                 :style 'toggle :selected `(xwem-cl-marked-p ,(xwem-rooticon-cl ri)))
 378         "--"
 379         (vector "Close" `(xwem-client-kill ,(xwem-rooticon-cl ri)))
 380         (vector "Kill" `(xwem-client-kill ,(xwem-rooticon-cl ri) '(4)))))
 381
 382 (define-xwem-command xwem-rooticon-menu ()
 383   "Popup rooticon menu."
 384   (xwem-interactive)
 385   (let ((ri (X-Win-get-prop (X-Event-win xwem-last-xevent) 'xwem-rooticon)))
 386     (when (xwem-rooticon-p ri)
 387       (xwem-popup-menu (xwem-rooticon-genmenu ri)))))
 388
 389 (defun xwem-rooticon-set-position (cl prop val)
 390   "Set CL's rooticon position property PROP to VAL."
 391   (let ((ri (xwem-cl-get-sys-prop cl 'xwem-rooticon)))
 392     (if (not (xwem-rooticon-p ri))
 393         (xwem-cl-put-prop cl prop val)
 394
 395       (setf (X-Geom-x (xwem-rooticon-xgeom ri)) (car val))
 396       (setf (X-Geom-y (xwem-rooticon-xgeom ri)) (cdr val))
 397       (XMoveWindow (xwem-dpy) (xwem-rooticon-xriwin ri)
 398                    (X-Geom-x (xwem-rooticon-xgeom ri))
 399                    (X-Geom-y (xwem-rooticon-xgeom ri))))))
 400
 401 (defun xwem-rooticon-get-position (cl prop)
 402   "Return CL's rooticon position property PROP."
 403   (let ((ri (xwem-cl-get-sys-prop cl 'xwem-rooticon)))
 404     (if (not (xwem-rooticon-p ri))
 405         (xwem-cl-get-prop cl prop)
 406       (cons (X-Geom-x (xwem-rooticon-xgeom ri))
 407             (X-Geom-y (xwem-rooticon-xgeom ri))))))
 408
 409 (define-xwem-client-property rooticon-position nil
 410   "Client's rooticon position."
 411   :type '(cons (number :tag "X")
 412                (number :tag "Y"))
 413   :set 'xwem-rooticon-set-position
 414   :get 'xwem-rooticon-get-position)
 415
 416 \f
 417 (provide 'xwem-rooticon)
 418
 419 ;;;; On-load actions:
 420 (if xwem-started
 421     (xwem-rooticon-init)
 422   (add-hook 'xwem-before-init-wins-hook 'xwem-rooticon-init))
 423
 424 ;;; xwem-rooticon.el ends here