X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-fun.el;h=d6b4fba6246e9c785fe9b9df4cc313b287e86061;hb=53195fc045a4fe12bf4593780b268850489ddf7d;hp=fe39d859d8dabfd14afe653e879414a3dc7a7c1a;hpb=ec1bd8420fe770918f618ed280e2551076d28923;p=gnus diff --git a/lisp/gnus-fun.el b/lisp/gnus-fun.el index fe39d859d..d6b4fba62 100644 --- a/lisp/gnus-fun.el +++ b/lisp/gnus-fun.el @@ -1,26 +1,24 @@ ;;; gnus-fun.el --- various frivolous extension functions to Gnus -;; Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc. +;; Copyright (C) 2002-2014 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., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. +;; along with GNU Emacs. If not, see . ;;; Commentary: @@ -32,6 +30,9 @@ (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." @@ -39,6 +40,24 @@ :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 "24.5" + :group 'gnus-fun + :type 'string) + +(defcustom gnus-face-directory (expand-file-name "faces" gnus-directory) + "*Directory where Face PNG files are stored." + :version "24.5" + :group 'gnus-fun + :type 'directory) + +(defcustom gnus-face-omit-files nil + "Regexp to match faces in `gnus-face-directory' to be omitted." + :version "24.5" + :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" @@ -49,10 +68,7 @@ "convert -scale 48x48! %s xbm:- | xbm2xface.pl" "Command for converting an image to an X-Face. The command must take a image filename (use \"%s\") as input. -The output must be the Face header data on stdout in PNG format. - -By default it takes a GIF filename and output the X-Face header data -on stdout." +The output must be the X-Face header data on stdout." :version "22.1" :group 'gnus-fun :type '(choice (const :tag "giftopnm, netpbm (GIF input only)" @@ -65,10 +81,10 @@ on stdout." "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." +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 '(choice (const :tag "djpeg, netpbm (JPG input only)" @@ -77,71 +93,64 @@ stdout in PNG format." "convert -scale 48x48! %s -colors %d png:-") (string))) -(defcustom gnus-face-properties-alist (if (featurep 'xemacs) - '((xface . (:face gnus-x-face))) - '((pbm . (:face gnus-x-face)) - (png . nil))) - "Alist of image types and properties applied to Face and X-Face images. -Here are examples: - -;; Specify the altitude of Face images in the From header. -\(setq gnus-face-properties-alist - '((pbm . (:face gnus-x-face :ascent 80)) - (png . (:ascent 80)))) - -;; Show Face images as pressed buttons. -\(setq gnus-face-properties-alist - '((pbm . (:face gnus-x-face :relief -2)) - (png . (:relief -2)))) - -See the manual for the valid properties for various image types. -Currently, `pbm' is used for X-Face images and `png' is used for Face -images in Emacs. Only the `:face' property is effective on the `xface' -image type in XEmacs if it is built with the libcompface library." - :group 'gnus-fun - :type '(repeat (cons :format "%v" (symbol :tag "Image type") plist))) - (defun gnus-shell-command-to-string (command) "Like `shell-command-to-string' except not mingling ERROR." (with-output-to-string (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. + "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." @@ -153,7 +162,7 @@ different input formats." ;;;###autoload (defun gnus-face-from-file (file) - "Return a Face header based on an image file. + "Return a Face header based on an image FILE. Depending on `gnus-convert-image-to-face-command' it may accept different input formats." @@ -172,7 +181,7 @@ different input formats." quant)))) (if (> (length attempt) 726) (progn - (setq quant (- quant 2)) + (setq quant (- quant (if (< quant 10) 1 2))) (gnus-message 9 "Length %d; trying quant %d" (length attempt) quant)) (setq done t))) @@ -218,16 +227,36 @@ FILE should be a PNG file that's 48x48 and smaller than or equal to (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 randome 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)))) @@ -289,10 +318,10 @@ colors of the displayed X-Faces." 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) @@ -300,7 +329,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) -;;; arch-tag: 9d000a69-15cc-4491-9dc0-4627484f50c1 ;;; gnus-fun.el ends here