Commit | Line | Data |
---|---|---|
23f87bed | 1 | ;;; gnus-fun.el --- various frivolous extension functions to Gnus |
e84b4b86 | 2 | |
e3fe4da0 | 3 | ;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008 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 | ||
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 | |
5a9dffec | 12 | ;; the Free Software Foundation; either version 3, or (at your option) |
23f87bed MB |
13 | ;; any later version. |
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 | |
17 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
18 | ;; GNU General Public License for more details. | |
19 | ||
20 | ;; You should have received a copy of the GNU General Public License | |
21 | ;; along with GNU Emacs; see the file COPYING. If not, write to the | |
3a35cf56 LK |
22 | ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, |
23 | ;; Boston, MA 02110-1301, USA. | |
23f87bed MB |
24 | |
25 | ;;; Commentary: | |
26 | ||
27 | ;;; Code: | |
28 | ||
25fcd06c GM |
29 | ;; For Emacs < 22.2. |
30 | (eval-and-compile | |
31 | (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) | |
32 | ||
23f87bed | 33 | (eval-when-compile |
c1d7d285 MB |
34 | (require 'cl)) |
35 | ||
36 | (require 'mm-util) | |
37 | (require 'gnus-ems) | |
38 | (require 'gnus-util) | |
1b155fbd | 39 | (require 'gnus) |
23f87bed | 40 | |
9efa445f DN |
41 | (defvar gnus-face-properties-alist) |
42 | ||
23f87bed MB |
43 | (defcustom gnus-x-face-directory (expand-file-name "x-faces" gnus-directory) |
44 | "*Directory where X-Face PBM files are stored." | |
bf247b6e | 45 | :version "22.1" |
23f87bed MB |
46 | :group 'gnus-fun |
47 | :type 'directory) | |
48 | ||
49 | (defcustom gnus-convert-pbm-to-x-face-command "pbmtoxbm %s | compface" | |
50 | "Command for converting a PBM to an X-Face." | |
bf247b6e | 51 | :version "22.1" |
23f87bed MB |
52 | :group 'gnus-fun |
53 | :type 'string) | |
54 | ||
01c52d31 MB |
55 | (defcustom gnus-convert-image-to-x-face-command |
56 | "convert -scale 48x48! %s xbm:- | xbm2xface.pl" | |
23f87bed | 57 | "Command for converting an image to an X-Face. |
01c52d31 MB |
58 | The command must take a image filename (use \"%s\") as input. |
59 | The output must be the Face header data on stdout in PNG format. | |
60 | ||
23f87bed MB |
61 | By default it takes a GIF filename and output the X-Face header data |
62 | on stdout." | |
bf247b6e | 63 | :version "22.1" |
23f87bed | 64 | :group 'gnus-fun |
01c52d31 MB |
65 | :type '(choice (const :tag "giftopnm, netpbm (GIF input only)" |
66 | "giftopnm %s | ppmnorm | pnmscale -width 48 -height 48 | ppmtopgm | pgmtopbm | pbmtoxbm | compface") | |
67 | (const :tag "convert" | |
68 | "convert -scale 48x48! %s xbm:- | xbm2xface.pl") | |
69 | (string))) | |
70 | ||
71 | (defcustom gnus-convert-image-to-face-command | |
72 | "convert -scale 48x48! %s -colors %d png:-" | |
4a2358e9 | 73 | "Command for converting an image to a Face. |
01c52d31 MB |
74 | |
75 | The command must take an image filename (first format argument | |
76 | \"%s\") and the number of colors (second format argument: \"%d\") | |
77 | as input. The output must be the Face header data on stdout in | |
78 | PNG format." | |
bf247b6e | 79 | :version "22.1" |
23f87bed | 80 | :group 'gnus-fun |
01c52d31 MB |
81 | :type '(choice (const :tag "djpeg, netpbm (JPG input only)" |
82 | "djpeg %s | ppmnorm | pnmscale -width 48 -height 48 | ppmquant %d | pnmtopng") | |
83 | (const :tag "convert" | |
84 | "convert -scale 48x48! %s -colors %d png:-") | |
85 | (string))) | |
23f87bed MB |
86 | |
87 | (defun gnus-shell-command-to-string (command) | |
88 | "Like `shell-command-to-string' except not mingling ERROR." | |
89 | (with-output-to-string | |
90 | (call-process shell-file-name nil (list standard-output nil) | |
91 | nil shell-command-switch command))) | |
92 | ||
93 | (defun gnus-shell-command-on-region (start end command) | |
94 | "A simplified `shell-command-on-region'. | |
95 | Output to the current buffer, replace text, and don't mingle error." | |
96 | (call-process-region start end shell-file-name t | |
97 | (list (current-buffer) nil) | |
98 | nil shell-command-switch command)) | |
99 | ||
100 | ;;;###autoload | |
101 | (defun gnus-random-x-face () | |
102 | "Return X-Face header data chosen randomly from `gnus-x-face-directory'." | |
103 | (interactive) | |
104 | (when (file-exists-p gnus-x-face-directory) | |
105 | (let* ((files (directory-files gnus-x-face-directory t "\\.pbm$")) | |
106 | (file (nth (random (length files)) files))) | |
107 | (when file | |
108 | (gnus-shell-command-to-string | |
109 | (format gnus-convert-pbm-to-x-face-command | |
110 | (shell-quote-argument file))))))) | |
111 | ||
25fcd06c GM |
112 | (autoload 'message-goto-eoh "message" nil t) |
113 | ||
23f87bed MB |
114 | ;;;###autoload |
115 | (defun gnus-insert-random-x-face-header () | |
116 | "Insert a random X-Face header from `gnus-x-face-directory'." | |
117 | (interactive) | |
118 | (let ((data (gnus-random-x-face))) | |
119 | (save-excursion | |
120 | (message-goto-eoh) | |
121 | (if data | |
122 | (insert "X-Face: " data) | |
123 | (message | |
124 | "No face returned by `gnus-random-x-face'. Does %s/*.pbm exist?" | |
125 | gnus-x-face-directory))))) | |
126 | ||
127 | ;;;###autoload | |
128 | (defun gnus-x-face-from-file (file) | |
01c52d31 MB |
129 | "Insert an X-Face header based on an image file. |
130 | ||
131 | Depending on `gnus-convert-image-to-x-face-command' it may accept | |
132 | different input formats." | |
133 | (interactive "fImage file name: ") | |
23f87bed MB |
134 | (when (file-exists-p file) |
135 | (gnus-shell-command-to-string | |
136 | (format gnus-convert-image-to-x-face-command | |
137 | (shell-quote-argument (expand-file-name file)))))) | |
138 | ||
139 | ;;;###autoload | |
140 | (defun gnus-face-from-file (file) | |
01c52d31 MB |
141 | "Return a Face header based on an image file. |
142 | ||
143 | Depending on `gnus-convert-image-to-face-command' it may accept | |
144 | different input formats." | |
145 | (interactive "fImage file name: ") | |
23f87bed MB |
146 | (when (file-exists-p file) |
147 | (let ((done nil) | |
148 | (attempt "") | |
149 | (quant 16)) | |
150 | (while (and (not done) | |
151 | (> quant 1)) | |
152 | (setq attempt | |
153 | (let ((coding-system-for-read 'binary)) | |
154 | (gnus-shell-command-to-string | |
155 | (format gnus-convert-image-to-face-command | |
156 | (shell-quote-argument (expand-file-name file)) | |
157 | quant)))) | |
158 | (if (> (length attempt) 726) | |
159 | (progn | |
01c52d31 | 160 | (setq quant (- quant (if (< quant 10) 1 2))) |
23f87bed MB |
161 | (gnus-message 9 "Length %d; trying quant %d" |
162 | (length attempt) quant)) | |
163 | (setq done t))) | |
164 | (if done | |
165 | (mm-with-unibyte-buffer | |
166 | (insert attempt) | |
167 | (gnus-face-encode)) | |
168 | nil)))) | |
169 | ||
170 | (defun gnus-face-encode () | |
171 | (let ((step 72)) | |
172 | (base64-encode-region (point-min) (point-max)) | |
173 | (goto-char (point-min)) | |
174 | (while (search-forward "\n" nil t) | |
175 | (replace-match "")) | |
176 | (goto-char (point-min)) | |
177 | (while (> (- (point-max) (point)) | |
178 | step) | |
179 | (forward-char step) | |
180 | (insert "\n ") | |
181 | (setq step 76)) | |
182 | (buffer-string))) | |
183 | ||
184 | ;;;###autoload | |
185 | (defun gnus-convert-face-to-png (face) | |
186 | "Convert FACE (which is base64-encoded) to a PNG. | |
187 | The PNG is returned as a string." | |
188 | (mm-with-unibyte-buffer | |
189 | (insert face) | |
190 | (ignore-errors | |
191 | (base64-decode-region (point-min) (point-max))) | |
192 | (buffer-string))) | |
193 | ||
194 | ;;;###autoload | |
195 | (defun gnus-convert-png-to-face (file) | |
196 | "Convert FILE to a Face. | |
197 | FILE should be a PNG file that's 48x48 and smaller than or equal to | |
198 | 726 bytes." | |
199 | (mm-with-unibyte-buffer | |
200 | (insert-file-contents file) | |
201 | (when (> (buffer-size) 726) | |
202 | (error "The file is %d bytes long, which is too long" | |
203 | (buffer-size))) | |
204 | (gnus-face-encode))) | |
205 | ||
206 | (defface gnus-x-face '((t (:foreground "black" :background "white"))) | |
207 | "Face to show X-Face. | |
208 | The colors from this face are used as the foreground and background | |
209 | colors of the displayed X-Faces." | |
210 | :group 'gnus-article-headers) | |
211 | ||
25fcd06c GM |
212 | (declare-function article-narrow-to-head "gnus-art" ()) |
213 | (declare-function gnus-article-goto-header "gnus-art" (header)) | |
214 | (declare-function gnus-add-image "gnus-art" (category image)) | |
215 | (declare-function gnus-add-wash-type "gnus-art" (type)) | |
216 | ||
23f87bed MB |
217 | (defun gnus-display-x-face-in-from (data) |
218 | "Display the X-Face DATA in the From header." | |
25fcd06c | 219 | (require 'gnus-art) |
d7eb3b36 | 220 | (let (pbm) |
23f87bed MB |
221 | (when (or (gnus-image-type-available-p 'xface) |
222 | (and (gnus-image-type-available-p 'pbm) | |
223 | (setq pbm (uncompface data)))) | |
224 | (save-excursion | |
225 | (save-restriction | |
226 | (article-narrow-to-head) | |
227 | (gnus-article-goto-header "from") | |
228 | (when (bobp) | |
229 | (insert "From: [no `from' set]\n") | |
230 | (forward-char -17)) | |
231 | (gnus-add-image | |
232 | 'xface | |
233 | (gnus-put-image | |
234 | (if (gnus-image-type-available-p 'xface) | |
01c52d31 MB |
235 | (apply 'gnus-create-image (concat "X-Face: " data) 'xface t |
236 | (cdr (assq 'xface gnus-face-properties-alist))) | |
237 | (apply 'gnus-create-image pbm 'pbm t | |
238 | (cdr (assq 'pbm gnus-face-properties-alist)))) | |
239 | nil 'xface)) | |
23f87bed MB |
240 | (gnus-add-wash-type 'xface)))))) |
241 | ||
242 | (defun gnus-grab-cam-x-face () | |
243 | "Grab a picture off the camera and make it into an X-Face." | |
244 | (interactive) | |
245 | (shell-command "xawtv-remote snap ppm") | |
246 | (let ((file nil)) | |
247 | (while (null (setq file (directory-files "/tftpboot/sparky/tmp" | |
248 | t "snap.*ppm"))) | |
249 | (sleep-for 1)) | |
250 | (setq file (car file)) | |
251 | (with-temp-buffer | |
252 | (shell-command | |
253 | (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" | |
254 | file) | |
255 | (current-buffer)) | |
256 | ;;(sleep-for 3) | |
257 | (delete-file file) | |
258 | (buffer-string)))) | |
259 | ||
260 | (defun gnus-grab-cam-face () | |
261 | "Grab a picture off the camera and make it into an X-Face." | |
262 | (interactive) | |
263 | (shell-command "xawtv-remote snap ppm") | |
264 | (let ((file nil) | |
265 | result) | |
266 | (while (null (setq file (directory-files "/tftpboot/sparky/tmp" | |
267 | t "snap.*ppm"))) | |
268 | (sleep-for 1)) | |
269 | (setq file (car file)) | |
270 | (shell-command | |
271 | (format "pnmcut -left 110 -top 30 -width 144 -height 144 '%s' | pnmscale -width 48 -height 48 | ppmtopgm > /tmp/gnus.face.ppm" | |
272 | file)) | |
273 | (let ((gnus-convert-image-to-face-command | |
274 | (format "cat '%%s' | ppmquant %%d | ppmchange %s | pnmtopng" | |
275 | (gnus-fun-ppm-change-string)))) | |
276 | (setq result (gnus-face-from-file "/tmp/gnus.face.ppm"))) | |
277 | (delete-file file) | |
278 | ;;(delete-file "/tmp/gnus.face.ppm") | |
279 | result)) | |
280 | ||
281 | (defun gnus-fun-ppm-change-string () | |
282 | (let* ((possibilites '("%02x0000" "00%02x00" "0000%02x" | |
283 | "%02x%02x00" "00%02x%02x" "%02x00%02x")) | |
284 | (format (concat "'#%02x%02x%02x' '#" | |
285 | (nth (random 6) possibilites) | |
286 | "'")) | |
287 | (values nil)) | |
288 | (dotimes (i 255) | |
289 | (push (format format i i i i i i) | |
290 | values)) | |
291 | (mapconcat 'identity values " "))) | |
292 | ||
293 | (provide 'gnus-fun) | |
294 | ||
d7eb3b36 | 295 | ;; arch-tag: 9d000a69-15cc-4491-9dc0-4627484f50c1 |
23f87bed | 296 | ;;; gnus-fun.el ends here |