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