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