[config.git] / djavu-asus / elpa / jabber-20230715.456 / jabber-avatar.el

;;; jabber-avatar.el --- generic functions for avatars  -*- lexical-binding: t; -*-

;; 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. [1][2][3]
;;
;; 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.
;;
;; [1] XEP-0008: IQ-Based Avatars
;;     https://xmpp.org/extensions/xep-0008.html
;; [2] XEP-0084: User Avatar
;;     https://xmpp.org/extensions/xep-0084.html
;; [3] XEP-0153: vCard-Based Avatars
;;     https://xmpp.org/extensions/xep-0153.html

;;; Code:

(require 'mailcap)
(eval-when-compile (require 'cl-lib))

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

(cl-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 XEP-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 an image from FILE-OR-DATA.
If width/height exceeds jabber-avatar-max-width or
jabber-avatar-max-height, and ImageMagick is available, the image
is scaled down."
  (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
Commit	Line	Data
53e6db90 DC	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