Add isearch-yank-symbol-or-char
[emacs.git] / lisp / gnus / gnus-fun.el
blob40c6d511115df943080f131581d06a7bf1671a23
1 ;;; gnus-fun.el --- various frivolous extension functions to Gnus
3 ;; Copyright (C) 2002-2018 Free Software Foundation, Inc.
5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
6 ;; Keywords: news
8 ;; This file is part of GNU Emacs.
10 ;; GNU Emacs 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 3 of the License, or
13 ;; (at your option) any later version.
15 ;; GNU Emacs 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.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
23 ;;; Commentary:
25 ;;; Code:
27 (eval-when-compile
28 (require 'cl))
30 (require 'mm-util)
31 (require 'gnus-util)
32 (require 'gnus)
34 (defvar gnus-face-properties-alist)
36 (defcustom gnus-x-face-directory (expand-file-name "x-faces" gnus-directory)
37 "Directory where X-Face PBM files are stored."
38 :version "22.1"
39 :group 'gnus-fun
40 :type 'directory)
42 (defcustom gnus-x-face-omit-files nil
43 "Regexp to match faces in `gnus-x-face-directory' to be omitted."
44 :version "25.1"
45 :group 'gnus-fun
46 :type '(choice (const nil) string))
48 (defcustom gnus-face-directory (expand-file-name "faces" gnus-directory)
49 "Directory where Face PNG files are stored."
50 :version "25.1"
51 :group 'gnus-fun
52 :type 'directory)
54 (defcustom gnus-face-omit-files nil
55 "Regexp to match faces in `gnus-face-directory' to be omitted."
56 :version "25.1"
57 :group 'gnus-fun
58 :type '(choice (const nil) string))
60 (defcustom gnus-convert-pbm-to-x-face-command "pbmtoxbm %s | compface"
61 "Command for converting a PBM to an X-Face."
62 :version "22.1"
63 :group 'gnus-fun
64 :type 'string)
66 (defcustom gnus-convert-image-to-x-face-command
67 "convert -scale 48x48! %s xbm:- | xbm2xface.pl"
68 "Command for converting an image to an X-Face.
69 The command must take an image filename (use \"%s\") as input.
70 The output must be the X-Face header data on stdout."
71 :version "22.1"
72 :group 'gnus-fun
73 :type '(choice (const :tag "giftopnm, netpbm (GIF input only)"
74 "giftopnm %s | ppmnorm | pnmscale -width 48 -height 48 | ppmtopgm | pgmtopbm | pbmtoxbm | compface")
75 (const :tag "convert"
76 "convert -scale 48x48! %s xbm:- | xbm2xface.pl")
77 (string)))
79 (defcustom gnus-convert-image-to-face-command
80 "convert -scale 48x48! %s -colors %d png:-"
81 "Command for converting an image to a Face.
83 The command must take an image filename (first format argument
84 \"%s\") and the number of colors (second format argument: \"%d\")
85 as input. The output must be the Face header data on stdout in
86 PNG format."
87 :version "22.1"
88 :group 'gnus-fun
89 :type '(choice (const :tag "djpeg, netpbm (JPG input only)"
90 "djpeg %s | ppmnorm | pnmscale -width 48 -height 48 | ppmquant %d | pnmtopng")
91 (const :tag "convert"
92 "convert -scale 48x48! %s -colors %d png:-")
93 (string)))
95 (defun gnus-shell-command-to-string (command)
96 "Like `shell-command-to-string' except not mingling ERROR."
97 (with-output-to-string
98 (call-process shell-file-name nil (list standard-output nil)
99 nil shell-command-switch command)))
101 ;;;###autoload
102 (defun gnus--random-face-with-type (dir ext omit fun)
103 "Return file from DIR with extension EXT, omitting matches of OMIT, processed by FUN."
104 (when (file-exists-p dir)
105 (let* ((files
106 (remove nil (mapcar
107 (lambda (f) (unless (string-match (or omit "^$") f) f))
108 (directory-files dir t ext))))
109 (file (nth (random (length files)) files)))
110 (when file
111 (funcall fun file)))))
113 ;;;###autoload
114 (autoload 'message-goto-eoh "message" nil t)
115 (autoload 'message-insert-header "message" nil t)
117 (defun gnus--insert-random-face-with-type (fun type)
118 "Get a random face using FUN and insert it as a header TYPE.
120 For instance, to insert an X-Face use `gnus-random-x-face' as FUN
121 and \"X-Face\" as TYPE."
122 (let ((data (funcall fun)))
123 (save-excursion
124 (if data
125 (progn (message-goto-eoh)
126 (insert type ": " data "\n"))
127 (message
128 "No face returned by the function %s." (symbol-name fun))))))
132 ;;;###autoload
133 (defun gnus-random-x-face ()
134 "Return X-Face header data chosen randomly from `gnus-x-face-directory'.
136 Files matching `gnus-x-face-omit-files' are not considered."
137 (interactive)
138 (gnus--random-face-with-type gnus-x-face-directory "\\.pbm$" gnus-x-face-omit-files
139 (lambda (file)
140 (gnus-shell-command-to-string
141 (format gnus-convert-pbm-to-x-face-command
142 (shell-quote-argument file))))))
144 ;;;###autoload
145 (defun gnus-insert-random-x-face-header ()
146 "Insert a random X-Face header from `gnus-x-face-directory'."
147 (interactive)
148 (gnus--insert-random-face-with-type 'gnus-random-x-face 'X-Face))
150 ;;;###autoload
151 (defun gnus-x-face-from-file (file)
152 "Insert an X-Face header based on an image FILE.
154 Depending on `gnus-convert-image-to-x-face-command' it may accept
155 different input formats."
156 (interactive "fImage file name: ")
157 (when (file-exists-p file)
158 (gnus-shell-command-to-string
159 (format gnus-convert-image-to-x-face-command
160 (shell-quote-argument (expand-file-name file))))))
162 ;;;###autoload
163 (defun gnus-face-from-file (file)
164 "Return a Face header based on an image FILE.
166 Depending on `gnus-convert-image-to-face-command' it may accept
167 different input formats."
168 (interactive "fImage file name: ")
169 (when (file-exists-p file)
170 (let ((done nil)
171 (attempt "")
172 (quant 16))
173 (while (and (not done)
174 (> quant 1))
175 (setq attempt
176 (let ((coding-system-for-read 'binary))
177 (gnus-shell-command-to-string
178 (format gnus-convert-image-to-face-command
179 (shell-quote-argument (expand-file-name file))
180 quant))))
181 (if (> (length attempt) 726)
182 (progn
183 (setq quant (- quant (if (< quant 10) 1 2)))
184 (gnus-message 9 "Length %d; trying quant %d"
185 (length attempt) quant))
186 (setq done t)))
187 (if done
188 (mm-with-unibyte-buffer
189 (insert attempt)
190 (gnus-face-encode))
191 nil))))
193 (defun gnus-face-encode ()
194 (let ((step 72))
195 (base64-encode-region (point-min) (point-max))
196 (goto-char (point-min))
197 (while (search-forward "\n" nil t)
198 (replace-match ""))
199 (goto-char (point-min))
200 (while (> (- (point-max) (point))
201 step)
202 (forward-char step)
203 (insert "\n ")
204 (setq step 76))
205 (buffer-string)))
207 ;;;###autoload
208 (defun gnus-convert-face-to-png (face)
209 "Convert FACE (which is base64-encoded) to a PNG.
210 The PNG is returned as a string."
211 (mm-with-unibyte-buffer
212 (insert face)
213 (ignore-errors
214 (base64-decode-region (point-min) (point-max)))
215 (buffer-string)))
217 ;;;###autoload
218 (defun gnus-convert-png-to-face (file)
219 "Convert FILE to a Face.
220 FILE should be a PNG file that's 48x48 and smaller than or equal to
221 726 bytes."
222 (mm-with-unibyte-buffer
223 (insert-file-contents file)
224 (when (> (buffer-size) 726)
225 (error "The file is %d bytes long, which is too long"
226 (buffer-size)))
227 (gnus-face-encode)))
229 ;;;###autoload
230 (defun gnus-random-face ()
231 "Return randomly chosen Face from `gnus-face-directory'.
233 Files matching `gnus-face-omit-files' are not considered."
234 (interactive)
235 (gnus--random-face-with-type gnus-face-directory "\\.png$"
236 gnus-face-omit-files
237 'gnus-convert-png-to-face))
239 ;;;###autoload
240 (defun gnus-insert-random-face-header ()
241 "Insert a random Face header from `gnus-face-directory'."
242 (gnus--insert-random-face-with-type 'gnus-random-face 'Face))
244 (defface gnus-x-face '((t (:foreground "black" :background "white")))
245 "Face to show X-Face.
246 The colors from this face are used as the foreground and background
247 colors of the displayed X-Faces."
248 :group 'gnus-article-headers)
250 (declare-function article-narrow-to-head "gnus-art" ())
251 (declare-function gnus-article-goto-header "gnus-art" (header))
252 (declare-function gnus-add-image "gnus-art" (category image))
253 (declare-function gnus-add-wash-type "gnus-art" (type))
255 (defun gnus-display-x-face-in-from (data)
256 "Display the X-Face DATA in the From header."
257 (require 'gnus-art)
258 (let (pbm)
259 (when (or (gnus-image-type-available-p 'xface)
260 (and (gnus-image-type-available-p 'pbm)
261 (setq pbm (uncompface data))))
262 (save-excursion
263 (save-restriction
264 (article-narrow-to-head)
265 (gnus-article-goto-header "from")
266 (when (bobp)
267 (insert "From: [no 'from' set]\n")
268 (forward-char -17))
269 (gnus-add-image
270 'xface
271 (gnus-put-image
272 (if (gnus-image-type-available-p 'xface)
273 (apply 'gnus-create-image (concat "X-Face: " data) 'xface t
274 (cdr (assq 'xface gnus-face-properties-alist)))
275 (apply 'gnus-create-image pbm 'pbm t
276 (cdr (assq 'pbm gnus-face-properties-alist))))
277 nil 'xface))
278 (gnus-add-wash-type 'xface))))))
280 (defun gnus-grab-cam-x-face ()
281 "Grab a picture off the camera and make it into an X-Face."
282 (interactive)
283 (shell-command "xawtv-remote snap ppm")
284 (let ((file nil))
285 (while (null (setq file (directory-files "/tftpboot/sparky/tmp"
286 t "snap.*ppm")))
287 (sleep-for 1))
288 (setq file (car file))
289 (with-temp-buffer
290 (shell-command
291 (format "pnmcut -left 110 -top 30 -width 144 -height 144 '%s' | ppmnorm 2>/dev/null | pnmscale -width 48 | ppmtopgm | pgmtopbm -threshold -value 0.92 | pbmtoxbm | compface"
292 file)
293 (current-buffer))
294 ;;(sleep-for 3)
295 (delete-file file)
296 (buffer-string))))
298 (defun gnus-grab-cam-face ()
299 "Grab a picture off the camera and make it into an X-Face."
300 (interactive)
301 (shell-command "xawtv-remote snap ppm")
302 (let ((file nil)
303 (tempfile (make-temp-file "gnus-face-" nil ".ppm"))
304 result)
305 (while (null (setq file (directory-files "/tftpboot/sparky/tmp"
306 t "snap.*ppm")))
307 (sleep-for 1))
308 (setq file (car file))
309 (shell-command
310 (format "pnmcut -left 110 -top 30 -width 144 -height 144 '%s' | pnmscale -width 48 -height 48 | ppmtopgm >> %s"
311 file tempfile))
312 (let ((gnus-convert-image-to-face-command
313 (format "cat '%%s' | ppmquant %%d | ppmchange %s | pnmtopng"
314 (gnus-fun-ppm-change-string))))
315 (setq result (gnus-face-from-file tempfile)))
316 (delete-file file)
317 ;;(delete-file tempfile) ; FIXME why are we not deleting it?!
318 result))
320 (defun gnus-fun-ppm-change-string ()
321 (let* ((possibilities '("%02x0000" "00%02x00" "0000%02x"
322 "%02x%02x00" "00%02x%02x" "%02x00%02x"))
323 (format (concat "'#%02x%02x%02x' '#"
324 (nth (random 6) possibilities)
325 "'"))
326 (values nil))
327 (dotimes (i 255)
328 (push (format format i i i i i i)
329 values))
330 (mapconcat 'identity values " ")))
332 (defun gnus-funcall-no-warning (function &rest args)
333 (when (fboundp function)
334 (apply function args)))
336 (provide 'gnus-fun)
338 ;;; gnus-fun.el ends here