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

   1 ;;; xwem-tray.el --- Tray support for XWEM.
   2
   3 ;; Copyright (C) 2003-2005 by XWEM Org.
   4
   5 ;; Author: Zajcev Evgeny <zevlg@yandex.ru>
   6 ;; Created: 1 Sep 2003
   7 ;; Keywords: xlib, xwem
   8 ;; X-CVS: $Id: xwem-tray.el,v 1.9 2005-04-04 19:54:17 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 ;; We should implement something like dockapp handler(or system tray),
  32 ;; that will be placed on free space of xwem-minibuffer or xwem-frame
  33 ;; and handle external X applications. It may receive some
  34 ;; ClientMessages and process them. Some of this ClientMessage should
  35 ;; be used to run elisp code.
  36 ;;
  37 ;; See how mbdock from matchbox made.
  38 ;;
  39 ;; xwem tray creates fake window which is only used to hold selection
  40 ;; needed for communicatio, xwem minibuffer window will be used for
  41 ;; holding apps.
  42 ;;
  43 ;;; TODO:
  44 ;;    - Proper possition in `xwem-minibuffer' calculation.
  45 ;;    - Run elisp support(almost already done).
  46 ;;
  47
  48 ;;; Code:
  49 \f
  50 (require 'xlib-tray)
  51 (require 'xwem-load)
  52 (require 'xwem-help)
  53 (require 'xwem-manage)
  54
  55 ;;; xwem tray constants
  56 (defconst xwem-tc-dock-req 0 "Dock place request.")
  57 (defconst xwem-tc-message 1 "Message from dock app.")
  58 (defconst xwem-tc-cancel-message 2 "Cancels message.")
  59 (defconst xwem-tc-run-lisp 3 "Evaluate emacs lisp string")
  60
  61 (defvar xwem-tray-message-hook 'xwem-tray-message-defhook
  62   "*Hook to be called whin new message from dock app.
  63 Function will be called with arg - dockapp.")
  64
  65 (defcustom xwem-tray-id 0 "System tray identificator.")
  66
  67 (defcustom xwem-tray-name "xwem-tray"
  68   "X Name for xwem tray.")
  69
  70 (defcustom xwem-tray-class '("xwem-tray" "xwem-tray")
  71   "X Class for xwem tray")
  72
  73 (defconst xwem-tray-evmask (Xmask-or XM-SubstructureNotify
  74                                      XM-Exposure
  75                                      XM-StructureNotify
  76                                      XM-SubstructureRedirect
  77                                      XM-PropertyChange
  78                                      XM-ButtonPress
  79                                      XM-ButtonRelease))
  80
  81 ;;; Configuration for xwem system tray
  82 (defgroup xwem-tray nil
  83   "Group to customize XWEM system tray."
  84   :prefix "xwem-tray-"
  85   :group 'xwem)
  86
  87 (defcustom xwem-tray-use-groups nil
  88   "*Non-nil mean systray with use EXPERIMENTAL dockapp grouping.
  89 Set it to non-nil on your own risk."
  90   :type 'boolean
  91   :group 'xwem-tray)
  92
  93 (defcustom xwem-tray-default-align 'right
  94   "*Position in minibuffer where dockapps will placed."
  95   :type '(choice (const :tag "At Right" right)
  96                  (const :tag "At Left" left))
  97   :group 'xwem-tray)
  98
  99 (defcustom xwem-tray-minib-start-offset 4
 100   "*Start offset in pixels."
 101   :type 'number
 102   :group 'xwem-tray)
 103
 104 (defcustom xwem-tray-minib-dock-offset 5
 105   "*Offset in pixels between dockapps."
 106   :type 'number
 107   :group 'xwem-tray)
 108
 109 (defcustom xwem-tray-groups-distance 5
 110   "*Minimum distance between systray groups."
 111   :type 'number
 112   :group 'xwem-tray)
 113
 114 (defcustom xwem-tray-cursor-shape 'X-XC-right_ptr
 115   "*Cursor shape which will be used when pointer is over dock app."
 116   :type (xwem-cursor-shape-choice)
 117   :set (xwem-cus-set-cursor-shape
 118         xwem-tray-cursor
 119         (and (xwem-tray-p xwem-tray) (xwem-tray-xwin xwem-tray)))
 120   :initialize 'custom-initialize-default
 121   :group 'xwem-tray)
 122
 123 (defcustom xwem-tray-cursor-foreground-color "#000075"
 124   "*Cursor's foreground color used when poniter is on dock app."
 125   :type 'color
 126   :set (xwem-cus-set-cursor-foreground xwem-tray-cursor)
 127   :initialize 'custom-initialize-default
 128   :group 'xwem-tray)
 129
 130 (defcustom xwem-tray-cursor-background-color "#000039"
 131   "*Cursor's background color used when poniter is on dock app."
 132   :type 'color
 133   :set (xwem-cus-set-cursor-background xwem-tray-cursor)
 134   :initialize 'custom-initialize-default
 135   :group 'xwem-tray)
 136
 137 (define-xwem-face xwem-tray-group-face
 138   `(((light) (:foreground "white"))
 139     ((medium) (:foreground "gray50"))
 140     ((dark) (:foreground "black")))
 141   "*Face to outline dockapp groups."
 142   :group 'xwem-tray
 143   :group 'xwem-faces)
 144
 145 ;;; Delimiter stuff
 146 (defcustom xwem-tray-delimiter-width 4
 147   "*Delimiter width."
 148   :type 'number
 149   :group 'xwem-tray)
 150
 151 (defcustom xwem-tray-delimiter-height-reminder 2
 152   "*How many pixels on top/bottom from xwem minibuffer.."
 153   :type 'number
 154   :group 'xwem-tray)
 155
 156 (define-xwem-face xwem-tray-delimiter-face
 157   `(((background light)
 158      (:foreground "gray40"))
 159     ((background light shadow)
 160      (:foreground "gray30"))
 161     ((background dark)
 162      (:foreground "gray70"))
 163     ((background dark shadow)
 164      (:foreground "gray80"))
 165     (t (:foreground "gray55")))
 166   "Face to draw systray delimiter."
 167   :group 'xwem-tray
 168   :group 'xwem-faces)
 169
 170 ;;; Internal variables
 171
 172 (defvar xwem-tray-groups '("desktop"  "launch" "misc" "default")
 173   "List of valid dockapp groups.")
 174
 175 (defconst xwem-tray-align-left 1)
 176 (defconst xwem-tray-align-right 2)
 177
 178
 179 ;;; Internal variables
 180 (defvar xwem-tray nil
 181   "Default xwem system tray.")
 182
 183 (defvar xwem-tray-cursor nil
 184   "Cursor used when pointer is over dock app.")
 185 (defvar xwem-tray-curroffset 0
 186   "Current offset in pixels.")
 187
 188 ;;; Dock applications
 189 ;;
 190 ;; Dock is array in form:
 191 ;;  [x-window geom-after-reparent]
 192 (defvar xwem-tray-dapp-list nil "List of dockapp X windows.")
 193
 194 ;; System tray
 195 (defstruct xwem-tray
 196   xwin                                  ; Tray's X window
 197   xgeom                                 ; Tray's X geometry
 198   atoms
 199
 200   groups                                ; list of groups
 201   dockapps                              ; compatible with old style
 202   plist)                                ; tray properties
 203
 204 (defmacro xwem-tray-rem-prop (tray prop)
 205   "From TRAY's property list, remove property PROP."
 206   `(setf (xwem-tray-plist ,tray)
 207          (plist-remprop (xwem-tray-plist ,tray) ,prop)))
 208 (defmacro xwem-tray-put-prop (tray prop val)
 209   "In TRAY's plist put PROP with VAL."
 210   `(if ,val
 211        (setf (xwem-tray-plist ,tray)
 212              (plist-put (xwem-tray-plist ,tray) ,prop ,val))
 213      (xwem-tray-rem-prop ,tray ,prop)))
 214 (defmacro xwem-tray-get-prop (tray prop)
 215   "Get TRAY's property PROP."
 216   `(plist-get (xwem-tray-plist ,tray) ,prop))
 217
 218 (defstruct xwem-tray-group
 219   name                                  ; group name
 220   align                                 ; group align
 221   xwin                                  ; group window
 222   xgeom                                 ; group window geometry
 223
 224   dockapps
 225   plist)                                ; properties
 226
 227 ;; Dockapp structure
 228 (defstruct xwem-dapp
 229   xwin
 230   geom
 231
 232   group                                 ; group
 233   plist                                 ; dockapp properties
 234
 235   ;; for xembed messaging
 236   mess-type
 237   mess-waitlen
 238   mess-currlen
 239   mess)
 240
 241 (defmacro xwem-dapp-alive-p (dapp)
 242   "Return non-nil if DAPP is alive dock application."
 243   `(and (xwem-dapp-p ,dapp)
 244         (memq ,dapp xwem-tray-dapp-list)))
 245
 246 (defmacro xwem-dapp-rem-prop (dapp prop)
 247   `(setf (xwem-dapp-plist ,dapp)
 248          (plist-remprop (xwem-dapp-plist dapp) ,prop)))
 249
 250 (defmacro xwem-dapp-put-prop (dapp prop val)
 251   `(if ,val
 252        (setf (xwem-dapp-plist ,dapp)
 253              (plist-put (xwem-dapp-plist ,dapp) ,prop ,val))
 254      (xwem-dapp-rem-prop ,dapp ,prop)))
 255
 256 (defmacro xwem-dapp-get-prop (dapp prop)
 257   `(plist-get (xwem-dapp-plist ,dapp) ,prop))
 258
 259 (defmacro xwem-dapp-group-name (dapp)
 260   `(xwem-dapp-get-prop ,dapp 'group))
 261 (defsetf xwem-dapp-group-name (dapp) (group)
 262   `(xwem-dapp-put-prop ,dapp 'group ,group))
 263
 264 (defmacro xwem-dapp-id (dapp)
 265   `(xwem-dapp-get-prop ,dapp 'id))
 266 (defsetf xwem-dapp-id (dapp) (id)
 267   `(xwem-dapp-put-prop ,dapp 'id ,id))
 268
 269 (defmacro xwem-dapp-align (dapp)
 270   `(xwem-dapp-get-prop ,dapp 'align))
 271 (defsetf xwem-dapp-align (dapp) (align)
 272   `(xwem-dapp-put-prop ,dapp 'align ,align))
 273
 274 (defmacro xwem-dapp-state (dapp)
 275   `(xwem-dapp-get-prop ,dapp 'state))
 276 (defsetf xwem-dapp-state (dapp) (state)
 277   `(xwem-dapp-put-prop ,dapp 'state ,state))
 278
 279 ;; Message is vector in form:
 280 ;;  [message-type message-waitlen message-currlen message-string]
 281
 282 ;; message-type is one of `xwem-tc-message', `xwem-tc-cancel-message'
 283 ;; or `xwem-tc-run-lisp'.
 284 \f
 285 ;;; Functions
 286
 287 ;;{{{  [-] Groups
 288
 289 (defun xwem-tray-group-get-position (group)
 290   "Get good position in system tray for tray GROUP."
 291   (let ((groups (xwem-tray-groups xwem-tray))
 292         (dtlen xwem-tray-minib-start-offset))
 293     (while groups
 294       (when (eq (xwem-tray-group-align (car groups))
 295                 (xwem-tray-group-align group))
 296         (incf dtlen (X-Geom-width (xwem-tray-group-xgeom (car groups))))
 297         (incf dtlen xwem-tray-groups-distance))
 298       (setq groups (cdr groups)))
 299
 300     (ecase (xwem-tray-group-align group)
 301       (right
 302        (- (X-Geom-width (xwem-minib-xgeom xwem-minibuffer))
 303           dtlen (X-Geom-width (xwem-tray-group-xgeom group))))
 304       (left
 305        (+ (X-Geom-width (xwem-minib-cl-xgeom xwem-minibuffer))
 306           dtlen)))))
 307
 308 (defun xwem-tray-group-find (name)
 309   "Search for tray group with NAME."
 310   (let ((groups (xwem-tray-groups xwem-tray)))
 311     (while (and groups
 312                 (not (string= (xwem-tray-group-name (car groups)) name)))
 313       (setq groups (cdr groups)))
 314     (car groups)))
 315
 316 (defun xwem-tray-group-create (name &rest params)
 317   "Create and return new systray group, giving it NAME.
 318 Additional PARAMS can be specified."
 319   (let ((xtg (apply 'make-xwem-tray-group :name name params)))
 320     (unless (xwem-tray-group-align xtg)
 321       (setf (xwem-tray-group-align xtg)
 322             xwem-tray-default-align))
 323     (unless (xwem-tray-group-xgeom xtg)
 324       (setf (xwem-tray-group-xgeom xtg)
 325             (make-X-Geom :x 0 :y 0 :width 16 :height 16)))
 326
 327     (setf (X-Geom-x (xwem-tray-group-xgeom xtg))
 328           (xwem-tray-group-get-position xtg))
 329     (setf (xwem-tray-group-xwin xtg)
 330           (XCreateWindow
 331            (xwem-dpy) (xwem-tray-xwin xwem-tray)
 332            (X-Geom-x (xwem-tray-group-xgeom xtg))
 333            (X-Geom-y (xwem-tray-group-xgeom xtg))
 334            (X-Geom-width (xwem-tray-group-xgeom xtg))
 335            (X-Geom-height (xwem-tray-group-xgeom xtg))
 336            (X-Geom-border-width (xwem-tray-group-xgeom xtg))
 337            nil nil nil
 338            (make-X-Attr :override-redirect t
 339                         :background-pixel
 340                         (X-Gc-foreground
 341                          (xwem-face-get-gc 'xwem-tray-group-face '(medium)))
 342                         :event-mask (Xmask-or XM-ButtonPress
 343                                               XM-ButtonRelease))))
 344
 345     ;; Add to tray's groups
 346     (setf (xwem-tray-groups xwem-tray)
 347           (cons xtg (xwem-tray-groups xwem-tray)))
 348     xtg))
 349
 350 (defun xwem-tray-group-same-align-sorted (group)
 351   "Return list of groups with same align as GROUP."
 352   (sort (delq nil (mapcar #'(lambda (g)
 353                               (and (eql (xwem-tray-group-align g)
 354                                         (xwem-tray-group-align g)) g))
 355                           (xwem-tray-groups xwem-tray)))
 356         #'(lambda (g1 g2)
 357             (> (X-Geom-x (xwem-tray-group-xgeom g1))
 358                (X-Geom-x (xwem-tray-group-xgeom g2))))))
 359
 360 (defun xwem-tray-group-resize (group new-width new-height)
 361   "Resize tray GROUP to NEW-WIDTH and NEW-HEIGHT."
 362   (let ((glist (xwem-tray-group-same-align-sorted group))
 363         (off (- new-width
 364                 (X-Geom-width (xwem-tray-group-xgeom group)))))
 365     (if (eq (xwem-tray-group-align group) 'left)
 366         (setq glist (cdr (memq group glist)))
 367       (setq glist (cdr (memq group (nreverse glist)))
 368             off (- new-width)))
 369
 370     (mapc #'(lambda (g)
 371               (incf (X-Geom-x (xwem-tray-group-xgeom g)) off)
 372               (XMoveWindow (xwem-dpy) (xwem-tray-group-xwin g)
 373                            (X-Geom-x (xwem-tray-group-xgeom g))
 374                            (X-Geom-y (xwem-tray-group-xgeom g))))
 375           glist)
 376     (incf (X-Geom-width (xwem-tray-group-xgeom group)) off)
 377     (XResizeWindow (xwem-dpy) (xwem-tray-group-xwin group)
 378                    (X-Geom-width (xwem-tray-group-xgeom group))
 379                    (X-Geom-height (xwem-tray-group-xgeom group)))
 380     ))
 381
 382 (defun xwme-tray-group-repositionate-dapps (group)
 383   "Repositionate GROUP's dock applications."
 384   (let ((gdapps (xwem-tray-group-dockapps group))
 385         (step 3)
 386         (coff 3))
 387     (while gdapps
 388       (setf (X-Geom-x (xwem-dapp-geom (car gdapps))) coff)
 389       ;; XXX do it deffering
 390       (XMoveWindow (xwem-dpy) (xwem-dapp-xwin (car gdapps))
 391                    (X-Geom-x (xwem-dapp-geom (car gdapps)))
 392                    (X-Geom-y (xwem-dapp-geom (car gdapps))))
 393       (incf coff (X-Geom-width (xwem-dapp-geom (car gdapps))))
 394       (incf coff step)
 395       (setq gdapps (cdr gdapps)))
 396
 397     (when (> coff (X-Geom-width (xwem-tray-group-xgeom group)))
 398       (xwem-tray-group-resize
 399        group coff
 400        (X-Geom-height (xwem-tray-group-xgeom group))))))
 401
 402 (defun xwem-tray-group-attach-dapp (group dapp)
 403   "To tray GROUP attach dock application DAPP."
 404   (let ((gdapps (xwem-tray-group-dockapps group)))
 405     (XReparentWindow (xwem-dpy) (xwem-tray-group-xwin group)
 406                      (xwem-dapp-xwin dapp) 0 0)
 407     (while (and gdapps
 408                 (> (xwem-dapp-id (car gdapps))
 409                    (xwem-dapp-id dapp)))
 410       (setq gdapps (cdr gdapps)))
 411     (if (not gdapps)
 412         (setf (xwem-tray-group-dockapps group)
 413               (append (xwem-tray-group-dockapps group)
 414                       (list dapp)))
 415       (setcdr gdapps (cons (car gdapps) (cdr gdapps)))
 416       (setcar gdapps dapp))
 417
 418     (xwme-tray-group-repositionate-dapps group)))
 419
 420 (defun xwem-tray-group-find-create (name)
 421   "Find existing or create new group."
 422   (or (xwem-tray-group-find name)
 423       (xwem-tray-group-create name)))
 424
 425 ;;}}}
 426
 427 ;;;###xwem-autoload
 428 (defun xwem-XTrayInit (xdpy xwin &optional dockid dockgroup dockalign)
 429   "Same as `XTrayInit'.
 430 You should use this function instead of direct calls to `XTrayInit',
 431 because in time you doing it xwem-tray may be uninitialised."
 432   (xwem-tray-startit xdpy)              ; make sure systray initialized
 433
 434   (when dockid
 435     (XChangeProperty xdpy xwin (XInternAtom xdpy "XWEM_DOCK_ID")
 436                      XA-integer X-format-16 X-PropModeReplace dockid))
 437   (when dockgroup
 438     (XChangeProperty xdpy xwin (XInternAtom xdpy "XWEM_DOCK_GROUP")
 439                      XA-string X-format-8 X-PropModeReplace dockgroup))
 440   (when dockalign
 441     (XChangeProperty xdpy xwin (XInternAtom xdpy "XWEM_DOCK_ALIGN")
 442                      XA-integer X-format-16 X-PropModeReplace dockalign))
 443
 444   (XTrayInit xdpy xwin))
 445
 446 ;;;###xwem-autoload
 447 (defun xwem-tray-find-dapp (xwin)
 448   "Finds dock application by X window XWIN."
 449   (car (member* xwin xwem-tray-dapp-list
 450                 :test #'(lambda (xwin dapp)
 451                           (X-Win-equal xwin (xwem-dapp-xwin dapp))))))
 452
 453 (defun xwem-tray-message-defhook (dapp)
 454   "Default function for message from dock apps handling."
 455   (if (featurep 'xwem-special)
 456       (xwem-help-display "tray message"
 457         (insert (xwem-dapp-mess dapp)))
 458     (xwem-message 'error "Message arrived from dock app, but special frames not enabled.")))
 459
 460 ;;; XXX these three functions:
 461 ;;
 462 ;;  - xwem-tray-remove-dapp
 463 ;;  - xwem-tray-hide-dapp
 464 ;;  - xwem-tray-show-dapp
 465 ;;
 466 ;; Has many of common code, get rid of it --lg
 467
 468 (defun xwem-tray-remove-dapp (dapp)
 469   "Remove dock application DAPP from xwem tray dockapps list."
 470   (let ((dgeom (xwem-dapp-geom dapp))
 471         (state (xwem-dapp-state dapp)))
 472     ;; Remove from dapps list
 473     (setq xwem-tray-dapp-list
 474           (delq dapp xwem-tray-dapp-list))
 475     (X-invalidate-cl-struct dapp)
 476
 477     ;; Move other dapps to fill free space
 478     (unless (eq state 'hidden)
 479       (mapc #'(lambda (dapp)
 480                 (ecase xwem-tray-default-align
 481                   (right
 482                    (when (< (X-Geom-x (xwem-dapp-geom dapp))
 483                             (X-Geom-x dgeom))
 484                      (xwem-tray-move-dapp dapp
 485                                           (+ (X-Geom-x (xwem-dapp-geom dapp))
 486                                              (X-Geom-width dgeom)
 487                                              xwem-tray-minib-dock-offset)
 488                                           (X-Geom-y (xwem-dapp-geom dapp)))))
 489
 490                   (left
 491                    (when (> (X-Geom-x (xwem-dapp-geom dapp))
 492                             (X-Geom-x dgeom))
 493                      (xwem-tray-move-dapp dapp
 494                                           (- (X-Geom-x (xwem-dapp-geom dapp))
 495                                              (X-Geom-width dgeom)
 496                                              xwem-tray-minib-dock-offset)
 497                                           (X-Geom-y (xwem-dapp-geom dapp)))))))
 498             xwem-tray-dapp-list))))
 499
 500 (defun xwem-tray-hide-dapp (hide-dapp &optional unmap-p)
 501   "Hide dockapp DAPP temporary.
 502 Non-nil UNMAP-P mean dockapp already unmapped."
 503   (unless (eq (xwem-dapp-state hide-dapp) 'hidden)
 504     (unless unmap-p
 505       (XUnmapWindow (xwem-dpy) (xwem-dapp-xwin hide-dapp)))
 506     (setf (xwem-dapp-state hide-dapp) 'hidden)
 507
 508     (let ((dgeom (xwem-dapp-geom hide-dapp)))
 509       (mapc #'(lambda (dapp)
 510                 (unless (eq dapp hide-dapp)
 511                   (ecase xwem-tray-default-align
 512                     (right
 513                      (when (< (X-Geom-x (xwem-dapp-geom dapp))
 514                               (X-Geom-x dgeom))
 515                        (xwem-tray-move-dapp dapp
 516                                             (+ (X-Geom-x (xwem-dapp-geom dapp))
 517                                                (X-Geom-width dgeom)
 518                                                xwem-tray-minib-dock-offset)
 519                                             (X-Geom-y (xwem-dapp-geom dapp)))))
 520
 521                     (left
 522                      (when (> (X-Geom-x (xwem-dapp-geom dapp))
 523                               (X-Geom-x dgeom))
 524                        (xwem-tray-move-dapp dapp
 525                                             (- (X-Geom-x (xwem-dapp-geom dapp))
 526                                                (X-Geom-width dgeom)
 527                                                xwem-tray-minib-dock-offset)
 528                                             (X-Geom-y (xwem-dapp-geom dapp))))))))
 529             xwem-tray-dapp-list))))
 530
 531 (defun xwem-tray-show-dapp (show-dapp &optional map-p)
 532   "Show dockapp SHOW-DAPP that was hidden temporary.
 533 Non-nil MAP-P mean dock app already mapped."
 534   (unless (eq (xwem-dapp-state show-dapp) 'shown)
 535     (unless map-p
 536       (XMapWindow (xwem-dpy) (xwem-dapp-xwin show-dapp)))
 537     (setf (xwem-dapp-state show-dapp) 'shown)
 538
 539     (let ((dgeom (xwem-dapp-geom show-dapp)))
 540       (mapc #'(lambda (dapp)
 541                 (unless (eq dapp show-dapp)
 542                   (ecase xwem-tray-default-align
 543                     (right
 544                      (when (< (X-Geom-x (xwem-dapp-geom dapp))
 545                               (+ (X-Geom-x dgeom) (X-Geom-width dgeom)))
 546                        (xwem-tray-move-dapp dapp
 547                                             (- (X-Geom-x (xwem-dapp-geom dapp))
 548                                                (X-Geom-width dgeom)
 549                                                xwem-tray-minib-dock-offset)
 550                                             (X-Geom-y (xwem-dapp-geom dapp)))))
 551
 552                     (left
 553                      (when (> (X-Geom-x (xwem-dapp-geom dapp))
 554                               (+ (X-Geom-x dgeom) (X-Geom-width dgeom)))
 555                        (xwem-tray-move-dapp dapp
 556                                             (+ (X-Geom-x (xwem-dapp-geom dapp))
 557                                                (X-Geom-width dgeom)
 558                                                xwem-tray-minib-dock-offset)
 559                                             (X-Geom-y (xwem-dapp-geom dapp))))))))
 560             xwem-tray-dapp-list))))
 561
 562 (defun xwem-tray-get-proper-position (width)
 563   "Get good position in system tray for dapp with WIDTH."
 564   (let ((dapps xwem-tray-dapp-list)
 565         (dtlen xwem-tray-minib-start-offset))
 566     (while dapps
 567       (when (eq (xwem-dapp-state (car dapps)) 'shown)
 568         (incf dtlen (X-Geom-width (xwem-dapp-geom (car dapps))))
 569         (incf dtlen xwem-tray-minib-dock-offset))
 570       (setq dapps (cdr dapps)))
 571
 572     (ecase xwem-tray-default-align
 573       (right
 574        (- (X-Geom-width (xwem-minib-xgeom xwem-minibuffer))
 575           dtlen width))
 576       (left
 577        (+ (X-Geom-width (xwem-minib-cl-xgeom xwem-minibuffer))
 578           dtlen)))))
 579
 580 (define-xwem-deffered xwem-tray-apply-dapp-position (dapp)
 581   "Apply DAPP's position to life."
 582   (when (xwem-dapp-alive-p dapp)
 583     (XMoveWindow (xwem-dpy) (xwem-dapp-xwin dapp)
 584                  (X-Geom-x (xwem-dapp-geom dapp))
 585                  (X-Geom-y (xwem-dapp-geom dapp)))))
 586
 587 (defun xwem-tray-move-dapp (dapp new-x new-y)
 588   "Move DAPP to NEW-X, NEW-Y position.
 589 If NEW-X or NEW-Y is nil - corresponding value is retained."
 590   (when new-x
 591     (setf (X-Geom-x (xwem-dapp-geom dapp)) new-x))
 592   (when new-y
 593     (setf (X-Geom-y (xwem-dapp-geom dapp)) new-y))
 594   (xwem-tray-apply-dapp-position dapp))
 595
 596 (defun xwem-tray-new-dapp (xwin)
 597   "New dock application XWIN wants to be managed."
 598   (let* ((minb-hei (X-Geom-height (xwem-minib-xgeom xwem-minibuffer)))
 599          (wgeom (XGetGeometry (xwem-dpy) xwin))
 600          (w-wid (X-Geom-width wgeom))
 601          (w-hei (X-Geom-height wgeom))
 602          (dapp-geom (make-X-Geom
 603                      :x (xwem-tray-get-proper-position w-wid)
 604                      :y (/ (- minb-hei w-hei) 2)
 605                      :width w-wid :height w-hei))
 606          (dapp (make-xwem-dapp :xwin xwin :geom dapp-geom)))
 607
 608     ;; Set DAPP's window gravity
 609     (XChangeWindowAttributes
 610      (xwem-dpy) xwin (make-X-Attr :win-gravity
 611                                   (if (eq xwem-tray-default-align 'right)
 612                                       X-EastGravity
 613                                     X-WestGravity)))
 614
 615     ;; Dockapp properties
 616     (setf (xwem-dapp-id dapp)
 617           (nth 2 (XGetWindowProperty
 618                   (xwem-dpy) xwin (XInternAtom (xwem-dpy) "XWEM_DOCK_ID"))))
 619     (setf (xwem-dapp-group-name dapp)
 620           (XGetPropertyString (xwem-dpy) xwin
 621                               (XInternAtom (xwem-dpy) "XWEM_DOCK_GROUP")))
 622     (setf (xwem-dapp-align dapp)
 623           (nth 2 (XGetWindowProperty
 624                   (xwem-dpy) xwin (XInternAtom (xwem-dpy) "XWEM_DOCK_ALIGN"))))
 625
 626     (add-to-list 'xwem-tray-dapp-list dapp)
 627
 628     (X-Win-EventHandler-add-new xwin 'xwem-dapp-handle-xevent
 629                                 100 (list X-ClientMessage))
 630
 631     (if xwem-tray-use-groups
 632         (xwem-tray-group-attach-dapp
 633          (xwem-tray-group-find-create (xwem-dapp-group-name dapp))
 634          dapp)
 635       (XReparentWindow (xwem-dpy) xwin (xwem-tray-xwin xwem-tray)
 636                        (X-Geom-x dapp-geom)
 637                        (X-Geom-y dapp-geom)))
 638     (XMapWindow (xwem-dpy) xwin)
 639     (setf (xwem-dapp-state dapp) 'shown)))
 640
 641 (defun xwem-dapp-handle-client-message (xev)
 642   "Handle ClientMessage from dock application."
 643   (xwem-debug 'xwem-tray "DOCK APP: ClientMessage")
 644
 645   (let ((dapp (xwem-tray-find-dapp (X-Event-xclient-window xev)))
 646         (mes-type (X-Atom-id (X-Event-xclient-atom xev))))
 647     (cond ((= mes-type (X-Atom-id (aref (xwem-tray-atoms xwem-tray) 9)))
 648            ;; part of some message arrived
 649            (let* ((len (- (xwem-dapp-mess-waitlen dapp)
 650                           (xwem-dapp-mess-currlen dapp)))
 651                   (ltgo (if (> len 20) 20 len))) ;length to go
 652              (setf (xwem-dapp-mess dapp)
 653                    (concat (xwem-dapp-mess dapp)
 654                            (xwem-list-to-string
 655                             (mapcar 'car (X-Event-xclient-msg xev)) ltgo)))
 656              (setf (xwem-dapp-mess-currlen dapp)
 657                    (+ (xwem-dapp-mess-currlen dapp) ltgo)))
 658
 659            (when (= (xwem-dapp-mess-currlen dapp)
 660                     (xwem-dapp-mess-waitlen dapp))
 661              ;; message accomplished
 662              (let ((dtype (xwem-dapp-mess-type dapp)))
 663                (cond ((= dtype xwem-tc-message)
 664                       ;; TODO: run hook?
 665                       (when xwem-tray-message-hook
 666                         (funcall xwem-tray-message-hook dapp)))
 667
 668                      ((= dtype xwem-tc-run-lisp)
 669                       (xwem-debug 'xwem-tray "DOCK APP: ELISP: '%s'"
 670                                   '(xwem-dapp-mess dapp))
 671                       (with-temp-buffer
 672                         (insert (xwem-dapp-mess dapp))
 673                         (condition-case nil
 674                             (progn
 675                               (xwem-message 'info "evaling: %S"
 676                                             (xwem-dapp-mess dapp))
 677                               (eval-buffer))
 678                           (t nil))))
 679                      ))))
 680
 681           ((= mes-type (X-Atom-id (aref (xwem-tray-atoms xwem-tray) 3)))
 682            ;; opcode arrived
 683            (let ((opc (truncate (car (nth 1 (X-Event-xclient-msg xev))))))
 684              (cond ((= opc xwem-tc-dock-req) nil)
 685                    (t (setf (xwem-dapp-mess dapp) "")
 686                       (setf (xwem-dapp-mess-currlen dapp) 0)
 687                       (setf (xwem-dapp-mess-waitlen dapp)
 688                             (truncate (car (nth 3 (X-Event-xclient-msg xev)))))
 689                       (setf (xwem-dapp-mess-type dapp) opc))
 690                    )))
 691           (t (xwem-message
 692               'warning "Unknown mes-type %d from dock app." mes-type)))
 693     nil))
 694
 695 (defun xwem-dapp-handle-xevent (xdpy xwin xev)
 696   "X Events handler for dockapps."
 697   (xwem-debug 'xwem-tray "DAPP: X Event: %S" '(X-Event-name xev))
 698
 699   (X-Event-CASE xev
 700     (:X-ClientMessage
 701      (xwem-dapp-handle-client-message xev))
 702     ))
 703
 704 (defun xwem-tray-create (dpy)
 705   "Creates new XWEM system tray on DPY.
 706 Window is InputOnly to be transparent."
 707   (let ((win nil))
 708     (setq win (XCreateWindow
 709                dpy nil
 710                0 0 1 1
 711                0 0 X-InputOnly nil
 712                (make-X-Attr :override-redirect t
 713                             :event-mask xwem-tray-evmask)))
 714
 715     (X-Win-EventHandler-add-new win 'xwem-tray-handle-client-message
 716                                 100 (list X-ClientMessage))
 717
 718     ;; Setup various hints
 719     (XSetWMClass dpy win xwem-tray-class)
 720     (XSetWMName dpy win xwem-tray-name)
 721
 722     (setf (xwem-tray-xwin xwem-tray) win)
 723     (setf (xwem-tray-plist xwem-tray) nil)
 724
 725     ;; TODO: install Selections and properties we will need
 726     ))
 727
 728 (defun xwem-tray-init (dpy)
 729   "Initialize xwem tray."
 730   (setq xwem-tray
 731         (make-xwem-tray :atoms (make-vector 40 nil)
 732                         :xwin (xwem-minib-xwin xwem-minibuffer)))
 733
 734   (let ((xwem-atoms (xwem-tray-atoms xwem-tray)))
 735     (aset xwem-atoms 0 (XInternAtom dpy "_NET_WM_WINDOW_TYPE"))
 736     (aset xwem-atoms 1 (XInternAtom dpy "_NET_WM_WINDOW_TYPE_DOCK"))
 737     (aset xwem-atoms 3 (XInternAtom dpy "_NET_SYSTEM_TRAY_OPCODE"))
 738     (aset xwem-atoms 4 (XInternAtom dpy "_XEMBED_INFO"))
 739     (aset xwem-atoms 5 (XInternAtom dpy "_XEMBED"))
 740     (aset xwem-atoms 6 (XInternAtom dpy "MANAGER"))
 741     (aset xwem-atoms 9 (XInternAtom dpy "_NET_SYSTEM_TRAY_MESSAGE_DATA"))
 742     (aset xwem-atoms 10 (XInternAtom dpy "_NET_WM_WINDOW_TYPE_SPLASH"))
 743     (aset xwem-atoms 15 (XInternAtom dpy "_NET_WM_STRUT"))
 744     (aset xwem-atoms 18 (XInternAtom dpy "_NET_WM_ICON"))
 745     (aset xwem-atoms 19 (XInternAtom dpy "_NET_WM_PID"))
 746     (aset xwem-atoms 20 (XInternAtom dpy "_XROOTPMAP_ID"))
 747
 748     (aset xwem-atoms 30 (XInternAtom dpy "XWEM_DOCK_ID"))
 749     (aset xwem-atoms 31 (XInternAtom dpy "XWEM_DOCK_GROUP"))
 750     (aset xwem-atoms 32 (XInternAtom dpy "XWEM_DOCK_ALIGN"))
 751
 752     ;; Use emacs pid as tray identificator
 753     (aset xwem-atoms 2
 754           (XInternAtom dpy (format "_NET_SYSTEM_TRAY_S%i" xwem-tray-id))))
 755
 756   (setenv "SYSTEM_TRAY_ID" (format "%i" xwem-tray-id))
 757
 758   ;; Subscribe on substructure change events for xwem tray window.
 759   (XSelectInput (xwem-dpy) (xwem-tray-xwin xwem-tray)
 760                 (Xmask-or XM-SubstructureNotify XM-StructureNotify
 761                           (X-Attr-event-mask
 762                            (XGetWindowAttributes
 763                             (xwem-dpy) (xwem-tray-xwin xwem-tray)))))
 764   (X-Win-EventHandler-add-new (xwem-tray-xwin xwem-tray)
 765                               'xwem-tray-handle-xevent -1
 766                               (list X-MapNotify X-UnmapNotify
 767                                     X-DestroyNotify X-ConfigureNotify))
 768   (X-Win-EventHandler-add-new (xwem-tray-xwin xwem-tray)
 769                               'xwem-tray-handle-xevent 100
 770                               (list X-ClientMessage))
 771
 772   ;; Configure systray cursor
 773   (setq xwem-tray-cursor
 774         (xwem-make-cursor xwem-tray-cursor-shape
 775                           xwem-tray-cursor-foreground-color
 776                           xwem-tray-cursor-background-color))
 777   (XSetWindowCursor (xwem-dpy) (xwem-tray-xwin xwem-tray)
 778                     xwem-tray-cursor))
 779
 780 (defun xwem-tray-handle-xevent (xdpy xwin xev)
 781   "X Events handler for xwem systray."
 782   (xwem-debug 'xwem-tray "TRAY X Event: %S" '(X-Event-name xev))
 783
 784   (X-Event-CASE xev
 785     (:X-ClientMessage
 786      (let* ((mes-type (X-Atom-id (X-Event-xclient-atom xev)))
 787             (mes-data (X-Event-xclient-msg xev))
 788             (mes-win (X-Win-find-or-make (xwem-dpy) (car (nth 2 mes-data))))
 789             (data-type (truncate (car (nth 1 mes-data)))))
 790        (cond ((= mes-type (X-Atom-id (aref (xwem-tray-atoms xwem-tray) 3)))
 791               (cond ((= data-type xwem-tc-dock-req)
 792                      (xwem-debug 'xwem-tray "Creating new dockapp ..")
 793                      (xwem-tray-new-dapp mes-win))
 794                     (t (xwem-message
 795                         'warning "Unknown data-type %d in clientmessage."
 796                         data-type))))
 797              (t (xwem-message 'warning "Unknown mes-type %d" mes-type)))))
 798
 799     (:X-DestroyNotify
 800      (let ((dapp (xwem-tray-find-dapp (X-Event-xdestroywindow-window xev))))
 801        (when (xwem-dapp-alive-p dapp)
 802          (xwem-message 'note "Removing dockapp ..")
 803          (xwem-tray-remove-dapp dapp))))
 804
 805     (:X-UnmapNotify
 806      (let ((dapp (xwem-tray-find-dapp (X-Event-xunmap-window xev))))
 807        (when (xwem-dapp-alive-p dapp)
 808          (xwem-tray-hide-dapp dapp t))))
 809
 810     (:X-MapNotify
 811      (let ((dapp (xwem-tray-find-dapp (X-Event-xunmap-window xev))))
 812        (when (xwem-dapp-alive-p dapp)
 813          (xwem-tray-show-dapp dapp t))))
 814
 815     (:X-ConfigureNotify
 816      (when (eq (X-Event-xconfigure-window xev)
 817                (xwem-tray-xwin xwem-tray))
 818        (let ((height (X-Event-xconfigure-height xev)))
 819          (when (not (eql height
 820                          (xwem-tray-get-prop xwem-tray 'xwem-saved-height)))
 821            (xwem-tray-put-prop xwem-tray 'xwem-saved-height height)
 822            (mapc #'(lambda (dapp)
 823                      (setf (X-Geom-y (xwem-dapp-geom dapp))
 824                            (/ (- height (X-Geom-height (xwem-dapp-geom dapp))) 2))
 825                      (xwem-tray-apply-dapp-position dapp))
 826                  xwem-tray-dapp-list)))))))
 827
 828 (defun xwem-tray-startit (&optional dpy)
 829   "Start xwew tray on display DPY."
 830   (unless (get 'xwem-tray 'initialized)
 831     (unless dpy (setq dpy (xwem-dpy)))
 832
 833     (xwem-tray-init dpy)
 834     (XSetSelectionOwner dpy (aref (xwem-tray-atoms xwem-tray) 2)
 835                         (xwem-tray-xwin xwem-tray))
 836     (XMapWindow dpy (xwem-tray-xwin xwem-tray))
 837
 838     ;; Add finialization hook
 839     (add-hook 'xwem-exit-hook 'xwem-tray-fini)
 840     (put 'xwem-tray 'initialized t)))
 841
 842 (defun xwem-tray-fini ()
 843   "Finialize xwem-tray."
 844   (mapc #'(lambda (dapp)
 845             (XDestroyWindow (xwem-dpy) (xwem-dapp-xwin dapp)))
 846         xwem-tray-dapp-list)
 847
 848   (setq xwem-tray-dapp-list nil)
 849   (setq xwem-tray-cursor nil)
 850   )
 851
 852 ;;;###autoload
 853 (defun xwem-tray-delimeter (&optional w h bgcol)
 854   "Add delimiter to dockapp.
 855 W and H specifies delimiter width and height.
 856 BGCOL - background color."
 857   (unless w
 858     (setq w xwem-tray-delimiter-width))
 859   (unless h
 860     (setq h (- (X-Geom-height (xwem-minib-cl-xgeom xwem-minibuffer))
 861                (* 2 xwem-tray-delimiter-height-reminder))))
 862
 863   (let* ((bgmode (xwem-tray-background-mode))
 864          (bgcol (or bgcol (xwem-face-foreground 'xwem-tray-delimiter-face
 865                                                 (list 'background bgmode))))
 866          (xwin (XCreateWindow
 867                 (xwem-dpy) nil 0 0 w h
 868                 0 nil nil nil
 869                 (make-X-Attr
 870                  :override-redirect t
 871                  :cursor (xwem-make-cursor X-XC-sb_h_double_arrow)
 872                  :background-pixel
 873                  (XAllocNamedColor (xwem-dpy) (XDefaultColormap (xwem-dpy))
 874                                    bgcol)
 875                  :event-mask (Xmask-or XM-ButtonPress
 876                                        XM-ButtonRelease XM-ButtonMotion)))))
 877     (xwem-XTrayInit (xwem-dpy) xwin)
 878     xwin))
 879
 880 ;;;###xwem-autoload
 881 (defun xwem-tray-background-mode ()
 882   "Return background mode(`dark' or `light') for system tray."
 883   (xwem-get-background-mode
 884    (face-background-instance 'default (xwem-minib-frame xwem-minibuffer))))
 885
 886 ;;; System tray managing model
 887 ;;;###autoload
 888 (defun xwem-manage-systray (cl)
 889   "Manage method for systray dockaps."
 890   (xwem-XTrayInit (xwem-dpy) (xwem-cl-xwin cl)))
 891
 892 \f
 893 (provide 'xwem-tray)
 894
 895 ;;;; On-load actions:
 896
 897 ;; Systray manage type
 898 (define-xwem-manage-model systray
 899   "Managing model for systray utilities."
 900   :manage-method 'xwem-manage-systray)
 901
 902 ;; - Register xwem system tray
 903 (if xwem-started
 904     (xwem-tray-startit)
 905   (add-hook 'xwem-after-init-hook 'xwem-tray-startit))
 906
 907 ;;; xwem-tray.el ends here