cgit.sxemacs.org Git - riece/blob - lisp/riece-icon.el

   1 ;;; riece-icon.el --- display icons in IRC buffers
   2 ;; Copyright (C) 1998-2003 Daiki Ueno
   3
   4 ;; Author: Daiki Ueno <ueno@unixuser.org>
   5 ;; Created: 1998-09-28
   6 ;; Keywords: IRC, riece
   7
   8 ;; This file is part of Riece.
   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 2, or (at your option)
  13 ;; 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 GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Commentary:
  26
  27 ;; NOTE: This is an add-on module for Riece.
  28
  29 ;;; Code:
  30
  31 (require 'riece-globals)
  32 (require 'riece-signal)
  33
  34 (defvar riece-channel-list-icons
  35   '((" " . "/* XPM */
  36 static char * blank_xpm[] = {
  37 \"12 12 1 1\",
  38 \"      c None\",
  39 \"            \",
  40 \"            \",
  41 \"            \",
  42 \"            \",
  43 \"            \",
  44 \"            \",
  45 \"            \",
  46 \"            \",
  47 \"            \",
  48 \"            \",
  49 \"            \",
  50 \"            \"};")
  51     ("!" . "/* XPM */
  52 static char * balloon_xpm[] = {
  53 \"12 12 3 1\",
  54 \"       c None\",
  55 \"+      c #FFDD99\",
  56 \"@      c #000000\",
  57 \"            \",
  58 \"    ++++    \",
  59 \"  ++++++++  \",
  60 \" ++@@@@@@++ \",
  61 \" ++++++++++ \",
  62 \" ++@@@@@@++ \",
  63 \" ++++++++++ \",
  64 \" ++@@@@@@++ \",
  65 \"  ++++++++  \",
  66 \"   ++++++   \",
  67 \"   +++      \",
  68 \"   +        \"};")
  69     ("+" . "/* XPM */
  70 static char * check_xpm[] = {
  71 \"12 12 3 1\",
  72 \"      c None\",
  73 \".     c #9696FF\",
  74 \"+     c #5959FF\",
  75 \"            \",
  76 \"            \",
  77 \" ..      .. \",
  78 \".++.    .++.\",
  79 \" .++.  .++. \",
  80 \"  .++..++.  \",
  81 \"   .++++.   \",
  82 \"    .++.    \",
  83 \"     ..     \",
  84 \"            \",
  85 \"            \",
  86 \"            \"};")
  87     ("*" . "/* XPM */
  88 static char * active_xpm[] = {
  89 \"12 12 3 1\",
  90 \"      c None\",
  91 \".     c #96FF96\",
  92 \"+     c #59FF59\",
  93 \"            \",
  94 \"     ..     \",
  95 \"     .+.    \",
  96 \" .....++.   \",
  97 \" .+++++++.  \",
  98 \" .++++++++. \",
  99 \" .+++++++.  \",
 100 \" .....++.   \",
 101 \"     .+.    \",
 102 \"     ..     \",
 103 \"            \",
 104 \"            \"};")))
 105
 106 (defvar riece-user-list-icons
 107   '((" " . "/* XPM */
 108 static char * blank_xpm[] = {
 109 \"12 12 1 1\",
 110 \"      c None\",
 111 \"            \",
 112 \"            \",
 113 \"            \",
 114 \"            \",
 115 \"            \",
 116 \"            \",
 117 \"            \",
 118 \"            \",
 119 \"            \",
 120 \"            \",
 121 \"            \",
 122 \"            \"};")
 123     ("@" . "/* XPM */
 124 static char * spiral_xpm[] = {
 125 \"12 12 3 1\",
 126 \"      c None\",
 127 \".     c #FF5959\",
 128 \"+     c #FF9696\",
 129 \"            \",
 130 \"            \",
 131 \"    +++++   \",
 132 \"   ++...++  \",
 133 \"  ++.+++.++ \",
 134 \"  +.++.++.+ \",
 135 \"  +.+.+.+.+ \",
 136 \"  +.+.+++.+ \",
 137 \"  +.++...++ \",
 138 \"  ++.+++++.+\",
 139 \"   ++.....+ \",
 140 \"    ++++++  \"};")
 141     ("+" . "/* XPM */
 142 static char * cross_xpm[] = {
 143 \"12 12 3 1\",
 144 \"      c None\",
 145 \".     c #7F7F7F\",
 146 \"+     c #B2B2B2\",
 147 \"     ++     \",
 148 \"    +..+    \",
 149 \"    +..+    \",
 150 \"  +++..+++  \",
 151 \" +........+ \",
 152 \" +........+ \",
 153 \"  +++..+++  \",
 154 \"    +..+    \",
 155 \"    +..+    \",
 156 \"    +..+    \",
 157 \"    +..+    \",
 158 \"     ++     \"};")))
 159
 160 (defvar riece-pointer-icon
 161   "/* XPM */
 162 static char * a_xpm[] = {
 163 \"14 14 5 1\",
 164 \"      c None\",
 165 \".     c #FF9646\",
 166 \"+     c #FF5909\",
 167 \"@     c #FF7020\",
 168 \"*     c #FFA500\",
 169 \"              \",
 170 \"  @@@@@@@@@@@ \",
 171 \" @*.++++++.**@\",
 172 \" @*.++...++.*@\",
 173 \" @*.++.*.++.*@\",
 174 \" @*.++...+.**@\",
 175 \" @*.+++.+.***@\",
 176 \" @*.++.*.+.**@\",
 177 \" @*.++.*.++.*@\",
 178 \" @*.++.*.++.*@\",
 179 \" @*.++.*.++.*@\",
 180 \" @**..***..**@\",
 181 \"  @@@@@@@@@@@ \",
 182 \"              \"};")
 183
 184 (defconst riece-icon-description
 185   "Display icons in IRC buffers.")
 186
 187 (defun riece-icon-available-p ()
 188   (if (featurep 'xemacs)
 189       (featurep 'xpm)
 190     (if (fboundp 'image-type-available-p)
 191         (image-type-available-p 'xpm))))
 192
 193 (eval-and-compile
 194   (if (featurep 'xemacs)
 195       (defun riece-icon-make-image (data string)
 196         (make-glyph (list (vector 'xpm :data data)
 197                           (vector 'string :data string))))
 198     (defun riece-icon-make-image (data string)
 199       (create-image data 'xpm t :ascent 'center))))
 200
 201 (defun riece-icon-make-images (alist)
 202   (let ((pointer (setq alist (copy-alist alist))))
 203     (while pointer
 204       (setcdr (car pointer)
 205               (riece-icon-make-image (cdr (car pointer)) (car (car pointer))))
 206       (setq pointer (cdr pointer)))
 207     alist))
 208
 209 (eval-and-compile
 210   (if (featurep 'xemacs)
 211       (defun riece-icon-add-image-region (image start end)
 212         (map-extents
 213          (lambda (extent ignore)
 214            (if (or (extent-property extent 'riece-icon-user-list-extent)
 215                    (extent-property extent 'riece-icon-user-list-annotation))
 216                (delete-extent extent)))
 217          (current-buffer) start end)
 218         (let ((extent (make-extent start end))
 219               (annotation (make-annotation image end 'text)))
 220           (set-extent-property extent 'end-open t)
 221           (set-extent-property extent 'start-open t)
 222           (set-extent-property extent 'invisible t)
 223           (set-extent-property extent 'intangible t)
 224           (set-extent-property annotation
 225                                'riece-icon-user-list-extent extent)
 226           (set-extent-property extent
 227                                'riece-icon-user-list-annotation annotation)))
 228     (defun riece-icon-add-image-region (image start end)
 229       (let ((inhibit-read-only t)
 230             buffer-read-only)
 231         (add-text-properties start end
 232                              (list 'display
 233                                    image
 234                                    'rear-nonsticky (list 'display)))))))
 235
 236 (defun riece-icon-update-user-list-buffer ()
 237   (if (get 'riece-icon 'riece-addon-enabled)
 238       (let ((images (riece-icon-make-images riece-user-list-icons)))
 239         (save-excursion
 240           (goto-char (point-min))
 241           (while (re-search-forward "^[ @+]" nil t)
 242             (riece-icon-add-image-region
 243              (cdr (assoc (match-string 0) images))
 244              (1- (point)) (point)))))))
 245
 246 (defun riece-icon-update-channel-list-buffer ()
 247   (if (get 'riece-icon 'riece-addon-enabled)
 248       (let ((images (riece-icon-make-images riece-channel-list-icons)))
 249         (save-excursion
 250           (goto-char (point-min))
 251           (while (re-search-forward "^ ?[0-9]+:\\([ !+*]\\)" nil t)
 252             (riece-icon-add-image-region
 253              (cdr (assoc (match-string 1) images))
 254              (match-beginning 1) (match-end 1)))))))
 255
 256 (eval-and-compile
 257   (if (featurep 'xemacs)
 258       (progn
 259         (defvar riece-icon-xemacs-modeline-left-extent
 260           (copy-extent modeline-buffer-id-left-extent))
 261
 262         (defvar riece-icon-xemacs-modeline-right-extent
 263           (copy-extent modeline-buffer-id-right-extent))
 264
 265         (defun riece-icon-modeline-buffer-identification (line)
 266           "Decorate 1st element of `mode-line-buffer-identification' LINE.
 267 Modify whole identification by side effect."
 268           (let ((id (car line)) chopped)
 269             (if (and (stringp id) (string-match "^Riece:" id))
 270                 (progn
 271                   (setq chopped (substring id 0 (match-end 0))
 272                         id (substring id (match-end 0)))
 273                   (nconc
 274                    (list
 275                     (let ((glyph
 276                            (make-glyph
 277                             (nconc
 278                              (if (featurep 'xpm)
 279                                  (list (vector 'xpm :data
 280                                                riece-pointer-icon)))
 281                              (list (vector 'string :data chopped))))))
 282                       (set-glyph-face glyph 'modeline-buffer-id)
 283                       (cons riece-icon-xemacs-modeline-left-extent glyph))
 284                     (cons riece-icon-xemacs-modeline-right-extent id))
 285                    (cdr line)))
 286               line))))
 287     (condition-case nil
 288         (progn
 289           (require 'image)
 290           (defun riece-icon-modeline-buffer-identification (line)
 291             "Decorate 1st element of `mode-line-buffer-identification' LINE.
 292 Modify whole identification by side effect."
 293             (let ((id (copy-sequence (car line)))
 294                   (image
 295                    (if (image-type-available-p 'xpm)
 296                        (create-image riece-pointer-icon 'xpm t
 297                                      :ascent 'center))))
 298               (when (and image
 299                          (stringp id) (string-match "^Riece:" id))
 300                 (add-text-properties 0 (length id)
 301                                      (list 'display image
 302                                            'rear-nonsticky (list 'display))
 303                                      id)
 304                 (setcar line id))
 305               line)))
 306       (error
 307        (defalias 'riece-icon-modeline-buffer-identification 'identity)))))
 308
 309 (defun riece-icon-user-list-mode-hook ()
 310   (if (riece-icon-available-p)
 311       (add-hook 'riece-update-buffer-functions
 312                 'riece-icon-update-user-list-buffer t t)))
 313
 314 (defun riece-icon-channel-list-mode-hook ()
 315   (if (riece-icon-available-p)
 316       (add-hook 'riece-update-buffer-functions
 317                 'riece-icon-update-channel-list-buffer t t)))
 318
 319 (defun riece-icon-insinuate ()
 320   (save-excursion
 321     (when riece-user-list-buffer
 322       (set-buffer riece-user-list-buffer)
 323       (riece-icon-user-list-mode-hook))
 324     (when riece-channel-list-buffer
 325       (set-buffer riece-channel-list-buffer)
 326       (riece-icon-channel-list-mode-hook)))
 327   (add-hook 'riece-user-list-mode-hook
 328             'riece-icon-user-list-mode-hook)
 329   (add-hook 'riece-channel-list-mode-hook
 330             'riece-icon-channel-list-mode-hook))
 331
 332 (defun riece-icon-uninstall ()
 333   (save-excursion
 334     (when riece-user-list-buffer
 335       (set-buffer riece-user-list-buffer)
 336       (remove-hook 'riece-update-buffer-functions
 337                    'riece-icon-update-user-list-buffer t))
 338     (when riece-channel-list-buffer
 339       (set-buffer riece-channel-list-buffer)
 340       (remove-hook 'riece-update-buffer-functions
 341                    'riece-icon-update-channel-list-buffer t)))
 342   (remove-hook 'riece-user-list-mode-hook
 343                'riece-icon-user-list-mode-hook)
 344   (remove-hook 'riece-channel-list-mode-hook
 345                'riece-icon-channel-list-mode-hook))
 346
 347 (defvar riece-icon-original-mode-line-buffer-identification nil)
 348
 349 (defun riece-icon-update-mode-line-buffer-identification ()
 350   (let ((buffers riece-buffer-list))
 351     (save-excursion
 352       (while buffers
 353         (set-buffer (car buffers))
 354         (if (local-variable-p 'riece-mode-line-buffer-identification
 355                               (car buffers))
 356             (setq mode-line-buffer-identification
 357                   (riece-mode-line-buffer-identification
 358                    riece-mode-line-buffer-identification)))
 359         (setq buffers (cdr buffers))))))
 360
 361 (defun riece-icon-enable ()
 362   (setq riece-icon-original-mode-line-buffer-identification
 363         (symbol-function 'riece-mode-line-buffer-identification))
 364   (defalias 'riece-mode-line-buffer-identification
 365     'riece-icon-modeline-buffer-identification)
 366   (riece-icon-update-mode-line-buffer-identification)
 367   (if riece-current-channel
 368       (riece-emit-signal 'user-list-changed riece-current-channel))
 369   (riece-emit-signal 'channel-list-changed))
 370
 371 (defun riece-icon-disable ()
 372   (fset 'riece-mode-line-buffer-identification
 373         riece-icon-original-mode-line-buffer-identification)
 374   (riece-icon-update-mode-line-buffer-identification)
 375   (if riece-current-channel
 376       (riece-emit-signal 'user-list-changed riece-current-channel))
 377   (riece-emit-signal 'channel-list-changed))
 378
 379 (provide 'riece-icon)
 380
 381 ;;; riece-icon.el ends here