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 (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