X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fgnus-fun.el;h=fa78b5c6e1580ff9ba4104ae7466ff2d6984bce5;hp=f8afca862bdfddbb314ebd73b3f3f4f37b39882f;hb=b52037f4a9c6bee1ff556c22750e158da1208d4b;hpb=d8548da3c081184bb84c45a5168a17f2355042cf diff --git a/lisp/gnus-fun.el b/lisp/gnus-fun.el index f8afca862..fa78b5c6e 100644 --- a/lisp/gnus-fun.el +++ b/lisp/gnus-fun.el @@ -1,53 +1,97 @@ -;;; gnus-fun.el --- various frivoluos extension functions to Gnus -;; Copyright (C) 2002, 2003 Free Software Foundation, Inc. +;;; gnus-fun.el --- various frivolous extension functions to Gnus + +;; Copyright (C) 2002-2016 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; GNU Emacs is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; along with GNU Emacs. If not, see . ;;; Commentary: ;;; Code: +(eval-when-compile + (require 'cl)) + +(require 'mm-util) +(require 'gnus-ems) +(require 'gnus-util) +(require 'gnus) + +(defvar gnus-face-properties-alist) + (defcustom gnus-x-face-directory (expand-file-name "x-faces" gnus-directory) "*Directory where X-Face PBM files are stored." + :version "22.1" :group 'gnus-fun :type 'directory) +(defcustom gnus-x-face-omit-files nil + "Regexp to match faces in `gnus-x-face-directory' to be omitted." + :version "25.1" + :group 'gnus-fun + :type 'string) + +(defcustom gnus-face-directory (expand-file-name "faces" gnus-directory) + "*Directory where Face PNG files are stored." + :version "25.1" + :group 'gnus-fun + :type 'directory) + +(defcustom gnus-face-omit-files nil + "Regexp to match faces in `gnus-face-directory' to be omitted." + :version "25.1" + :group 'gnus-fun + :type 'string) + (defcustom gnus-convert-pbm-to-x-face-command "pbmtoxbm %s | compface" "Command for converting a PBM to an X-Face." + :version "22.1" :group 'gnus-fun :type 'string) -(defcustom gnus-convert-image-to-x-face-command "giftopnm %s | ppmnorm | pnmscale -width 48 -height 48 | ppmtopgm | pgmtopbm | pbmtoxbm | compface" +(defcustom gnus-convert-image-to-x-face-command + "convert -scale 48x48! %s xbm:- | xbm2xface.pl" "Command for converting an image to an X-Face. -By default it takes a GIF filename and output the X-Face header data -on stdout." +The command must take a image filename (use \"%s\") as input. +The output must be the X-Face header data on stdout." + :version "22.1" :group 'gnus-fun - :type 'string) + :type '(choice (const :tag "giftopnm, netpbm (GIF input only)" + "giftopnm %s | ppmnorm | pnmscale -width 48 -height 48 | ppmtopgm | pgmtopbm | pbmtoxbm | compface") + (const :tag "convert" + "convert -scale 48x48! %s xbm:- | xbm2xface.pl") + (string))) -(defcustom gnus-convert-image-to-face-command "djpeg %s | ppmnorm | pnmscale -width 48 -height 48 | ppmquant %d | pnmtopng" - "Command for converting an image to an Face. -By default it takes a JPEG filename and output the Face header data -on stdout." +(defcustom gnus-convert-image-to-face-command + "convert -scale 48x48! %s -colors %d png:-" + "Command for converting an image to a Face. + +The command must take an image filename (first format argument +\"%s\") and the number of colors (second format argument: \"%d\") +as input. The output must be the Face header data on stdout in +PNG format." + :version "22.1" :group 'gnus-fun - :type 'string) + :type '(choice (const :tag "djpeg, netpbm (JPG input only)" + "djpeg %s | ppmnorm | pnmscale -width 48 -height 48 | ppmquant %d | pnmtopng") + (const :tag "convert" + "convert -scale 48x48! %s -colors %d png:-") + (string))) (defun gnus-shell-command-to-string (command) "Like `shell-command-to-string' except not mingling ERROR." @@ -55,42 +99,62 @@ on stdout." (call-process shell-file-name nil (list standard-output nil) nil shell-command-switch command))) -(defun gnus-shell-command-on-region (start end command) - "A simplified `shell-command-on-region'. -Output to the current buffer, replace text, and don't mingle error." - (call-process-region start end shell-file-name t - (list (current-buffer) nil) - nil shell-command-switch command)) +;;;###autoload +(defun gnus--random-face-with-type (dir ext omit fun) + "Return file from DIR with extension EXT, omitting matches of OMIT, processed by FUN." + (when (file-exists-p dir) + (let* ((files + (remove nil (mapcar + (lambda (f) (unless (string-match (or omit "^$") f) f)) + (directory-files dir t ext)))) + (file (nth (random (length files)) files))) + (when file + (funcall fun file))))) + +;;;###autoload +(autoload 'message-goto-eoh "message" nil t) +(autoload 'message-insert-header "message" nil t) + +(defun gnus--insert-random-face-with-type (fun type) + "Get a random face using FUN and insert it as a header TYPE. + +For instance, to insert an X-Face use `gnus-random-x-face' as FUN + and \"X-Face\" as TYPE." + (let ((data (funcall fun))) + (save-excursion + (if data + (progn (message-goto-eoh) + (insert type ": " data "\n")) + (message + "No face returned by the function %s." (symbol-name fun)))))) + + ;;;###autoload (defun gnus-random-x-face () - "Return X-Face header data chosen randomly from `gnus-x-face-directory'." + "Return X-Face header data chosen randomly from `gnus-x-face-directory'. + +Files matching `gnus-x-face-omit-files' are not considered." (interactive) - (when (file-exists-p gnus-x-face-directory) - (let* ((files (directory-files gnus-x-face-directory t "\\.pbm$")) - (file (nth (random (length files)) files))) - (when file - (gnus-shell-command-to-string - (format gnus-convert-pbm-to-x-face-command - (shell-quote-argument file))))))) + (gnus--random-face-with-type gnus-x-face-directory "\\.pbm$" gnus-x-face-omit-files + (lambda (file) + (gnus-shell-command-to-string + (format gnus-convert-pbm-to-x-face-command + (shell-quote-argument file)))))) ;;;###autoload (defun gnus-insert-random-x-face-header () "Insert a random X-Face header from `gnus-x-face-directory'." (interactive) - (let ((data (gnus-random-x-face))) - (save-excursion - (message-goto-eoh) - (if data - (insert "X-Face: " data) - (message - "No face returned by `gnus-random-x-face'. Does %s/*.pbm exist?" - gnus-x-face-directory))))) + (gnus--insert-random-face-with-type 'gnus-random-x-face 'X-Face)) ;;;###autoload (defun gnus-x-face-from-file (file) - "Insert an X-Face header based on an image file." - (interactive "fImage file name (by default GIF): ") + "Insert an X-Face header based on an image FILE. + +Depending on `gnus-convert-image-to-x-face-command' it may accept +different input formats." + (interactive "fImage file name: ") (when (file-exists-p file) (gnus-shell-command-to-string (format gnus-convert-image-to-x-face-command @@ -98,8 +162,11 @@ Output to the current buffer, replace text, and don't mingle error." ;;;###autoload (defun gnus-face-from-file (file) - "Return an Face header based on an image file." - (interactive "fImage file name (by default JPEG): ") + "Return a Face header based on an image FILE. + +Depending on `gnus-convert-image-to-face-command' it may accept +different input formats." + (interactive "fImage file name: ") (when (file-exists-p file) (let ((done nil) (attempt "") @@ -107,18 +174,19 @@ Output to the current buffer, replace text, and don't mingle error." (while (and (not done) (> quant 1)) (setq attempt - (gnus-shell-command-to-string - (format gnus-convert-image-to-face-command - (shell-quote-argument (expand-file-name file)) - quant))) - (if (> (length attempt) 740) + (let ((coding-system-for-read 'binary)) + (gnus-shell-command-to-string + (format gnus-convert-image-to-face-command + (shell-quote-argument (expand-file-name file)) + quant)))) + (if (> (length attempt) 726) (progn - (setq quant (- quant 2)) - (message "Length %d; trying quant %d" - (length attempt) quant)) + (setq quant (- quant (if (< quant 10) 1 2))) + (gnus-message 9 "Length %d; trying quant %d" + (length attempt) quant)) (setq done t))) (if done - (mm-with-unibyte-buffer + (mm-with-unibyte-buffer (insert attempt) (gnus-face-encode)) nil)))) @@ -147,28 +215,48 @@ The PNG is returned as a string." (base64-decode-region (point-min) (point-max))) (buffer-string))) -;;;#autoload +;;;###autoload (defun gnus-convert-png-to-face (file) "Convert FILE to a Face. FILE should be a PNG file that's 48x48 and smaller than or equal to -740 bytes." +726 bytes." (mm-with-unibyte-buffer (insert-file-contents file) - (when (> (buffer-size) 740) + (when (> (buffer-size) 726) (error "The file is %d bytes long, which is too long" (buffer-size))) (gnus-face-encode))) +;;;###autoload +(defun gnus-random-face () + "Return randomly chosen Face from `gnus-face-directory'. + +Files matching `gnus-face-omit-files' are not considered." + (interactive) + (gnus--random-face-with-type gnus-face-directory "\\.png$" + gnus-face-omit-files + 'gnus-convert-png-to-face)) + +;;;###autoload +(defun gnus-insert-random-face-header () + "Insert a random Face header from `gnus-face-directory'." + (gnus--insert-random-face-with-type 'gnus-random-face 'Face)) + (defface gnus-x-face '((t (:foreground "black" :background "white"))) "Face to show X-Face. The colors from this face are used as the foreground and background colors of the displayed X-Faces." :group 'gnus-article-headers) +(declare-function article-narrow-to-head "gnus-art" ()) +(declare-function gnus-article-goto-header "gnus-art" (header)) +(declare-function gnus-add-image "gnus-art" (category image)) +(declare-function gnus-add-wash-type "gnus-art" (type)) + (defun gnus-display-x-face-in-from (data) "Display the X-Face DATA in the From header." - (let ((default-enable-multibyte-characters nil) - pbm) + (require 'gnus-art) + (let (pbm) (when (or (gnus-image-type-available-p 'xface) (and (gnus-image-type-available-p 'pbm) (setq pbm (uncompface data)))) @@ -177,17 +265,17 @@ colors of the displayed X-Faces." (article-narrow-to-head) (gnus-article-goto-header "from") (when (bobp) - (insert "From: [no `from' set]\n") + (insert "From: [no 'from' set]\n") (forward-char -17)) (gnus-add-image 'xface (gnus-put-image (if (gnus-image-type-available-p 'xface) - (gnus-create-image - (concat "X-Face: " data) - 'xface t :ascent 'center :face 'gnus-x-face) - (gnus-create-image - pbm 'pbm t :ascent 'center :face 'gnus-x-face)))) + (apply 'gnus-create-image (concat "X-Face: " data) 'xface t + (cdr (assq 'xface gnus-face-properties-alist))) + (apply 'gnus-create-image pbm 'pbm t + (cdr (assq 'pbm gnus-face-properties-alist)))) + nil 'xface)) (gnus-add-wash-type 'xface)))))) (defun gnus-grab-cam-x-face () @@ -213,27 +301,28 @@ colors of the displayed X-Faces." (interactive) (shell-command "xawtv-remote snap ppm") (let ((file nil) + (tempfile (make-temp-file "gnus-face-" nil ".ppm")) result) (while (null (setq file (directory-files "/tftpboot/sparky/tmp" t "snap.*ppm"))) (sleep-for 1)) (setq file (car file)) (shell-command - (format "pnmcut -left 110 -top 30 -width 144 -height 144 '%s' | ppmnorm 2>/dev/null | pnmscale -width 48 -height 48 | ppmtopgm > /tmp/gnus.face.ppm" - file)) + (format "pnmcut -left 110 -top 30 -width 144 -height 144 '%s' | pnmscale -width 48 -height 48 | ppmtopgm >> %s" + file tempfile)) (let ((gnus-convert-image-to-face-command - (format "cat '%%s' | ppmchange %s | ppmquant %%d | pnmtopng" + (format "cat '%%s' | ppmquant %%d | ppmchange %s | pnmtopng" (gnus-fun-ppm-change-string)))) - (setq result (gnus-face-from-file "/tmp/gnus.face.ppm"))) + (setq result (gnus-face-from-file tempfile))) (delete-file file) - ;;(delete-file "/tmp/gnus.face.ppm") + ;;(delete-file tempfile) ; FIXME why are we not deleting it?! result)) (defun gnus-fun-ppm-change-string () - (let* ((possibilites '("%02x0000" "00%02x00" "0000%02x" - "%02x%02x00" "00%02x%02x" "%02x00%02x")) + (let* ((possibilities '("%02x0000" "00%02x00" "0000%02x" + "%02x%02x00" "00%02x%02x" "%02x00%02x")) (format (concat "'#%02x%02x%02x' '#" - (nth (random 6) possibilites) + (nth (random 6) possibilities) "'")) (values nil)) (dotimes (i 255) @@ -241,6 +330,10 @@ colors of the displayed X-Faces." values)) (mapconcat 'identity values " "))) +(defun gnus-funcall-no-warning (function &rest args) + (when (fboundp function) + (apply function args))) + (provide 'gnus-fun) ;;; gnus-fun.el ends here