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