view lisp/mh-e/mh-xface.el @ 110410:f2e111723c3a

Merge changes made in Gnus trunk. Reimplement nnimap, and do tweaks to the rest of the code to support that. * gnus-int.el (gnus-finish-retrieve-group-infos) (gnus-retrieve-group-data-early): New functions. * gnus-range.el (gnus-range-nconcat): New function. * gnus-start.el (gnus-get-unread-articles): Support early retrieval of data. (gnus-read-active-for-groups): Support finishing the early retrieval of data. * gnus-sum.el (gnus-summary-move-article): Pass the move-to group name if the move is internal, so that nnimap can do fast internal moves. * gnus.el (gnus-article-special-mark-lists): Add uid/active tuples, for nnimap usage. * nnimap.el: Rewritten. * nnmail.el (nnmail-inhibit-default-split-group): New internal variable to allow the mail splitting to not return a default group. This is useful for nnimap, which will leave unmatched mail in the inbox. * utf7.el (utf7-encode): Autoload. Implement shell connection. * nnimap.el (nnimap-open-shell-stream): New function. (nnimap-open-connection): Use it. Get the number of lines by using BODYSTRUCTURE. (nnimap-transform-headers): Get the number of lines in each message. (nnimap-retrieve-headers): Query for BODYSTRUCTURE so that we get the number of lines. Not all servers return UIDNEXT. Work past this problem. Remove junk from end of file. Fix typo in "bogus" section. Make capabilties be case-insensitive. Require cl when compiling. Don't bug out if the LIST command doesn't have any parameters. 2010-09-17 Knut Anders Hatlen <[e-mail]> (tiny change) * nnimap.el (nnimap-get-groups): Don't bug out if the LIST command doesn't have any parameters. (mm-text-html-renderer): Document gnus-article-html. 2010-09-17 Julien Danjou <[e-mail]> (tiny fix) * mm-decode.el (mm-text-html-renderer): Document gnus-article-html. * dgnushack.el: Define netrc-credentials. If the user doesn't have a /etc/services, supply some sensible port defaults. Have `unseen-or-unread' select an unread unseen article first. (nntp-open-server): Return whether the open was successful or not. Throughout all files, replace (save-excursion (set-buffer ...)) with (with-current-buffer ... ). Save result so that it doesn't say "failed" all the time. Add ~/.authinfo to the default, since that's probably most useful for users. Don't use the "finish" method when we're reading from the agent. Add some more nnimap-relevant agent stuff to nnagent.el. * nnimap.el (nnimap-with-process-buffer): Removed. Revert one line that was changed by mistake in the last checkin. (nnimap-open-connection): Don't error out when we can't make a connection nnimap-related changes to avoid bugging out if we can't contact a server. * gnus-start.el (gnus-get-unread-articles): Don't try to scan groups from methods that are denied. * nnimap.el (nnimap-possibly-change-group): Return nil if we can't log in. (nnimap-finish-retrieve-group-infos): Make sure we're not waiting for nothing. * gnus-sum.el (gnus-select-newsgroup): Indent.

;;; mh-xface.el --- MH-E X-Face and Face header field display

;; Copyright (C) 2002, 2003, 2005, 2006, 2007, 2008, 2009, 2010
;;   Free Software Foundation, Inc.

;; Author: Bill Wohler <[e-mail]>
;; Maintainer: Bill Wohler <[e-mail]>
;; Keywords: mail
;; See: mh-e.el

;; This file is part of GNU Emacs.

;; 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 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
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;;; Change Log:

;;; Code:

(require 'mh-e)
(mh-require-cl)

(autoload 'message-fetch-field "message")

(defvar mh-show-xface-function
  (cond ((and (featurep 'xemacs) (locate-library "x-face") (not (featurep 'xface)))
         (load "x-face" t t)
         #'mh-face-display-function)
        ((>= emacs-major-version 21)
         #'mh-face-display-function)
        (t #'ignore))
  "Determine at run time what function should be called to display X-Face.")

(defvar mh-uncompface-executable
  (and (fboundp 'executable-find) (executable-find "uncompface")))



;;; X-Face Display

;;;###mh-autoload
(defun mh-show-xface ()
  "Display X-Face."
  (when (and window-system mh-show-use-xface-flag
             (or mh-decode-mime-flag mh-mhl-format-file
                 mh-clean-message-header-flag))
    (funcall mh-show-xface-function)))

(defun mh-face-display-function ()
  "Display a Face, X-Face, or X-Image-URL header field.
If more than one of these are present, then the first one found
in this order is used."
  (save-restriction
    (goto-char (point-min))
    (re-search-forward "\n\n" (point-max) t)
    (narrow-to-region (point-min) (point))
    (let* ((case-fold-search t)
           (face (message-fetch-field "face" t))
           (x-face (message-fetch-field "x-face" t))
           (url (message-fetch-field "x-image-url" t))
           raw type)
      (cond (face (setq raw (mh-face-to-png face)
                        type 'png))
            (x-face (setq raw (mh-uncompface x-face)
                          type 'pbm))
            (url (setq type 'url))
            (t (multiple-value-setq (type raw)
                 (values-list (mh-picon-get-image)))))
      (when type
        (goto-char (point-min))
        (when (re-search-forward "^from:" (point-max) t)
          ;; GNU Emacs
          (mh-do-in-gnu-emacs
            (if (eq type 'url)
                (mh-x-image-url-display url)
              (mh-funcall-if-exists
               insert-image (create-image
                             raw type t
                             :foreground
                             (mh-face-foreground 'mh-show-xface nil t)
                             :background
                             (mh-face-background 'mh-show-xface nil t))
               " ")))
          ;; XEmacs
          (mh-do-in-xemacs
            (cond
             ((eq type 'url)
              (mh-x-image-url-display url))
             ((eq type 'png)
              (when (featurep 'png)
                (set-extent-begin-glyph
                 (make-extent (point) (point))
                 (make-glyph (vector 'png ':data (mh-face-to-png face))))))
             ;; Try internal xface support if available...
             ((and (eq type 'pbm) (featurep 'xface))
              (set-glyph-face
               (set-extent-begin-glyph
                (make-extent (point) (point))
                (make-glyph (vector 'xface ':data (concat "X-Face: " x-face))))
               'mh-show-xface))
             ;; Otherwise try external support with x-face...
             ((and (eq type 'pbm)
                   (fboundp 'x-face-xmas-wl-display-x-face)
                   (fboundp 'executable-find) (executable-find "uncompface"))
              (mh-funcall-if-exists x-face-xmas-wl-display-x-face))
             ;; Picon display
             ((and raw (member type '(xpm xbm gif)))
              (when (featurep type)
                (set-extent-begin-glyph
                 (make-extent (point) (point))
                 (make-glyph (vector type ':data raw))))))
            (when raw (insert " "))))))))

(defun mh-face-to-png (data)
  "Convert base64 encoded DATA to png image."
  (with-temp-buffer
    (set-buffer-multibyte nil)
    (insert data)
    (ignore-errors (base64-decode-region (point-min) (point-max)))
    (buffer-string)))

(defun mh-uncompface (data)
  "Run DATA through `uncompface' to generate bitmap."
  (with-temp-buffer
    (set-buffer-multibyte nil)
    (insert data)
    (when (and mh-uncompface-executable
               (equal (call-process-region (point-min) (point-max)
                                           mh-uncompface-executable t '(t nil))
                      0))
      (mh-icontopbm)
      (buffer-string))))

(defun mh-icontopbm ()
  "Elisp substitute for `icontopbm'."
  (goto-char (point-min))
  (let ((end (point-max)))
    (while (re-search-forward "0x\\(..\\)\\(..\\)," nil t)
      (save-excursion
        (goto-char (point-max))
        (insert (string-to-number (match-string 1) 16))
        (insert (string-to-number (match-string 2) 16))))
    (delete-region (point-min) end)
    (goto-char (point-min))
    (insert "P4\n48 48\n")))



;;; Picon Display

;; XXX: This should be customizable. As a side-effect of setting this
;;   variable, arrange to reset mh-picon-existing-directory-list to 'unset.
(defvar mh-picon-directory-list
  '("~/.picons" "~/.picons/users" "~/.picons/usenix" "~/.picons/news"
    "~/.picons/domains" "~/.picons/misc"
    "/usr/share/picons/" "/usr/share/picons/users" "/usr/share/picons/usenix"
    "/usr/share/picons/news" "/usr/share/picons/domains"
    "/usr/share/picons/misc")
  "List of directories where picons reside.
The directories are searched for in the order they appear in the list.")

(defvar mh-picon-existing-directory-list 'unset
  "List of directories to search in.")

(defvar mh-picon-cache (make-hash-table :test #'equal))

(defvar mh-picon-image-types
  (loop for type in '(xpm xbm gif)
        when (or (mh-do-in-gnu-emacs
                   (ignore-errors
                     (mh-funcall-if-exists image-type-available-p type)))
                 (mh-do-in-xemacs (featurep type)))
        collect type))

(autoload 'message-tokenize-header "sendmail")

(defun* mh-picon-get-image ()
  "Find the best possible match and return contents."
  (mh-picon-set-directory-list)
  (save-restriction
    (let* ((from-field (ignore-errors (car (message-tokenize-header
                                            (mh-get-header-field "from:")))))
           (from (car (ignore-errors
                        (mh-funcall-if-exists ietf-drums-parse-address
                                              from-field))))
           (host (and from
                      (string-match "\\([^+]*\\)\\(+.*\\)?@\\(.*\\)" from)
                      (downcase (match-string 3 from))))
           (user (and host (downcase (match-string 1 from))))
           (canonical-address (format "%s@%s" user host))
           (cached-value (gethash canonical-address mh-picon-cache))
           (host-list (and host (delete "" (split-string host "\\."))))
           (match nil))
      (cond (cached-value (return-from mh-picon-get-image cached-value))
            ((not host-list) (return-from mh-picon-get-image nil)))
      (setq match
            (block 'loop
              ;; u@h search
              (loop for dir in mh-picon-existing-directory-list
                    do (loop for type in mh-picon-image-types
                             ;; [path]user@host
                             for file1 = (format "%s/%s.%s"
                                                 dir canonical-address type)
                             when (file-exists-p file1)
                             do (return-from 'loop file1)
                             ;; [path]user
                             for file2 = (format "%s/%s.%s" dir user type)
                             when (file-exists-p file2)
                             do (return-from 'loop file2)
                             ;; [path]host
                             for file3 = (format "%s/%s.%s" dir host type)
                             when (file-exists-p file3)
                             do (return-from 'loop file3)))
              ;; facedb search
              ;; Search order for [e-mail]:
              ;;   [path]net/foo/user
              ;;   [path]net/foo/user/face
              ;;   [path]net/user
              ;;   [path]net/user/face
              ;;   [path]net/foo/unknown
              ;;   [path]net/foo/unknown/face
              ;;   [path]net/unknown
              ;;   [path]net/unknown/face
              (loop for u in (list user "unknown")
                    do (loop for dir in mh-picon-existing-directory-list
                             do (loop for x on host-list by #'cdr
                                      for y = (mh-picon-generate-path x u dir)
                                      do (loop for type in mh-picon-image-types
                                               for z1 = (format "%s.%s" y type)
                                               when (file-exists-p z1)
                                               do (return-from 'loop z1)
                                               for z2 = (format "%s/face.%s"
                                                                y type)
                                               when (file-exists-p z2)
                                               do (return-from 'loop z2)))))))
      (setf (gethash canonical-address mh-picon-cache)
            (mh-picon-file-contents match)))))

(defun mh-picon-set-directory-list ()
  "Update `mh-picon-existing-directory-list' if needed."
  (when (eq mh-picon-existing-directory-list 'unset)
    (setq mh-picon-existing-directory-list
          (loop for x in mh-picon-directory-list
                when (file-directory-p x) collect x))))

(defun mh-picon-generate-path (host-list user directory)
  "Generate the image file path.
HOST-LIST is the parsed host address of the email address, USER
the username and DIRECTORY is the directory relative to which the
path is generated."
  (loop with acc = ""
        for elem in host-list
        do (setq acc (format "%s/%s" elem acc))
        finally return (format "%s/%s%s" directory acc user)))

(defun mh-picon-file-contents (file)
  "Return details about FILE.
A list of consisting of a symbol for the type of the file and the
file contents as a string is returned. If FILE is nil, then both
elements of the list are nil."
  (if (stringp file)
      (with-temp-buffer
        (set-buffer-multibyte nil)
        (let ((type (and (string-match ".*\\.\\(...\\)$" file)
                         (intern (match-string 1 file)))))
          (insert-file-contents-literally file)
          (list type (buffer-string))))
    (list nil nil)))



;;; X-Image-URL Display

(defvar mh-x-image-scaling-function
  (cond ((executable-find "convert")
         'mh-x-image-scale-with-convert)
        ((and (executable-find "anytopnm") (executable-find "pnmscale")
              (executable-find "pnmtopng"))
         'mh-x-image-scale-with-pnm)
        (t 'ignore))
  "Function to use to scale image to proper size.")

(defun mh-x-image-scale-with-pnm (input output)
  "Scale image in INPUT file and write to OUTPUT file using pnm tools."
  (let ((res (shell-command-to-string
              (format "anytopnm < %s | pnmscale -xysize 96 48 | pnmtopng > %s"
                      input output))))
    (unless (equal res "")
      (delete-file output))))

(defun mh-x-image-scale-with-convert (input output)
  "Scale image in INPUT file and write to OUTPUT file using ImageMagick."
  (call-process "convert" nil nil nil "-geometry" "96x48" input output))

(defvar mh-wget-executable nil)
(defvar mh-wget-choice
  (or (and (setq mh-wget-executable (executable-find "wget")) 'wget)
      (and (setq mh-wget-executable (executable-find "fetch")) 'fetch)
      (and (setq mh-wget-executable (executable-find "curl")) 'curl)))
(defvar mh-wget-option
  (cdr (assoc mh-wget-choice '((curl . "-o") (fetch . "-o") (wget . "-O")))))
(defvar mh-x-image-temp-file nil)
(defvar mh-x-image-url nil)
(defvar mh-x-image-marker nil)
(defvar mh-x-image-url-cache-file nil)

(defun mh-x-image-url-display (url)
  "Display image from location URL.
If the URL isn't present in the cache then it is fetched with wget."
  (let* ((cache-filename (mh-x-image-url-cache-canonicalize url))
         (state (mh-x-image-get-download-state cache-filename))
         (marker (set-marker (make-marker) (point))))
    (set (make-local-variable 'mh-x-image-marker) marker)
    (cond ((not (mh-x-image-url-sane-p url)))
          ((eq state 'ok)
           (mh-x-image-display cache-filename marker))
          ((or (not mh-wget-executable)
               (eq mh-x-image-scaling-function 'ignore)))
          ((eq state 'never))
          ((not mh-fetch-x-image-url)
           (set-marker marker nil))
          ((eq state 'try-again)
           (mh-x-image-set-download-state cache-filename nil)
           (mh-x-image-url-fetch-image url cache-filename marker
                                       'mh-x-image-scale-and-display))
          ((and (eq mh-fetch-x-image-url 'ask)
                (not (y-or-n-p (format "Fetch %s? " url))))
           (mh-x-image-set-download-state cache-filename 'never))
          ((eq state nil)
           (mh-x-image-url-fetch-image url cache-filename marker
                                       'mh-x-image-scale-and-display)))))

(defvar mh-x-image-cache-directory nil
  "Directory where X-Image-URL images are cached.")

;;;###mh-autoload
(defun mh-set-x-image-cache-directory (directory)
  "Set the DIRECTORY where X-Image-URL images are cached.
This is only done if `mh-x-image-cache-directory' is nil."
  ;; XXX This is the code that used to be in find-user-path. Is there
  ;; a good reason why the variable is set conditionally? Do we expect
  ;; the user to have set this variable directly?
  (unless mh-x-image-cache-directory
    (setq mh-x-image-cache-directory directory)))

(defun mh-x-image-url-cache-canonicalize (url)
  "Canonicalize URL.
Replace the ?/ character with a ?! character and append .png.
Also replaces special characters with `mh-url-hexify-string'
since not all characters, such as :, are valid within Windows
filenames.  In addition, replaces * with %2a. See URL
`http://msdn.microsoft.com/library/default.asp?url=/library/en-us/shellcc/platform/shell/reference/ifaces/iitemnamelimits/GetValidCharacters.asp'."
  (format "%s/%s.png" mh-x-image-cache-directory
          (mh-replace-regexp-in-string
           "\*" "%2a"
           (mh-url-hexify-string
            (with-temp-buffer
              (insert url)
              (mh-replace-string "/" "!")
              (buffer-string))))))

(defun mh-x-image-get-download-state (file)
  "Check the state of FILE by following any symbolic links."
  (unless (file-exists-p mh-x-image-cache-directory)
    (call-process "mkdir" nil nil nil mh-x-image-cache-directory))
  (cond ((file-symlink-p file)
         (intern (file-name-nondirectory (file-chase-links file))))
        ((not (file-exists-p file)) nil)
        (t 'ok)))

(defun mh-x-image-set-download-state (file data)
  "Setup a symbolic link from FILE to DATA."
  (if data
      (make-symbolic-link (symbol-name data) file t)
    (delete-file file)))

(defun mh-x-image-url-sane-p (url)
  "Check if URL is something sensible."
  (let ((len (length url)))
    (cond ((< len 5) nil)
          ((not (equal (substring url 0 5) "http:")) nil)
          ((> len 100) nil)
          (t t))))

(defun mh-x-image-display (image marker)
  "Display IMAGE at MARKER."
  (with-current-buffer (marker-buffer marker)
    (let ((inhibit-read-only t)
          (buffer-modified-flag (buffer-modified-p)))
      (unwind-protect
          (when (and (file-readable-p image) (not (file-symlink-p image))
                     (eq marker mh-x-image-marker))
            (goto-char marker)
            (mh-do-in-gnu-emacs
              (mh-funcall-if-exists insert-image (create-image image 'png)))
            (mh-do-in-xemacs
              (when (featurep 'png)
                (set-extent-begin-glyph
                 (make-extent (point) (point))
                 (make-glyph
                  (vector 'png ':data (with-temp-buffer
                                        (insert-file-contents-literally image)
                                        (buffer-string))))))))
        (set-buffer-modified-p buffer-modified-flag)))))

(defun mh-x-image-url-fetch-image (url cache-file marker sentinel)
  "Fetch and display the image specified by URL.
After the image is fetched, it is stored in CACHE-FILE. It will
be displayed in a buffer and position specified by MARKER. The
actual display is carried out by the SENTINEL function."
  (if mh-wget-executable
      (let ((buffer (get-buffer-create (generate-new-buffer-name
                                        mh-temp-fetch-buffer)))
            (filename (or (mh-funcall-if-exists make-temp-file "mhe-fetch")
                          (expand-file-name (make-temp-name "~/mhe-fetch")))))
        (with-current-buffer buffer
          (set (make-local-variable 'mh-x-image-url-cache-file) cache-file)
          (set (make-local-variable 'mh-x-image-marker) marker)
          (set (make-local-variable 'mh-x-image-temp-file) filename))
        (set-process-sentinel
         (start-process "*mh-x-image-url-fetch*" buffer
                        mh-wget-executable mh-wget-option filename url)
         sentinel))
    ;; Temporary failure
    (mh-x-image-set-download-state cache-file 'try-again)))

(defun mh-x-image-scale-and-display (process change)
  "When the wget PROCESS terminates scale and display image.
The argument CHANGE is ignored."
  (when (eq (process-status process) 'exit)
    (let (marker temp-file cache-filename wget-buffer)
      (with-current-buffer (setq wget-buffer (process-buffer process))
        (setq marker mh-x-image-marker
              cache-filename mh-x-image-url-cache-file
              temp-file mh-x-image-temp-file))
      (cond
       ;; Check if we have `convert'
       ((eq mh-x-image-scaling-function 'ignore)
        (message "The \"convert\" program is needed to display X-Image-URL")
        (mh-x-image-set-download-state cache-filename 'try-again))
       ;; Scale fetched image
       ((and (funcall mh-x-image-scaling-function temp-file cache-filename)
             nil))
       ;; Attempt to display image if we have it
       ((file-exists-p cache-filename)
        (mh-x-image-display cache-filename marker))
       ;; We didn't find the image. Should we try to display it the next time?
       (t (mh-x-image-set-download-state cache-filename 'try-again)))
      (ignore-errors
        (set-marker marker nil)
        (delete-process process)
        (kill-buffer wget-buffer)
        (delete-file temp-file)))))

(provide 'mh-xface)

;; Local Variables:
;; indent-tabs-mode: nil
;; sentence-end-double-space: nil
;; End:

;; arch-tag: a79dd33f-d0e5-4b19-a53a-be690f90229a
;;; mh-xface.el ends here