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

   1 ;;; xwem-icons.el --- Icons handling routines.
   2
   3 ;; Copyright (C) 2003-2005 by XWEM Org.
   4
   5 ;; Author: Zajcev Evgeny <zevlg@yandex.ru>
   6 ;;         Steve Youngs  <steve@youngs.au.com>
   7 ;; Created: Sat Dec 27 15:38:24 MSK 2003
   8 ;; Keywords: xwem
   9 ;; X-CVS: $Id: xwem-icons.el,v 1.10 2005-04-04 19:54:12 lg Exp $
  10
  11 ;; This file is part of XWEM.
  12
  13 ;; XWEM is free software; you can redistribute it and/or modify it
  14 ;; under the terms of the GNU General Public License as published by
  15 ;; the Free Software Foundation; either version 2, or (at your option)
  16 ;; any later version.
  17
  18 ;; XWEM is distributed in the hope that it will be useful, but WITHOUT
  19 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
  20 ;; or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public
  21 ;; License for more details.
  22
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  25 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  26 ;; 02111-1307, USA.
  27
  28 ;;; Synched up with: Not in FSF
  29
  30 ;;; Commentary:
  31
  32 ;; Icons support.
  33
  34 ;; Supports client properties:
  35
  36 ;;    `xwem-tab-face' - Face to draw tabber item (overrides `xwem-tabber-face'
  37 ;;    `xwem-icon-name' - Name of icon to use (overrides `xwem-icons-alist')
  38
  39 ;;; Code:
  40 \f
  41 (require 'xlib-xpm)
  42
  43 (require 'xwem-load)
  44
  45 ;;;###autoload
  46 (defcustom xwem-icons-dir (locate-data-directory "xwem")
  47   "Directory where icons for use by XWEM lies."
  48   :type 'directory
  49   :group 'xwem)
  50
  51 ;;;###autoload
  52 (defcustom xwem-icons-list
  53   '(("mini-display.xpm"
  54      (class-inst "^Terminal$") (class-name "^Terminal$"))
  55     ("mini-clock.xpm" (application "xclock"))
  56     ("mini-measure.xpm" (application "xload"))
  57     ("mini-calc.xpm"
  58      (or (buffer-major-mode calc-mode)
  59          (class-name "[cC]alc")))
  60
  61     ("mini-xkeycaps.xpm" (application "xkeycaps"))
  62     ("mini-xv.xpm" (application "xv"))
  63     ("mini-imagemagic.xpm" (application "display"))
  64
  65     ("mini-xdvi.xpm" (class-inst "^xdvi$") (class-name "^XDvi$"))
  66     ("mini-acroread.xpm" (class-name "^AcroRead\\|Xpdf$"))
  67     ("mini-info.xpm" (class-name "Xman"))
  68     ("mini-gimp.xpm" (class-name "^Gimp$"))
  69     ("mini-djvu.xpm" (class-inst "^djview$") (class-name "^Djview$"))
  70
  71     ;; EMACS
  72     ("mini-xemacstex.xpm"
  73      (or (buffer-major-mode plain-tex-mode)
  74          (buffer-major-mode texinfo-mode)
  75          (and (application "xemacs")
  76               (name  "\\.tex"))))
  77     ("mini-xemacsC.xpm"
  78      (or (buffer-major-mode c-mode)
  79          (and (application "xemacs")
  80               (name  "\\.[ch]"))))
  81     ("mini-xemacsgnus.xpm"
  82      (or (buffer-major-mode gnus-group-mode)
  83          (buffer-major-mode gnus-article-mode)
  84          (buffer-major-mode gnus-summary-mode)
  85          (and (application "xemacs")
  86               (name "\\(Group\\|Summary\\|Article\\)"))))
  87     ("mini-xemacspy.xpm"
  88      (or (buffer-major-mode python-mode)
  89          (and (application "xemacs")
  90               (name "\\.py"))))
  91
  92     ;; MISC
  93     ("mini-links.xpm" (application "links"))
  94     ("mini-ddd.xpm" (application "ddd"))
  95     ("mini-vnc.xpm" (application "vncviewer"))
  96     ("mini-firefox.xpm" (application "firefox"))
  97     ("mini-mozilla.xpm" (application "mozilla"))
  98     ("mini-opera.xpm" (application "opera"))
  99     ("mini-gv.xpm" (or (application "gv") (application "ghostview")))
 100     ("mini-xfig.xpm" (application "xfig"))
 101     ("mini-ethereal.xpm" (application "ethereal"))
 102     ("mini-font.xpm" (or (application "xfd") (application "xfontsel")))
 103
 104     ("mini-sh1.xpm"
 105      (or (buffer-major-mode eshell-mode)
 106          (buffer-major-mode shell-mode)
 107          (buffer-major-mode term-mode)
 108          (buffer-major-mode terminal-mode)
 109          (and (class-inst "x?console")
 110               (class-name "[Xx]?[Cc]onsole"))))
 111     ("mini-colors.xpm"
 112      (or (buffer-name "\\*Colors\\*")
 113          (and (class-inst "x?colors?")
 114               (class-name "[Xx]?colors?"))
 115          (name "^xcmap$")))
 116     ("mini-xchat.xpm" (application "xchat"))
 117     ("mini-diag.xpm" (application "gnumeric"))
 118
 119     ("mini-xemacs.xpm" (application "xemacs"))
 120
 121     ("mini-zoom.xpm" (or (class-inst "^Xmag$")
 122                          (name "^Lupe$")))
 123     ("mini-graph.xpm" (application "gnuplot"))
 124
 125     ;; ICQ
 126     ("mini-icq.xpm"
 127      (or (buffer-major-mode eicq-buddy-mode)
 128          (buffer-major-mode eicq-log-mode)
 129          (and (application "xemacs")
 130               (name "\\*Status\\*"))
 131          (application "licq")
 132          (name "[LlMmVv][Ii][Cc][Qq]")))
 133
 134     ;; xterm
 135     ("mini-term.xpm" (and (class-name "^.[tT]erm$")
 136                           (or (class-inst "^.term$")
 137                               (class-inst "^rxvt$"))))
 138
 139     ("mini-x2.xpm" (eval t)))           ; any other
 140   "Icons matching list in `xwem-manage-list' format."
 141   :type '(repeat
 142           (cons :tag "Icon specifier"
 143                 (string :tag "Icon name")
 144                 (repeat
 145                  (cons
 146                   (choice (const :tag "Application" application)
 147                           (const :tag "Class name" class-name)
 148                           (const :tag "Class instance" class-inst)
 149                           (const :tag "Name" name)
 150                           (const :tag "Buffer Major Mode" buffer-major-mode)
 151                           (const :tag "Buffer Name" buffer-name)
 152                           (const :tag "Buffer Name" buffer-name)
 153                           (const :tag "Sexp for evaluation" eval)
 154                           (const :tag "Function" function)
 155                           (const :tag "Or operation" or)
 156                           (const :tag "And operation" and))
 157                   (repeat sexp)))))
 158   :group 'xwem)
 159
 160 ;;; Internal variables
 161
 162 (defvar xwem-icons-specifiers nil
 163   "List of icons specifiers.")
 164
 165 (defvar xwem-icons-loaded-list nil
 166   "List of already loaded icons.")
 167
 168 \f
 169 ;;; Faces
 170 (define-xwem-face xwem-icon-red-face
 171   `(((shade) (:foreground "red3"))
 172     (t (:foreground "red")))
 173   "Red face to be used by icons.")
 174
 175 (define-xwem-face xwem-icon-green-face
 176   `(((shade) (:foreground "green3"))
 177     (t (:foreground "green")))
 178   "Green face to be used by icons.")
 179
 180 (define-xwem-face xwem-icon-blue-face
 181   `(((shade) (:foreground "blue3"))
 182     (t (:foreground "blue")))
 183   "Blue face to be used by icons.")
 184
 185 (define-xwem-face xwem-icon-cyan-face
 186   `(((shade) (:foreground "cyan3"))
 187     (t (:foreground "cyan")))
 188   "Cyan face to be used by icons.")
 189
 190 (define-xwem-face xwem-icon-magenta-face
 191   `(((shade) (:foreground "magenta3"))
 192     (t (:foreground "magenta")))
 193   "Magenta face to be used by icons.")
 194
 195 (define-xwem-face xwem-icon-yellow-face
 196   `(((shade) (:foreground "yellow3"))
 197     (t (:foreground "yellow")))
 198   "Yellow face to be used by icons.")
 199
 200 (define-xwem-face xwem-icon-brown-face
 201   `(((shade) (:foreground "brown3"))
 202     (t (:foreground "brown")))
 203   "Brown face to be used by icons.")
 204
 205 \f
 206 (define-xwem-client-property xwem-icon-name nil
 207   "Icon to use for client."
 208   :type 'string)
 209
 210 ;;; Functions
 211 (defun xwem-icons-cl-icon-name (cl)
 212   "Return icon name for CL."
 213   (or (xwem-client-property cl 'xwem-icon-name)
 214       (car (xwem-manda-find-match-1 cl xwem-icons-list 'cdr))))
 215
 216 (defun xwem-icons-cl-buildin-icon (cl &optional tag-set)
 217   "Return build in icon for CL."
 218   (let ((iname (xwem-icons-cl-icon-name cl))
 219         ximg-spec fname ximg ximg-mask-pixmap)
 220     (when iname
 221       (setq ximg-spec (plist-get xwem-icons-specifiers iname))
 222
 223       (unless ximg-spec
 224         (setq ximg-spec (make-specifier 'generic))
 225         (setq xwem-icons-specifiers
 226               (plist-put xwem-icons-specifiers iname ximg-spec)))
 227
 228       (setq ximg (plist-get xwem-icons-loaded-list
 229                    (cdar (cdar (specifier-spec-list ximg-spec nil tag-set t)))))
 230       (unless ximg
 231         ;; No image in TAG-SET environ
 232         (setq fname (expand-file-name iname xwem-icons-dir))
 233         (setq ximg (X:xpm-pixmap-from-file
 234                     (xwem-dpy) (XDefaultRootWindow (xwem-dpy))
 235                     fname nil tag-set))
 236         (setq ximg-mask-pixmap
 237               (X:xpm-pixmap-from-file
 238                (xwem-dpy) (XDefaultRootWindow (xwem-dpy)) fname t tag-set))
 239
 240         (setq ximg (cons ximg ximg-mask-pixmap))
 241         (let ((sym (gensym "*xwem-icon-")))
 242           (add-spec-list-to-specifier ximg-spec
 243              `((global ,(cons tag-set sym))) 'remove-tag-set-prepend)
 244
 245           (setq xwem-icons-loaded-list
 246                 (plist-put xwem-icons-loaded-list sym ximg))))
 247       ximg)))
 248
 249 (defun xwem-icons-cl-kwm-win-icon (cl &optional tag-set)
 250   "Return CL's KWM_WIN_ICON if specified."
 251   (let ((kwi (xwem-cl-get-sys-prop cl 'kwm-win-icon)))
 252     (cond ((eq kwi 'no-kwm-win-icon) nil)
 253           ((null kwi)
 254            ;; KWM_WIN_ICON not yet checked
 255            (let* ((kw (XGetWindowProperty
 256                        (xwem-dpy) (xwem-cl-xwin cl)
 257                        (XInternAtom (xwem-dpy) "KWM_WIN_ICON")))
 258                   (pp (and (nth 2 kw) (make-X-Pixmap :dpy (xwem-dpy)
 259                                                      :id (nth 2 kw))))
 260                   (pm (and (nth 3 kw) (make-X-Pixmap :dpy (xwem-dpy)
 261                                                      :id (nth 3 kw))))
 262                   (gg nil))
 263              (if (not (and pp pm))
 264                  (xwem-cl-put-sys-prop cl 'kwm-win-icon 'no-kwm-win-icon)
 265
 266                (setq gg (XGetGeometry (xwem-dpy) pp))
 267                (setf (X-Pixmap-width pp) (X-Geom-width gg))
 268                (setf (X-Pixmap-height pp) (X-Geom-height gg))
 269
 270                (setq gg (XGetGeometry (xwem-dpy) pm))
 271                (setf (X-Pixmap-width pm) (X-Geom-width gg))
 272                (setf (X-Pixmap-height pm) (X-Geom-height gg))
 273
 274                (xwem-cl-put-sys-prop cl 'kwm-win-icon (setq gg (cons pp pm))))
 275              gg))
 276           (t kwi))))
 277
 278 ;;;###xwem-autoload
 279 (defun xwem-icons-cl-icon (cl &optional tag-set)
 280   "Get X-Image of CL's icon.
 281 Return cons cell where car is X-Pixmap of icon and cdr is X-Pixmap
 282 where mask for icon is stored.
 283
 284 TAG-SET specifies environment list for which icon is created."
 285   (or (xwem-icons-cl-kwm-win-icon cl tag-set)
 286       (xwem-icons-cl-buildin-icon cl tag-set)))
 287
 288 \f
 289 (provide 'xwem-icons)
 290
 291 ;;; xwem-icons.el ends here