X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-fun.el;h=0f28bf5e5eaea9c94189f18a9d420140035c8a03;hb=06b90ae8fdfbe69d395e9d8cc1c0854d3b1d7b42;hp=aa711da04e57bd3440d9a3f1ef2b55839db8c905;hpb=2374477d8a9f3aac2ac29f51c10e5d16686b33c3;p=gnus diff --git a/lisp/gnus-fun.el b/lisp/gnus-fun.el index aa711da04..0f28bf5e5 100644 --- a/lisp/gnus-fun.el +++ b/lisp/gnus-fun.el @@ -1,49 +1,86 @@ -;;; gnus-fun.el --- various frivoluos extension functions to Gnus -;; Copyright (C) 2002 Free Software Foundation, Inc. +;;; gnus-fun.el --- various frivolous extension functions to Gnus + +;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 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" - "Command for converting a GIF to an X-Face." +(defcustom gnus-convert-image-to-x-face-command + "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." + :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 a GIF to an X-Face." +(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." @@ -60,7 +97,7 @@ Output to the current buffer, replace text, and don't mingle error." ;;;###autoload (defun gnus-random-x-face () - "Insert a random X-Face header from `gnus-x-face-directory'." + "Return X-Face header data chosen randomly from `gnus-x-face-directory'." (interactive) (when (file-exists-p gnus-x-face-directory) (let* ((files (directory-files gnus-x-face-directory t "\\.pbm$")) @@ -70,157 +107,99 @@ 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'." + (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))))) + ;;;###autoload (defun gnus-x-face-from-file (file) - "Insert an X-Face header based on an image file." - (interactive "fImage file name:" ) + "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 - (shell-quote-argument file))))) + (shell-quote-argument (expand-file-name file)))))) +;;;###autoload (defun gnus-face-from-file (file) - "Return an Face header based on an image file." - (interactive "fImage file name:" ) + "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 "") - (step 72) (quant 16)) (while (and (not done) (> quant 1)) (setq attempt - (gnus-shell-command-to-string - (format gnus-convert-image-to-face-command - (shell-quote-argument 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) - (base64-encode-region (point-min) (point-max)) - (goto-char (point-min)) - (while (search-forward "\n" nil t) - (replace-match "")) - (goto-char (point-min)) - (while (> (- (point-max) (point)) - step) - (forward-char step) - (insert "\n ") - (setq step 76)) - (buffer-string)) + (gnus-face-encode)) nil)))) +(defun gnus-face-encode () + (let ((step 72)) + (base64-encode-region (point-min) (point-max)) + (goto-char (point-min)) + (while (search-forward "\n" nil t) + (replace-match "")) + (goto-char (point-min)) + (while (> (- (point-max) (point)) + step) + (forward-char step) + (insert "\n ") + (setq step 76)) + (buffer-string))) + ;;;###autoload (defun gnus-convert-face-to-png (face) + "Convert FACE (which is base64-encoded) to a PNG. +The PNG is returned as a string." (mm-with-unibyte-buffer (insert face) - (base64-decode-region (point-min) (point-max)) + (ignore-errors + (base64-decode-region (point-min) (point-max))) (buffer-string))) -(defun gnus-convert-image-to-gray-x-face (file depth) - (let* ((mapfile (mm-make-temp-file (expand-file-name "gnus." - mm-tmp-directory))) - (levels (expt 2 depth)) - (step (/ 255 (1- levels))) - color-alist bits bits-list mask pixel x-faces) - (with-temp-file mapfile - (insert "P3\n") - (insert (format "%d 1\n" levels)) - (insert "255\n") - (dotimes (i levels) - (insert (format "%d %d %d\n" - (* step i) (* step i) (* step i))) - (push (cons (* step i) i) color-alist))) - (when (file-exists-p file) - (with-temp-buffer - (insert (gnus-shell-command-to-string - (format "giftopnm %s | ppmnorm | pnmscale -width 48 -height 48 | ppmquant -fs -map %s | ppmtopgm | pnmnoraw" - (shell-quote-argument file) - mapfile))) - (goto-char (point-min)) - (forward-line 3) - (while (setq pixel (ignore-errors (read (current-buffer)))) - (push (cdr (assq pixel color-alist)) bits-list)) - (setq bits-list (nreverse bits-list)) - (dotimes (bit-number depth) - (setq mask (expt 2 bit-number)) - (with-temp-buffer - (insert "P1\n48 48\n") - (dolist (bits bits-list) - (insert (if (zerop (logand bits mask)) "0 " "1 "))) - (gnus-shell-command-on-region - (point-min) (point-max) - ;; the following is taken from xbmtoikon: - "pbmtoicon | sed '/^[ ]*[*\\\\/]/d; s/[ ]//g; s/,$//' | tr , '\\012' | sed 's/^0x//; s/^/0x/' | pr -l1 -t -w22 -3 -s, | sed 's/,*$/,/' | compface") - (push (buffer-string) x-faces)))) - (dotimes (i (length x-faces)) - (insert (if (zerop i) "X-Face:" (format "X-Face-%s:" i)) - (nth i x-faces)))) - (delete-file mapfile))) - ;;;###autoload -(defun gnus-convert-gray-x-face-to-xpm (faces) - (let* ((depth (length faces)) - (scale (/ 255 (1- (expt 2 depth)))) - (ok-p t) - (coding-system-for-read 'binary) - (coding-system-for-write 'binary) - default-enable-multibyte-characters - start bit-array bit-arrays pixel) - (with-temp-buffer - (dolist (face faces) - (erase-buffer) - (insert (uncompface face)) - (gnus-shell-command-on-region - (point-min) (point-max) - "pnmnoraw") - (goto-char (point-min)) - (forward-line 2) - (setq start (point)) - (insert "[") - (while (not (eobp)) - (forward-char 1) - (insert " ")) - (insert "]") - (goto-char start) - (setq bit-array (read (current-buffer))) - (unless (= (length bit-array) (* 48 48)) - (setq ok-p nil)) - (push bit-array bit-arrays)) - (when ok-p - (erase-buffer) - (insert "P2\n48 48\n255\n") - (dotimes (i (* 48 48)) - (setq pixel 0) - (dotimes (plane depth) - (setq pixel (+ (* pixel 2) (aref (nth plane bit-arrays) i)))) - (insert (number-to-string (* scale pixel)) " ")) - (gnus-shell-command-on-region - (point-min) (point-max) - "ppmtoxpm") - (buffer-string))))) - -;;;###autoload -(defun gnus-convert-gray-x-face-region (beg end) - "Convert the X-Faces in region to a PPM file." - (interactive "r") - (let ((input (buffer-substring beg end)) - faces) - (with-temp-buffer - (insert input) - (goto-char (point-min)) - (while (not (eobp)) - (save-restriction - (mail-header-narrow-to-field) - (push (mail-header-field-value) faces) - (goto-char (point-max))))) - (gnus-convert-gray-x-face-to-xpm faces))) +(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 +726 bytes." + (mm-with-unibyte-buffer + (insert-file-contents file) + (when (> (buffer-size) 726) + (error "The file is %d bytes long, which is too long" + (buffer-size))) + (gnus-face-encode))) (defface gnus-x-face '((t (:foreground "black" :background "white"))) "Face to show X-Face. @@ -228,10 +207,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)))) @@ -246,11 +230,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 () @@ -271,23 +255,38 @@ colors of the displayed X-Faces." (delete-file file) (buffer-string)))) -(defun gnus-grab-gray-x-face () +(defun gnus-grab-cam-face () "Grab a picture off the camera and make it into an X-Face." (interactive) (shell-command "xawtv-remote snap ppm") - (let ((file nil)) + (let ((file nil) + result) (while (null (setq file (directory-files "/tftpboot/sparky/tmp" t "snap.*ppm"))) (sleep-for 1)) (setq file (car file)) - (with-temp-buffer - (shell-command - (format "pnmcut -left 70 -top 100 -width 144 -height 144 '%s' | ppmquant 256 2>/dev/null | ppmtogif > '%s.gif'" - file file) - (current-buffer)) - (delete-file file)) - (gnus-convert-image-to-gray-x-face (concat file ".gif") 3) - (delete-file (concat file ".gif")))) + (shell-command + (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 + (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* ((possibilites '("%02x0000" "00%02x00" "0000%02x" + "%02x%02x00" "00%02x%02x" "%02x00%02x")) + (format (concat "'#%02x%02x%02x' '#" + (nth (random 6) possibilites) + "'")) + (values nil)) + (dotimes (i 255) + (push (format format i i i i i i) + values)) + (mapconcat 'identity values " "))) (provide 'gnus-fun)