lisp/gnus/gnus-fun.el

   1 ;;; gnus-fun.el --- various frivolous extension functions to Gnus
   2
   3 ;; Copyright (C) 2002-2018 Free Software Foundation, Inc.
   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 3 of the License, or
  13 ;; (at your option) 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.  If not, see <https://www.gnu.org/licenses/>.
  22
  23 ;;; Commentary:
  24
  25 ;;; Code:
  26
  27 (require 'mm-util)
  28 (require 'gnus-util)
  29 (require 'gnus)
  30
  31 (defvar gnus-face-properties-alist)
  32
  33 (defcustom gnus-x-face-directory (expand-file-name "x-faces" gnus-directory)
  34   "Directory where X-Face PBM files are stored."
  35   :version "22.1"
  36   :group 'gnus-fun
  37   :type 'directory)
  38
  39 (defcustom gnus-x-face-omit-files nil
  40   "Regexp to match faces in `gnus-x-face-directory' to be omitted."
  41   :version "25.1"
  42   :group 'gnus-fun
  43   :type '(choice (const nil) string))
  44
  45 (defcustom gnus-face-directory (expand-file-name "faces" gnus-directory)
  46   "Directory where Face PNG files are stored."
  47   :version "25.1"
  48   :group 'gnus-fun
  49   :type 'directory)
  50
  51 (defcustom gnus-face-omit-files nil
  52   "Regexp to match faces in `gnus-face-directory' to be omitted."
  53   :version "25.1"
  54   :group 'gnus-fun
  55   :type '(choice (const nil) string))
  56
  57 (defcustom gnus-convert-pbm-to-x-face-command "pbmtoxbm %s | compface"
  58   "Command for converting a PBM to an X-Face."
  59   :version "22.1"
  60   :group 'gnus-fun
  61   :type 'string)
  62
  63 (defcustom gnus-convert-image-to-x-face-command
  64   "convert -scale 48x48! %s xbm:- | xbm2xface.pl"
  65   "Command for converting an image to an X-Face.
  66 The command must take an image filename (use \"%s\") as input.
  67 The output must be the X-Face header data on stdout."
  68   :version "22.1"
  69   :group 'gnus-fun
  70   :type '(choice (const :tag "giftopnm, netpbm (GIF input only)"
  71                         "giftopnm %s | ppmnorm | pnmscale -width 48 -height 48 | ppmtopgm | pgmtopbm | pbmtoxbm | compface")
  72                  (const :tag "convert"
  73                         "convert -scale 48x48! %s xbm:- | xbm2xface.pl")
  74                  (string)))
  75
  76 (defcustom gnus-convert-image-to-face-command
  77   "convert -scale 48x48! %s -colors %d png:-"
  78   "Command for converting an image to a Face.
  79
  80 The command must take an image filename (first format argument
  81 \"%s\") and the number of colors (second format argument: \"%d\")
  82 as input.  The output must be the Face header data on stdout in
  83 PNG format."
  84   :version "22.1"
  85   :group 'gnus-fun
  86   :type '(choice (const :tag "djpeg, netpbm (JPG input only)"
  87                         "djpeg %s | ppmnorm | pnmscale -width 48 -height 48 | ppmquant %d | pnmtopng")
  88                  (const :tag "convert"
  89                         "convert -scale 48x48! %s -colors %d png:-")
  90                  (string)))
  91
  92 (defun gnus-shell-command-to-string (command)
  93   "Like `shell-command-to-string' except not mingling ERROR."
  94   (with-output-to-string
  95     (call-process shell-file-name nil (list standard-output nil)
  96                   nil shell-command-switch command)))
  97
  98 ;;;###autoload
  99 (defun gnus--random-face-with-type (dir ext omit fun)
 100   "Return file from DIR with extension EXT, omitting matches of OMIT, processed by FUN."
 101   (when (file-exists-p dir)
 102     (let* ((files
 103             (remove nil (mapcar
 104                          (lambda (f) (unless (string-match (or omit "^$") f) f))
 105                          (directory-files dir t ext))))
 106            (file (nth (random (length files)) files)))
 107       (when file
 108         (funcall fun file)))))
 109
 110 ;;;###autoload
 111 (autoload 'message-goto-eoh "message" nil t)
 112 (autoload 'message-insert-header "message" nil t)
 113
 114 (defun gnus--insert-random-face-with-type (fun type)
 115   "Get a random face using FUN and insert it as a header TYPE.
 116
 117 For instance, to insert an X-Face use `gnus-random-x-face' as FUN
 118   and \"X-Face\" as TYPE."
 119   (let ((data (funcall fun)))
 120     (save-excursion
 121       (if data
 122           (progn (message-goto-eoh)
 123                  (insert  type ": " data "\n"))
 124         (message
 125          "No face returned by the function %s." (symbol-name fun))))))
 126
 127
 128
 129 ;;;###autoload
 130 (defun gnus-random-x-face ()
 131   "Return X-Face header data chosen randomly from `gnus-x-face-directory'.
 132
 133 Files matching `gnus-x-face-omit-files' are not considered."
 134   (interactive)
 135   (gnus--random-face-with-type gnus-x-face-directory "\\.pbm$" gnus-x-face-omit-files
 136                          (lambda (file)
 137                            (gnus-shell-command-to-string
 138                             (format gnus-convert-pbm-to-x-face-command
 139                                     (shell-quote-argument file))))))
 140
 141 ;;;###autoload
 142 (defun gnus-insert-random-x-face-header ()
 143   "Insert a random X-Face header from `gnus-x-face-directory'."
 144   (interactive)
 145   (gnus--insert-random-face-with-type 'gnus-random-x-face 'X-Face))
 146
 147 ;;;###autoload
 148 (defun gnus-x-face-from-file (file)
 149   "Insert an X-Face header based on an image FILE.
 150
 151 Depending on `gnus-convert-image-to-x-face-command' it may accept
 152 different input formats."
 153   (interactive "fImage file name: ")
 154   (when (file-exists-p file)
 155     (gnus-shell-command-to-string
 156      (format gnus-convert-image-to-x-face-command
 157              (shell-quote-argument (expand-file-name file))))))
 158
 159 ;;;###autoload
 160 (defun gnus-face-from-file (file)
 161   "Return a Face header based on an image FILE.
 162
 163 Depending on `gnus-convert-image-to-face-command' it may accept
 164 different input formats."
 165   (interactive "fImage file name: ")
 166   (when (file-exists-p file)
 167     (let ((done nil)
 168           (attempt "")
 169           (quant 16))
 170       (while (and (not done)
 171                   (> quant 1))
 172         (setq attempt
 173               (let ((coding-system-for-read 'binary))
 174                 (gnus-shell-command-to-string
 175                  (format gnus-convert-image-to-face-command
 176                          (shell-quote-argument (expand-file-name file))
 177                          quant))))
 178         (if (> (length attempt) 726)
 179             (progn
 180               (setq quant (- quant (if (< quant 10) 1 2)))
 181               (gnus-message 9 "Length %d; trying quant %d"
 182                             (length attempt) quant))
 183           (setq done t)))
 184       (if done
 185           (mm-with-unibyte-buffer
 186             (insert attempt)
 187             (gnus-face-encode))
 188         nil))))
 189
 190 (defun gnus-face-encode ()
 191   (let ((step 72))
 192     (base64-encode-region (point-min) (point-max))
 193     (goto-char (point-min))
 194     (while (search-forward "\n" nil t)
 195       (replace-match ""))
 196     (goto-char (point-min))
 197     (while (> (- (point-max) (point))
 198               step)
 199       (forward-char step)
 200       (insert "\n ")
 201       (setq step 76))
 202     (buffer-string)))
 203
 204 ;;;###autoload
 205 (defun gnus-convert-face-to-png (face)
 206   "Convert FACE (which is base64-encoded) to a PNG.
 207 The PNG is returned as a string."
 208   (mm-with-unibyte-buffer
 209     (insert face)
 210     (ignore-errors
 211       (base64-decode-region (point-min) (point-max)))
 212     (buffer-string)))
 213
 214 ;;;###autoload
 215 (defun gnus-convert-png-to-face (file)
 216   "Convert FILE to a Face.
 217 FILE should be a PNG file that's 48x48 and smaller than or equal to
 218 726 bytes."
 219   (mm-with-unibyte-buffer
 220     (insert-file-contents file)
 221     (when (> (buffer-size) 726)
 222       (error "The file is %d bytes long, which is too long"
 223              (buffer-size)))
 224     (gnus-face-encode)))
 225
 226 ;;;###autoload
 227 (defun gnus-random-face ()
 228   "Return randomly chosen Face from `gnus-face-directory'.
 229
 230 Files matching `gnus-face-omit-files' are not considered."
 231   (interactive)
 232   (gnus--random-face-with-type gnus-face-directory "\\.png$"
 233                          gnus-face-omit-files
 234                          'gnus-convert-png-to-face))
 235
 236 ;;;###autoload
 237 (defun gnus-insert-random-face-header ()
 238   "Insert a random Face header from `gnus-face-directory'."
 239   (gnus--insert-random-face-with-type 'gnus-random-face 'Face))
 240
 241 (defface gnus-x-face '((t (:foreground "black" :background "white")))
 242   "Face to show X-Face.
 243 The colors from this face are used as the foreground and background
 244 colors of the displayed X-Faces."
 245   :group 'gnus-article-headers)
 246
 247 (declare-function article-narrow-to-head   "gnus-art" ())
 248 (declare-function gnus-article-goto-header "gnus-art" (header))
 249 (declare-function gnus-add-image           "gnus-art" (category image))
 250 (declare-function gnus-add-wash-type       "gnus-art" (type))
 251
 252 (defun gnus-display-x-face-in-from (data)
 253   "Display the X-Face DATA in the From header."
 254   (require 'gnus-art)
 255   (let (pbm)
 256     (when (or (gnus-image-type-available-p 'xface)
 257               (and (gnus-image-type-available-p 'pbm)
 258                    (setq pbm (uncompface data))))
 259       (save-excursion
 260         (save-restriction
 261           (article-narrow-to-head)
 262           (gnus-article-goto-header "from")
 263           (when (bobp)
 264             (insert "From: [no 'from' set]\n")
 265             (forward-char -17))
 266           (gnus-add-image
 267            'xface
 268            (gnus-put-image
 269             (if (gnus-image-type-available-p 'xface)
 270                 (apply 'gnus-create-image (concat "X-Face: " data) 'xface t
 271                        (cdr (assq 'xface gnus-face-properties-alist)))
 272               (apply 'gnus-create-image pbm 'pbm t
 273                      (cdr (assq 'pbm gnus-face-properties-alist))))
 274             nil 'xface))
 275           (gnus-add-wash-type 'xface))))))
 276
 277 (defun gnus-grab-cam-x-face ()
 278   "Grab a picture off the camera and make it into an X-Face."
 279   (interactive)
 280   (shell-command "xawtv-remote snap ppm")
 281   (let ((file nil))
 282     (while (null (setq file (directory-files "/tftpboot/sparky/tmp"
 283                                              t "snap.*ppm")))
 284       (sleep-for 1))
 285     (setq file (car file))
 286     (with-temp-buffer
 287       (shell-command
 288        (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"
 289                file)
 290        (current-buffer))
 291       ;;(sleep-for 3)
 292       (delete-file file)
 293       (buffer-string))))
 294
 295 (defun gnus-grab-cam-face ()
 296   "Grab a picture off the camera and make it into an X-Face."
 297   (interactive)
 298   (shell-command "xawtv-remote snap ppm")
 299   (let ((file nil)
 300         (tempfile (make-temp-file "gnus-face-" nil ".ppm"))
 301         result)
 302     (while (null (setq file (directory-files "/tftpboot/sparky/tmp"
 303                                              t "snap.*ppm")))
 304       (sleep-for 1))
 305     (setq file (car file))
 306     (shell-command
 307      (format "pnmcut -left 110 -top 30 -width 144 -height 144 '%s' | pnmscale -width 48 -height 48 | ppmtopgm >> %s"
 308              file tempfile))
 309     (let ((gnus-convert-image-to-face-command
 310            (format "cat '%%s' | ppmquant %%d | ppmchange %s | pnmtopng"
 311                    (gnus-fun-ppm-change-string))))
 312       (setq result (gnus-face-from-file tempfile)))
 313     (delete-file file)
 314     ;;(delete-file tempfile)    ; FIXME why are we not deleting it?!
 315     result))
 316
 317 (defun gnus-fun-ppm-change-string ()
 318   (let* ((possibilities '("%02x0000" "00%02x00" "0000%02x"
 319                           "%02x%02x00" "00%02x%02x" "%02x00%02x"))
 320          (format (concat "'#%02x%02x%02x' '#"
 321                          (nth (random 6) possibilities)
 322                          "'"))
 323          (values nil))
 324   (dotimes (i 255)
 325     (push (format format i i i i i i)
 326           values))
 327   (mapconcat 'identity values " ")))
 328
 329 (defun gnus-funcall-no-warning (function &rest args)
 330   (when (fboundp function)
 331     (apply function args)))
 332
 333 (provide 'gnus-fun)
 334
 335 ;;; gnus-fun.el ends here