1 ;;; gnus-fun.el --- various frivolous extension functions to Gnus
3 ;; Copyright (C) 2002-2012 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 <http://www.gnu.org/licenses/>.
27 ;; For Emacs <22.2 and XEmacs.
29 (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
39 (defvar gnus-face-properties-alist)
41 (defcustom gnus-x-face-directory (expand-file-name "x-faces" gnus-directory)
42 "*Directory where X-Face PBM files are stored."
47 (defcustom gnus-convert-pbm-to-x-face-command "pbmtoxbm %s | compface"
48 "Command for converting a PBM to an X-Face."
53 (defcustom gnus-convert-image-to-x-face-command
54 "convert -scale 48x48! %s xbm:- | xbm2xface.pl"
55 "Command for converting an image to an X-Face.
56 The command must take a image filename (use \"%s\") as input.
57 The output must be the X-Face header data on stdout."
60 :type '(choice (const :tag "giftopnm, netpbm (GIF input only)"
61 "giftopnm %s | ppmnorm | pnmscale -width 48 -height 48 | ppmtopgm | pgmtopbm | pbmtoxbm | compface")
63 "convert -scale 48x48! %s xbm:- | xbm2xface.pl")
66 (defcustom gnus-convert-image-to-face-command
67 "convert -scale 48x48! %s -colors %d png:-"
68 "Command for converting an image to a Face.
70 The command must take an image filename (first format argument
71 \"%s\") and the number of colors (second format argument: \"%d\")
72 as input. The output must be the Face header data on stdout in
76 :type '(choice (const :tag "djpeg, netpbm (JPG input only)"
77 "djpeg %s | ppmnorm | pnmscale -width 48 -height 48 | ppmquant %d | pnmtopng")
79 "convert -scale 48x48! %s -colors %d png:-")
82 (defun gnus-shell-command-to-string (command)
83 "Like `shell-command-to-string' except not mingling ERROR."
84 (with-output-to-string
85 (call-process shell-file-name nil (list standard-output nil)
86 nil shell-command-switch command)))
89 (defun gnus-random-x-face ()
90 "Return X-Face header data chosen randomly from `gnus-x-face-directory'."
92 (when (file-exists-p gnus-x-face-directory)
93 (let* ((files (directory-files gnus-x-face-directory t "\\.pbm$"))
94 (file (nth (random (length files)) files)))
96 (gnus-shell-command-to-string
97 (format gnus-convert-pbm-to-x-face-command
98 (shell-quote-argument file)))))))
100 (autoload 'message-goto-eoh "message" nil t)
103 (defun gnus-insert-random-x-face-header ()
104 "Insert a random X-Face header from `gnus-x-face-directory'."
106 (let ((data (gnus-random-x-face)))
110 (insert "X-Face: " data)
112 "No face returned by `gnus-random-x-face'. Does %s/*.pbm exist?"
113 gnus-x-face-directory)))))
116 (defun gnus-x-face-from-file (file)
117 "Insert an X-Face header based on an image file.
119 Depending on `gnus-convert-image-to-x-face-command' it may accept
120 different input formats."
121 (interactive "fImage file name: ")
122 (when (file-exists-p file)
123 (gnus-shell-command-to-string
124 (format gnus-convert-image-to-x-face-command
125 (shell-quote-argument (expand-file-name file))))))
128 (defun gnus-face-from-file (file)
129 "Return a Face header based on an image file.
131 Depending on `gnus-convert-image-to-face-command' it may accept
132 different input formats."
133 (interactive "fImage file name: ")
134 (when (file-exists-p file)
138 (while (and (not done)
141 (let ((coding-system-for-read 'binary))
142 (gnus-shell-command-to-string
143 (format gnus-convert-image-to-face-command
144 (shell-quote-argument (expand-file-name file))
146 (if (> (length attempt) 726)
148 (setq quant (- quant (if (< quant 10) 1 2)))