/usr/share/emacs/site-lisp/elpa-src/jabber-0.8.92/jabber-avatar.el is in elpa-jabber 0.8.92+git98dc8e-2.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 | ;;; jabber-avatar.el --- generic functions for avatars
;; Copyright (C) 2006, 2007, 2008 Magnus Henoch
;; Author: Magnus Henoch <mange@freemail.hu>
;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; There are several methods for transporting avatars in Jabber
;; (JEP-0008, JEP-0084, JEP-0153). They all have in common that they
;; identify avatars by their SHA1 checksum, and (at least partially)
;; use Base64-encoded image data. Thus this library of support
;; functions for interpreting and caching avatars.
;; A contact with an avatar has the image in the avatar property of
;; the JID symbol. Use `jabber-avatar-set' to set it.
;;; Code:
(require 'mailcap)
(eval-when-compile (require 'cl))
;;;; Variables
(defgroup jabber-avatar nil
"Avatar related settings"
:group 'jabber)
(defcustom jabber-avatar-cache-directory
(locate-user-emacs-file "jabber-avatar-cache" ".jabber-avatars")
"Directory to use for cached avatars"
:group 'jabber-avatar
:type 'directory)
(defcustom jabber-avatar-verbose nil
"Display messages about irregularities with other people's avatars."
:group 'jabber-avatar
:type 'boolean)
(defcustom jabber-avatar-max-width 96
"Maximum width of avatars."
:group 'jabber-avatar
:type 'integer)
(defcustom jabber-avatar-max-height 96
"Maximum height of avatars."
:group 'jabber-avatar
:type 'integer)
;;;; Avatar data handling
(defstruct avatar sha1-sum mime-type url base64-data height width bytes)
(defun jabber-avatar-from-url (url)
"Construct an avatar structure from the given URL.
Retrieves the image to find info about it."
(with-current-buffer (let ((coding-system-for-read 'binary))
(url-retrieve-synchronously url))
(let* ((case-fold-search t)
(mime-type (ignore-errors
(search-forward-regexp "^content-type:[ \t]*\\(.*\\)$")
(match-string 1)))
(data (progn
(search-forward "\n\n")
(buffer-substring (point) (point-max)))))
(prog1
(jabber-avatar-from-data data nil mime-type)
(kill-buffer nil)))))
(defun jabber-avatar-from-file (filename)
"Construct an avatar structure from FILENAME."
(require 'mailcap)
(let ((data (with-temp-buffer
(insert-file-contents-literally filename)
(buffer-string)))
(mime-type (when (string-match "\\.[^.]+$" filename)
(mailcap-extension-to-mime (match-string 0 filename)))))
(jabber-avatar-from-data data nil mime-type)))
(defun jabber-avatar-from-base64-string (base64-string &optional mime-type)
"Construct an avatar stucture from BASE64-STRING.
If MIME-TYPE is not specified, try to find it from the image data."
(jabber-avatar-from-data nil base64-string mime-type))
(defun jabber-avatar-from-data (raw-data base64-string &optional mime-type)
"Construct an avatar structure from RAW-DATA and/or BASE64-STRING.
If either is not provided, it is computed.
If MIME-TYPE is not specified, try to find it from the image data."
(let* ((data (or raw-data (base64-decode-string base64-string)))
(bytes (length data))
(sha1-sum (sha1 data))
(base64-data (or base64-string (base64-encode-string raw-data)))
(type (or mime-type
(cdr (assq (get :type (cdr (condition-case nil
(jabber-create-image data nil t)
(error nil))))
'((png "image/png")
(jpeg "image/jpeg")
(gif "image/gif")))))))
(jabber-avatar-compute-size
(make-avatar :mime-type mime-type :sha1-sum sha1-sum :base64-data base64-data :bytes bytes))))
;; XXX: This function is based on an outdated version of JEP-0084.
;; (defun jabber-avatar-from-data-node (data-node)
;; "Construct an avatar structure from the given <data/> node."
;; (jabber-xml-let-attributes
;; (content-type id bytes height width) data-node
;; (let ((base64-data (car (jabber-xml-node-children data-node))))
;; (make-avatar :mime-type content-type :sha1-sum id :bytes bytes
;; :height height :width width :base64-data base64-data))))
(defun jabber-avatar-image (avatar)
"Create an image from AVATAR.
Return nil if images of this type are not supported."
(condition-case nil
(jabber-create-image (with-temp-buffer
(set-buffer-multibyte nil)
(insert (avatar-base64-data avatar))
(base64-decode-region (point-min) (point-max))
(buffer-string))
nil
t)
(error nil)))
(defun jabber-avatar-compute-size (avatar)
"Compute and set the width and height fields of AVATAR.
Return AVATAR."
;; image-size only works when there is a window system.
;; But display-graphic-p doesn't exist on XEmacs...
(let ((size (and (fboundp 'display-graphic-p)
(display-graphic-p)
(let ((image (jabber-avatar-image avatar)))
(and image
(image-size image t))))))
(when size
(setf (avatar-width avatar) (car size))
(setf (avatar-height avatar) (cdr size)))
avatar))
;;;; Avatar cache
(defun jabber-avatar-find-cached (sha1-sum)
"Return file name of cached image for avatar identified by SHA1-SUM.
If there is no cached image, return nil."
(let ((filename (expand-file-name sha1-sum jabber-avatar-cache-directory)))
(if (file-exists-p filename)
filename
nil)))
(defun jabber-avatar-cache (avatar)
"Cache the AVATAR."
(let* ((id (avatar-sha1-sum avatar))
(base64-data (avatar-base64-data avatar))
(mime-type (avatar-mime-type avatar))
(filename (expand-file-name id jabber-avatar-cache-directory)))
(unless (file-directory-p jabber-avatar-cache-directory)
(make-directory jabber-avatar-cache-directory t))
(if (file-exists-p filename)
(when jabber-avatar-verbose
(message "Caching avatar, but %s already exists" filename))
(with-temp-buffer
(let ((require-final-newline nil)
(coding-system-for-write 'binary))
(if (fboundp 'set-buffer-multibyte)
(set-buffer-multibyte nil))
(insert base64-data)
(base64-decode-region (point-min) (point-max))
(write-region (point-min) (point-max) filename nil 'silent))))))
;;;; Set avatar for contact
(defun jabber-avatar-set (jid avatar)
"Set the avatar of JID to be AVATAR.
JID is a string containing a bare JID.
AVATAR may be one of:
* An avatar structure.
* The SHA1 sum of a cached avatar.
* nil, meaning no avatar."
;; We want to optimize for the case of same avatar.
;; Loading an image is expensive, so do it lazily.
(let ((jid-symbol (jabber-jid-symbol jid))
image hash)
(cond
((avatar-p avatar)
(setq hash (avatar-sha1-sum avatar))
(setq image (lambda () (jabber-avatar-image avatar))))
((stringp avatar)
(setq hash avatar)
(setq image (lambda ()
(condition-case nil
(jabber-create-image (jabber-avatar-find-cached avatar))
(error nil)))))
(t
(setq hash nil)
(setq image #'ignore)))
(unless (string= hash (get jid-symbol 'avatar-hash))
(put jid-symbol 'avatar (funcall image))
(put jid-symbol 'avatar-hash hash)
(jabber-presence-update-roster jid-symbol))))
(defun jabber-create-image (file-or-data &optional type data-p)
"Create image, scaled down to jabber-avatar-max-width/height,
if width/height exceeds either of those, and ImageMagick is
available."
(let* ((image (create-image file-or-data type data-p))
(size (image-size image t))
(spec (cdr image)))
(when (and (functionp 'imagemagick-types)
(or (> (car size) jabber-avatar-max-width)
(> (cdr size) jabber-avatar-max-height)))
(plist-put spec :type 'imagemagick)
(plist-put spec :width jabber-avatar-max-width)
(plist-put spec :height jabber-avatar-max-height))
image))
(provide 'jabber-avatar)
;; arch-tag: 2405c3f8-8eaa-11da-826c-000a95c2fcd0
|