cgit.sxemacs.org Git - riece/blob - 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
  56 ;; `bbdb-search' is defined as a macro in bbdb-com.
  57 (eval-when-compile
  58   (condition-case nil
  59       (require 'bbdb-com)
  60     (error)))
  61
  62 (defconst riece-xfaceb-description
  63   "Display X-Face & Colour Face images in IRC buffers \(BBDB\).")
  64
  65 (defcustom riece-xfaceb-channels nil
  66   "*If non-nil, faces are only added in channels in this list.
  67
  68 You really want to set this to a list of small-ish channels that
  69 you're in because having it set globally can slow Emacs to a crawl,
  70 rendering it unusable if you're in some busy channels.
  71
  72 `riece-xfaceb-addremove-channel' can be used to interactively add or
  73 remove the current channel to/from this list."
  74   :type '(repeat string)
  75   :group 'riece-looks)
  76
  77 (defcustom riece-xfaceb-prefer-cface-to-xface (featurep 'png)
  78   "*When non-nil, display colour face images instead of X-Face."
  79   :type 'boolean
  80   :group 'riece-looks)
  81
  82 (defun riece-xfaceb-addremove-channel (&optional remove)
  83   "*Add the current channel to `riece-xfaceb-channels'.
  84
  85 With optional argument, REMOVE, remove the current channel from the
  86 list."
  87   (interactive "P")
  88   (if (or current-prefix-arg remove)
  89       ;; Remove channel.
  90       (progn
  91         (setq riece-xfaceb-channels
  92               (remove (riece-identity-prefix riece-current-channel)
  93                       riece-xfaceb-channels))
  94         (message "Channel: %s removed from riece-xfaceb channel list."
  95                  (riece-identity-prefix riece-current-channel)))
  96     ;; Add channel.
  97     (add-to-list 'riece-xfaceb-channels
  98                  (riece-identity-prefix riece-current-channel))
  99     (message "Channel: %s added to riece-xfaceb channel list."
 100              (riece-identity-prefix riece-current-channel)))
 101   (riece-emit-signal 'user-list-changed riece-current-channel))
 102
 103 (defun riece-xfaceb-face-to-png (face)
 104   "Base64 decode a Face header into a PNG.
 105 Returns a string."
 106   (with-temp-buffer
 107     (insert face)
 108     (base64-decode-region (point-min) (point-max))
 109     (buffer-string)))
 110
 111 (defun riece-xfaceb-add-glyph (type extent data)
 112   "Adds a cface or xface glyph to an extent.
 113
 114 TYPE is a symbol, either `cface', or `xface'.
 115 EXTENT is the extent to add the glyph to.
 116 DATA is the image data from BBDB."
 117   (cond
 118    ((eq type 'cface)
 119     (let ((glyph (riece-xfaceb-face-to-png data)))
 120       (set-extent-begin-glyph
 121        extent
 122        (make-glyph `([png :data ,glyph])))))
 123    ((eq type 'xface)
 124     (let ((glyph (concat "X-Face: " data)))
 125       (set-extent-begin-glyph
 126        extent
 127        (make-glyph `([xface :data ,glyph
 128                             :foreground "black"
 129                             :background "white"])))))
 130    (t nil)))
 131
 132 (defun riece-xfaceb-update-user-list-buffer ()
 133   "Add X-Face or Colour Face images to channel users' buffer."
 134   (when (and (get 'riece-xfaceb 'riece-addon-enabled)
 135              riece-current-channel
 136              (or (null riece-xfaceb-channels)
 137                  (member (riece-identity-prefix riece-current-channel)
 138                          riece-xfaceb-channels)))
 139     (let ((users (ignore-errors
 140                    (riece-with-server-buffer
 141                        (riece-identity-server riece-current-channel)
 142                      (riece-channel-get-users (riece-identity-prefix
 143                                                riece-current-channel))))))
 144       (while users
 145         (let* ((name (regexp-quote (caar users)))
 146                (str (cons 'ircnick name))
 147                (records (bbdb-search (bbdb-records) nil nil nil str nil))
 148                cface xface)
 149           (mapcar
 150            #'(lambda (record)
 151                (setq xface (bbdb-record-getprop record 'face))
 152                (setq cface (bbdb-record-getprop record 'cface)))
 153            records)
 154           (when (or cface xface)
 155             (with-current-buffer riece-user-list-buffer
 156               (goto-char (point-min))
 157               (re-search-forward (regexp-quote name) nil t)
 158               (beginning-of-line)
 159               (let ((ext (extent-at (point))))
 160                 (cond
 161                  ((and cface
 162                        (or riece-xfaceb-prefer-cface-to-xface
 163                            (not xface)))
 164                   (riece-xfaceb-add-glyph 'cface ext cface))
 165                  (xface (riece-xfaceb-add-glyph 'xface ext xface))
 166                  (t nil))))))
 167         (setq users (cdr users))))))
 168
 169 (defun riece-xfaceb-requires ()
 170   )
 171
 172 (defun riece-xfaceb-user-list-mode-hook ()
 173   (add-hook 'riece-update-buffer-functions
 174             'riece-xfaceb-update-user-list-buffer t t))
 175
 176 (defun riece-xfaceb-insinuate ()
 177   (if riece-user-list-buffer
 178       (with-current-buffer riece-user-list-buffer
 179         (riece-xfaceb-user-list-mode-hook)))
 180   (add-hook 'riece-user-list-mode-hook
 181             'riece-xfaceb-user-list-mode-hook))
 182
 183 (defun riece-xfaceb-uninstall ()
 184   (if riece-user-list-buffer
 185       (with-current-buffer riece-user-list-buffer
 186         (remove-hook 'riece-update-buffer-functions
 187                      'riece-xfaceb-update-user-list-buffer t)))
 188   (remove-hook 'riece-user-list-mode-hook
 189                'riece-xfaceb-user-list-mode-hook))
 190
 191 (defun riece-xfaceb-enable ()
 192   (add-to-list 'riece-saved-forms 'riece-xfaceb-channels)
 193   (define-key riece-command-mode-map "\C-c\C-cx"
 194     #'riece-xfaceb-addremove-channel)
 195   (if riece-current-channel
 196       (riece-emit-signal 'user-list-changed riece-current-channel)))
 197
 198 (defun riece-xfaceb-disable ()
 199   (setq riece-saved-forms
 200         (remove 'riece-xfaceb-channels riece-saved-forms))
 201   (define-key riece-command-mode-map "\C-c\C-cx" nil)
 202   (if riece-current-channel
 203       (riece-emit-signal 'user-list-changed riece-current-channel)))
 204
 205 (provide 'riece-xfaceb)
 206
 207 ;;; riece-xfaceb.el ends here
 208