1 ;;; gnus-fun.el --- various frivolous extension functions to Gnus
3 ;; Copyright (C) 2002-2018 Free Software Foundation, Inc.
5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
8 ;; This file is part of GNU Emacs.
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 3 of the License, or
13 ;; (at your option) any later version.
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.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
34 (defvar gnus-face-properties-alist
)
36 (defcustom gnus-x-face-directory
(expand-file-name "x-faces" gnus-directory
)
37 "Directory where X-Face PBM files are stored."
42 (defcustom gnus-x-face-omit-files nil
43 "Regexp to match faces in `gnus-x-face-directory' to be omitted."
46 :type
'(choice (const nil
) string
))
48 (defcustom gnus-face-directory
(expand-file-name "faces" gnus-directory
)
49 "Directory where Face PNG files are stored."
54 (defcustom gnus-face-omit-files nil
55 "Regexp to match faces in `gnus-face-directory' to be omitted."
58 :type
'(choice (const nil
) string
))
60 (defcustom gnus-convert-pbm-to-x-face-command
"pbmtoxbm %s | compface"
61 "Command for converting a PBM to an X-Face."
66 (defcustom gnus-convert-image-to-x-face-command
67 "convert -scale 48x48! %s xbm:- | xbm2xface.pl"
68 "Command for converting an image to an X-Face.
69 The command must take an image filename (use \"%s\") as input.
70 The output must be the X-Face header data on stdout."
73 :type
'(choice (const :tag
"giftopnm, netpbm (GIF input only)"
74 "giftopnm %s | ppmnorm | pnmscale -width 48 -height 48 | ppmtopgm | pgmtopbm | pbmtoxbm | compface")
76 "convert -scale 48x48! %s xbm:- | xbm2xface.pl")
79 (defcustom gnus-convert-image-to-face-command
80 "convert -scale 48x48! %s -colors %d png:-"
81 "Command for converting an image to a Face.
83 The command must take an image filename (first format argument
84 \"%s\") and the number of colors (second format argument: \"%d\")
85 as input. The output must be the Face header data on stdout in
89 :type
'(choice (const :tag
"djpeg, netpbm (JPG input only)"
90 "djpeg %s | ppmnorm | pnmscale -width 48 -height 48 | ppmquant %d | pnmtopng")
92 "convert -scale 48x48! %s -colors %d png:-")
95 (defun gnus-shell-command-to-string (command)
96 "Like `shell-command-to-string' except not mingling ERROR."
97 (with-output-to-string
98 (call-process shell-file-name nil
(list standard-output nil
)
99 nil shell-command-switch command
)))
102 (defun gnus--random-face-with-type (dir ext omit fun
)
103 "Return file from DIR with extension EXT, omitting matches of OMIT, processed by FUN."
104 (when (file-exists-p dir
)
107 (lambda (f) (unless (string-match (or omit
"^$") f
) f
))
108 (directory-files dir t ext
))))
109 (file (nth (random (length files
)) files
)))
111 (funcall fun file
)))))
114 (autoload 'message-goto-eoh
"message" nil t
)
115 (autoload 'message-insert-header
"message" nil t
)
117 (defun gnus--insert-random-face-with-type (fun type
)
118 "Get a random face using FUN and insert it as a header TYPE.
120 For instance, to insert an X-Face use `gnus-random-x-face' as FUN
121 and \"X-Face\" as TYPE."
122 (let ((data (funcall fun
)))
125 (progn (message-goto-eoh)
126 (insert type
": " data
"\n"))
128 "No face returned by the function %s." (symbol-name fun
))))))
133 (defun gnus-random-x-face ()
134 "Return X-Face header data chosen randomly from `gnus-x-face-directory'.
136 Files matching `gnus-x-face-omit-files' are not considered."
138 (gnus--random-face-with-type gnus-x-face-directory
"\\.pbm$" gnus-x-face-omit-files
140 (gnus-shell-command-to-string
141 (format gnus-convert-pbm-to-x-face-command
142 (shell-quote-argument file
))))))
145 (defun gnus-insert-random-x-face-header ()
146 "Insert a random X-Face header from `gnus-x-face-directory'."
148 (gnus--insert-random-face-with-type 'gnus-random-x-face
'X-Face
))
151 (defun gnus-x-face-from-file (file)
152 "Insert an X-Face header based on an image FILE.
154 Depending on `gnus-convert-image-to-x-face-command' it may accept
155 different input formats."
156 (interactive "fImage file name: ")
157 (when (file-exists-p file
)
158 (gnus-shell-command-to-string
159 (format gnus-convert-image-to-x-face-command
160 (shell-quote-argument (expand-file-name file
))))))
163 (defun gnus-face-from-file (file)
164 "Return a Face header based on an image FILE.
166 Depending on `gnus-convert-image-to-face-command' it may accept
167 different input formats."
168 (interactive "fImage file name: ")
169 (when (file-exists-p file
)
173 (while (and (not done
)
176 (let ((coding-system-for-read 'binary
))
177 (gnus-shell-command-to-string
178 (format gnus-convert-image-to-face-command
179 (shell-quote-argument (expand-file-name file
))
181 (if (> (length attempt
) 726)
183 (setq quant
(- quant
(if (< quant
10) 1 2)))
184 (gnus-message 9 "Length %d; trying quant %d"
185 (length attempt
) quant
))
188 (mm-with-unibyte-buffer
193 (defun gnus-face-encode ()
195 (base64-encode-region (point-min) (point-max))
196 (goto-char (point-min))
197 (while (search-forward "\n" nil t
)
199 (goto-char (point-min))
200 (while (> (- (point-max) (point))
208 (defun gnus-convert-face-to-png (face)
209 "Convert FACE (which is base64-encoded) to a PNG.
210 The PNG is returned as a string."
211 (mm-with-unibyte-buffer
214 (base64-decode-region (point-min) (point-max)))
218 (defun gnus-convert-png-to-face (file)
219 "Convert FILE to a Face.
220 FILE should be a PNG file that's 48x48 and smaller than or equal to
222 (mm-with-unibyte-buffer
223 (insert-file-contents file
)
224 (when (> (buffer-size) 726)
225 (error "The file is %d bytes long, which is too long"
230 (defun gnus-random-face ()
231 "Return randomly chosen Face from `gnus-face-directory'.
233 Files matching `gnus-face-omit-files' are not considered."
235 (gnus--random-face-with-type gnus-face-directory
"\\.png$"
237 'gnus-convert-png-to-face
))
240 (defun gnus-insert-random-face-header ()
241 "Insert a random Face header from `gnus-face-directory'."
242 (gnus--insert-random-face-with-type 'gnus-random-face
'Face
))
244 (defface gnus-x-face
'((t (:foreground
"black" :background
"white")))
245 "Face to show X-Face.
246 The colors from this face are used as the foreground and background
247 colors of the displayed X-Faces."
248 :group
'gnus-article-headers
)
250 (declare-function article-narrow-to-head
"gnus-art" ())
251 (declare-function gnus-article-goto-header
"gnus-art" (header))
252 (declare-function gnus-add-image
"gnus-art" (category image
))
253 (declare-function gnus-add-wash-type
"gnus-art" (type))
255 (defun gnus-display-x-face-in-from (data)
256 "Display the X-Face DATA in the From header."
259 (when (or (gnus-image-type-available-p 'xface
)
260 (and (gnus-image-type-available-p 'pbm
)
261 (setq pbm
(uncompface data
))))
264 (article-narrow-to-head)
265 (gnus-article-goto-header "from")
267 (insert "From: [no 'from' set]\n")
272 (if (gnus-image-type-available-p 'xface
)
273 (apply 'gnus-create-image
(concat "X-Face: " data
) 'xface t
274 (cdr (assq 'xface gnus-face-properties-alist
)))
275 (apply 'gnus-create-image pbm
'pbm t
276 (cdr (assq 'pbm gnus-face-properties-alist
))))
278 (gnus-add-wash-type 'xface
))))))
280 (defun gnus-grab-cam-x-face ()
281 "Grab a picture off the camera and make it into an X-Face."
283 (shell-command "xawtv-remote snap ppm")
285 (while (null (setq file
(directory-files "/tftpboot/sparky/tmp"
288 (setq file
(car file
))
291 (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"
298 (defun gnus-grab-cam-face ()
299 "Grab a picture off the camera and make it into an X-Face."
301 (shell-command "xawtv-remote snap ppm")
303 (tempfile (make-temp-file "gnus-face-" nil
".ppm"))
305 (while (null (setq file
(directory-files "/tftpboot/sparky/tmp"
308 (setq file
(car file
))
310 (format "pnmcut -left 110 -top 30 -width 144 -height 144 '%s' | pnmscale -width 48 -height 48 | ppmtopgm >> %s"
312 (let ((gnus-convert-image-to-face-command
313 (format "cat '%%s' | ppmquant %%d | ppmchange %s | pnmtopng"
314 (gnus-fun-ppm-change-string))))
315 (setq result
(gnus-face-from-file tempfile
)))
317 ;;(delete-file tempfile) ; FIXME why are we not deleting it?!
320 (defun gnus-fun-ppm-change-string ()
321 (let* ((possibilities '("%02x0000" "00%02x00" "0000%02x"
322 "%02x%02x00" "00%02x%02x" "%02x00%02x"))
323 (format (concat "'#%02x%02x%02x' '#"
324 (nth (random 6) possibilities
)
328 (push (format format i i i i i i
)
330 (mapconcat 'identity values
" ")))
332 (defun gnus-funcall-no-warning (function &rest args
)
333 (when (fboundp function
)
334 (apply function args
)))
338 ;;; gnus-fun.el ends here