(gnus-convert-face-to-png): Protect against errors.

[gnus] / lisp / gnus-fun.el

diff --git a/lisp/gnus-fun.el b/lisp/gnus-fun.el
index c1d6cd8..a3d41c6 100644 (file)
--- a/lisp/gnus-fun.el
+++ b/lisp/gnus-fun.el
@@ -36,26 +36,31 @@
   :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."
+  "Command for converting an image to an X-Face."
+  :group 'gnus-fun
+  :type '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 X-Face."
   :group 'gnus-fun
   :type 'string)
 
 (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) 
+    (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) 
+  (call-process-region start end shell-file-name t
+                      (list (current-buffer) nil)
                       nil shell-command-switch command))
 
 ;;;###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$"))
@@ -65,17 +70,77 @@ 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
+(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:" )
+  (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: ")
+  (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 (expand-file-name file))
+                      quant)))
+       (if (> (length attempt) 740)
+           (progn
+             (setq quant (- quant 2))
+             (message "Length %d; trying quant %d"
+                      (length attempt) quant))
+         (setq done t)))
+      (if done
+         (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))
+       nil))))
+
+;;;###autoload
+(defun gnus-convert-face-to-png (face)
+  (mm-with-unibyte-buffer
+    (insert face)
+    (ignore-errors
+      (base64-decode-region (point-min) (point-max)))
+    (buffer-string)))
 
 (defun gnus-convert-image-to-gray-x-face (file depth)
-  (let* ((mapfile (make-temp-name (expand-file-name "gnus." mm-tmp-directory)))
+  (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)
@@ -122,7 +187,7 @@ Output to the current buffer, replace text, and don't mingle error."
         (coding-system-for-read 'binary)
         (coding-system-for-write 'binary)
         default-enable-multibyte-characters
-        start bit-array bit-arrays pixels pixel)
+        start bit-array bit-arrays pixel)
     (with-temp-buffer
       (dolist (face faces)
        (erase-buffer)
@@ -189,7 +254,7 @@ colors of the displayed X-Faces."
        (save-restriction
          (article-narrow-to-head)
          (gnus-article-goto-header "from")
-         (when (bobp) 
+         (when (bobp)
            (insert "From: [no `from' set]\n")
            (forward-char -17))
          (gnus-add-image