X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fgnus-fun.el;h=f5e1c5ad69142a198ca088c62735e2065ee03919;hp=9fcb8394216e31449c9b5fcb5ad3cdd441cccb46;hb=4701091fb20fe41f824040bd0ce4513a58b00468;hpb=4e6ed4bd8e175ab78acf62b8f5e9a8af0e703992 diff --git a/lisp/gnus-fun.el b/lisp/gnus-fun.el index 9fcb83942..f5e1c5ad6 100644 --- a/lisp/gnus-fun.el +++ b/lisp/gnus-fun.el @@ -1,53 +1,83 @@ -;;; 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-2012 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: +;; For Emacs <22.2 and XEmacs. +(eval-and-compile + (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) + +(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-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,13 +85,6 @@ 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-x-face () "Return X-Face header data chosen randomly from `gnus-x-face-directory'." @@ -74,6 +97,8 @@ Output to the current buffer, replace text, and don't mingle error." (format gnus-convert-pbm-to-x-face-command (shell-quote-argument file))))))) +(autoload 'message-goto-eoh "message" nil t) + ;;;###autoload (defun gnus-insert-random-x-face-header () "Insert a random X-Face header from `gnus-x-face-directory'." @@ -89,8 +114,11 @@ Output to the current buffer, replace text, and don't mingle error." ;;;###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 +126,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 +138,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,14 +179,14 @@ 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))) @@ -165,10 +197,15 @@ 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)))) @@ -183,11 +220,11 @@ colors of the displayed X-Faces." '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 () @@ -219,15 +256,32 @@ colors of the displayed X-Faces." (sleep-for 1)) (setq file (car file)) (shell-command - (format "pnmcut -left 110 -top 30 -width 144 -height 144 '%s' | ppmnorm 2>/dev/null | ppmnorm | ppmtopgm | pnmscale -width 48 -height 48 > /tmp/gnus.face.ppm" + (format "pnmcut -left 110 -top 30 -width 144 -height 144 '%s' | pnmscale -width 48 -height 48 | ppmtopgm > /tmp/gnus.face.ppm" file)) (let ((gnus-convert-image-to-face-command - "cat '%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"))) (delete-file file) ;;(delete-file "/tmp/gnus.face.ppm") result)) +(defun gnus-fun-ppm-change-string () + (let* ((possibilities '("%02x0000" "00%02x00" "0000%02x" + "%02x%02x00" "00%02x%02x" "%02x00%02x")) + (format (concat "'#%02x%02x%02x' '#" + (nth (random 6) possibilities) + "'")) + (values nil)) + (dotimes (i 255) + (push (format format i i i i i i) + 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