djavu-asus/elpa/jabber-20230715.456/jabber-avatar.el

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