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