Updates/improvements -- riece-xfaceb
[riece] / lisp / riece-xfaceb.el
1 ;;; riece-xfaceb.el --- display X-Face/Colour Face in IRC buffers -*- lexical-binding: t -*-
2 ;; Copyright (C) 2005 Daiki Ueno
3
4 ;; Author: Steve Youngs <steve@sxemacs.org>
5 ;; Created: 2005-09-03
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., 51 Franklin Street, Fifth Floor,
23 ;; Boston, MA 02110-1301, USA.
24
25 ;;; Commentary:
26
27 ;; NOTE: This is an add-on module for Riece.  It is adapted from
28 ;; `riece-xface' but gets the image data from BBDB instead of LSDB.
29
30 ;; This add-on displays either X-Face or colour Face images in the
31 ;; Riece "Users" buffers.  The image data comes from entries in a BBDB
32 ;; db.  Consequently it does require a little setting up in BBDB...
33
34 ;; BBDB Setup:
35
36 ;; You need a new field called "ircnick" for each IRC contact that is
37 ;; in your BBDB.  Its value is the IRC nickname of the contact (what
38 ;; is listed in the Riece "Users" buffer).
39
40 ;;   M-x bbdb-insert-new-field RET ircnick RET
41 ;;   answer `yes' to the prompt about the field not being defined
42 ;;   then give it a value which will be that record's IRC nickname
43
44 ;; Then you'll need to collect X-Face: and Face: headers from your mail.
45 ;; To do that see: <http://www.emacswiki.org/cgi-bin/wiki/BbdbFaces>
46
47 ;;; Code:
48
49 (require 'riece-identity)
50 (require 'riece-globals)
51 (require 'riece-display)
52
53 (autoload 'bbdb-records "bbdb")
54 (autoload 'bbdb-record-getprop "bbdb")
55 (autoload 'bbdb-search "bbdb-com" nil nil 'macro)
56
57 (defconst riece-xfaceb-description
58   "Display X-Face & Colour Face images in IRC buffers \(BBDB\).")
59
60 (defcustom riece-xfaceb-channels nil
61   "*If non-nil, faces are only added in channels in this list.
62
63 You really want to set this to a list of small-ish channels that
64 you're in because having it set globally can slow Emacs to a crawl,
65 rendering it unusable if you're in some busy channels.
66
67 `riece-xfaceb-addremove-channel' can be used to interactively add or
68 remove the current channel to/from this list."
69   :type '(repeat string)
70   :group 'riece-looks)
71
72 (defcustom riece-xfaceb-prefer-cface-to-xface (featurep 'png)
73   "*When non-nil, display colour face images instead of X-Face."
74   :type 'boolean
75   :group 'riece-looks)
76
77 (defun riece-xfaceb-addremove-channel (&optional remove)
78   "*Add the current channel to `riece-xfaceb-channels'.
79
80 With optional argument, REMOVE, remove the current channel from the
81 list."
82   (interactive "P")
83   (if (or current-prefix-arg remove)
84       ;; Remove channel.
85       (progn
86         (setq riece-xfaceb-channels
87               (remove (riece-identity-prefix riece-current-channel)
88                       riece-xfaceb-channels))
89         (message "Channel: %s removed from riece-xfaceb channel list."
90                  (riece-identity-prefix riece-current-channel)))
91     ;; Add channel.
92     (add-to-list 'riece-xfaceb-channels
93                  (riece-identity-prefix riece-current-channel))
94     (message "Channel: %s added to riece-xfaceb channel list."
95              (riece-identity-prefix riece-current-channel)))
96   (riece-emit-signal 'user-list-changed riece-current-channel))
97
98 (defun riece-xfaceb-face-to-png (face)
99   "Base64 decode a Face header into a PNG.
100 Returns a string."
101   (with-temp-buffer
102     (insert face)
103     (base64-decode-region (point-min) (point-max))
104     (buffer-string)))
105
106 (defun riece-xfaceb-add-glyph (type extent data)
107   "Adds a cface or xface glyph to an extent.
108
109 TYPE is a symbol, either `cface', or `xface'.
110 EXTENT is the extent to add the glyph to.
111 DATA is the image data from BBDB."
112   (cond
113    ((eq type 'cface)
114     (let ((glyph (riece-xfaceb-face-to-png data)))
115       (set-extent-begin-glyph
116        extent
117        (make-glyph `([png :data ,glyph])))))
118    ((eq type 'xface)
119     (let ((glyph (concat "X-Face: " data)))
120       (set-extent-begin-glyph
121        extent
122        (make-glyph `([xface :data ,glyph
123                             :foreground "black"
124                             :background "white"])))))
125    (t nil)))
126
127 (defun riece-xfaceb-update-user-list-buffer ()
128   "Add X-Face or Colour Face images to channel users' buffer."
129   (when (and (get 'riece-xfaceb 'riece-addon-enabled)
130              (or (null riece-xfaceb-channels)
131                  (member (riece-identity-prefix riece-current-channel)
132                          riece-xfaceb-channels)))
133     (let ((users (ignore-errors 
134                    (riece-with-server-buffer
135                        (riece-identity-server riece-current-channel)
136                      (riece-channel-get-users (riece-identity-prefix
137                                                riece-current-channel))))))
138       (while users
139         (let* ((name (regexp-quote (caar users)))
140                (str (cons 'ircnick name))
141                (records (bbdb-search (bbdb-records) nil nil nil str nil))
142                cface xface)
143           (mapcar
144            #'(lambda (record)
145                (setq xface (bbdb-record-getprop record 'face))
146                (setq cface (bbdb-record-getprop record 'cface)))
147            records)
148           (when (or cface xface)
149             (with-current-buffer riece-user-list-buffer
150               (goto-char (point-min))
151               (re-search-forward (regexp-quote name) nil t)
152               (beginning-of-line)
153               (let ((ext (extent-at (point))))
154                 (cond
155                  ((and cface
156                        (or riece-xfaceb-prefer-cface-to-xface
157                            (not xface)))
158                   (riece-xfaceb-add-glyph 'cface ext cface))
159                  (xface (riece-xfaceb-add-glyph 'xface ext xface))
160                  (t nil))))))
161         (setq users (cdr users))))))
162
163 (defun riece-xfaceb-requires ()
164   )
165
166 (defun riece-xfaceb-user-list-mode-hook ()
167   (add-hook 'riece-update-buffer-functions
168             'riece-xfaceb-update-user-list-buffer t t))
169
170 (defun riece-xfaceb-insinuate ()
171   (if riece-user-list-buffer
172       (with-current-buffer riece-user-list-buffer
173         (riece-xfaceb-user-list-mode-hook)))
174   (add-hook 'riece-user-list-mode-hook
175             'riece-xfaceb-user-list-mode-hook))
176
177 (defun riece-xfaceb-uninstall ()
178   (if riece-user-list-buffer
179       (with-current-buffer riece-user-list-buffer
180         (remove-hook 'riece-update-buffer-functions
181                      'riece-xfaceb-update-user-list-buffer t)))
182   (remove-hook 'riece-user-list-mode-hook
183                'riece-xfaceb-user-list-mode-hook))
184
185 (defun riece-xfaceb-enable ()
186   (add-to-list 'riece-saved-forms 'riece-xfaceb-channels)
187   (define-key riece-command-mode-map "\C-c\C-cx"
188     #'riece-xfaceb-addremove-channel)
189   (if riece-current-channel
190       (riece-emit-signal 'user-list-changed riece-current-channel)))
191
192 (defun riece-xfaceb-disable ()
193   (setq riece-saved-forms
194         (remove 'riece-xfaceb-channels riece-saved-forms))
195   (define-key riece-command-mode-map "\C-c\C-cx" nil)
196   (if riece-current-channel
197       (riece-emit-signal 'user-list-changed riece-current-channel)))
198
199 (provide 'riece-xfaceb)
200
201 ;;; riece-xfaceb.el ends here
202