From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from localhost (localhost [127.0.0.1]) by olra.theworths.org (Postfix) with ESMTP id 0B1CB431FD8 for ; Wed, 5 Jun 2013 09:24:13 -0700 (PDT) X-Virus-Scanned: Debian amavisd-new at olra.theworths.org X-Spam-Flag: NO X-Spam-Score: 0.224 X-Spam-Level: X-Spam-Status: No, score=0.224 tagged_above=-999 required=5 tests=[DKIM_SIGNED=0.1, DKIM_VALID=-0.1, DKIM_VALID_AU=-0.1, FREEMAIL_ENVFROM_END_DIGIT=1, FREEMAIL_FROM=0.001, HS_INDEX_PARAM=0.023, RCVD_IN_DNSWL_LOW=-0.7] autolearn=disabled Received: from olra.theworths.org ([127.0.0.1]) by localhost (olra.theworths.org [127.0.0.1]) (amavisd-new, port 10024) with ESMTP id xujJgItUg2nQ for ; Wed, 5 Jun 2013 09:24:00 -0700 (PDT) Received: from mail-wi0-f175.google.com (mail-wi0-f175.google.com [209.85.212.175]) (using TLSv1 with cipher RC4-SHA (128/128 bits)) (No client certificate requested) by olra.theworths.org (Postfix) with ESMTPS id 51A04431FB6 for ; Wed, 5 Jun 2013 09:23:57 -0700 (PDT) Received: by mail-wi0-f175.google.com with SMTP id hn14so4994170wib.8 for ; Wed, 05 Jun 2013 09:23:56 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20120113; h=from:to:cc:subject:date:message-id:x-mailer:in-reply-to:references; bh=hKWwxBUR1hAlUagUlVrOWYvy1g8/CJe4Q7fzDgvJOS0=; b=bekF8Pc2Ud/R5lvIhohatvlrgLbwS7yzmMjDt51rUaAsvtu2ZNmqcqvak45dESdJji VcRQ3TNKGy9FltXkOjN4ebvG+7vl9Fvs6zyQmzIFVuo2UykuXtF4vhlqTEM0HvXQEDvG dVfqezByfjdApWAwfL8z0gol5esui1m1+26J338hecmrtQb8eNXdKvyixVNHtqYFgcPO 15lTtB6QZCmbbCeCNXSyDLKPr1eS0B8hStohYyvWLN4+n4bn+YAu65bFjAPU0+RY55ir jaWb79/KN/6/LGWuujBQ1zZ6HD9dFZzhO4tkrIHxxtJBFP/Y14nwBiwfk5G7br/xC4fr u1qA== X-Received: by 10.180.184.101 with SMTP id et5mr7366942wic.45.1370449436197; Wed, 05 Jun 2013 09:23:56 -0700 (PDT) Received: from localhost (93-97-24-31.zone5.bethere.co.uk. [93.97.24.31]) by mx.google.com with ESMTPSA id fu14sm11487953wic.0.2013.06.05.09.23.54 for (version=TLSv1.2 cipher=RC4-SHA bits=128/128); Wed, 05 Jun 2013 09:23:55 -0700 (PDT) From: Mark Walters To: notmuch@notmuchmail.org Subject: [PATCH 2/2] insert forest moved Date: Wed, 5 Jun 2013 17:23:46 +0100 Message-Id: <1370449426-2325-3-git-send-email-markwalters1009@gmail.com> X-Mailer: git-send-email 1.7.9.1 In-Reply-To: <1370449426-2325-1-git-send-email-markwalters1009@gmail.com> References: <1370449426-2325-1-git-send-email-markwalters1009@gmail.com> X-BeenThere: notmuch@notmuchmail.org X-Mailman-Version: 2.1.13 Precedence: list List-Id: "Use and development of the notmuch mail system." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , X-List-Received-Date: Wed, 05 Jun 2013 16:24:13 -0000 --- emacs/notmuch-show-display.el | 704 ++++++++++++++++++++++++++++++++++++++++- emacs/notmuch-show.el | 692 ---------------------------------------- 2 files changed, 703 insertions(+), 693 deletions(-) diff --git a/emacs/notmuch-show-display.el b/emacs/notmuch-show-display.el index 50d83ad..82678c2 100644 --- a/emacs/notmuch-show-display.el +++ b/emacs/notmuch-show-display.el @@ -21,5 +21,707 @@ ;; Authors: Carl Worth ;; David Edmondson +(require 'mm-view) +(require 'message) +(require 'mm-decode) +(require 'mailcap) -(provide 'notmuch-show-display) \ No newline at end of file +(require 'notmuch-lib) +(require 'notmuch-tag) +(require 'notmuch-wash) +(require 'notmuch-crypto) + +(declare-function notmuch-show-get-header "notmuch-show" (header &optional props)) +(declare-function notmuch-show-set-message-properties "notmuch-show" (props)) +(declare-function notmuch-show-set-prop "notmuch-show" (prop val &optional props)) + +(defcustom notmuch-message-headers '("Subject" "To" "Cc" "Date") + "Headers that should be shown in a message, in this order. + +For an open message, all of these headers will be made visible +according to `notmuch-message-headers-visible' or can be toggled +with `notmuch-show-toggle-visibility-headers'. For a closed message, +only the first header in the list will be visible." + :type '(repeat string) + :group 'notmuch-show) + +(defcustom notmuch-message-headers-visible t + "Should the headers be visible by default? + +If this value is non-nil, then all of the headers defined in +`notmuch-message-headers' will be visible by default in the display +of each message. Otherwise, these headers will be hidden and +`notmuch-show-toggle-visibility-headers' can be used to make them +visible for any given message." + :type 'boolean + :group 'notmuch-show) + +(defcustom notmuch-show-relative-dates t + "Display relative dates in the message summary line." + :type 'boolean + :group 'notmuch-show) + +(defvar notmuch-show-markup-headers-hook '(notmuch-show-colour-headers) + "A list of functions called to decorate the headers listed in +`notmuch-message-headers'.") + +(defcustom notmuch-show-insert-text/plain-hook '(notmuch-wash-wrap-long-lines + notmuch-wash-tidy-citations + notmuch-wash-elide-blank-lines + notmuch-wash-excerpt-citations) + "Functions used to improve the display of text/plain parts." + :type 'hook + :options '(notmuch-wash-convert-inline-patch-to-part + notmuch-wash-wrap-long-lines + notmuch-wash-tidy-citations + notmuch-wash-elide-blank-lines + notmuch-wash-excerpt-citations) + :group 'notmuch-show + :group 'notmuch-hooks) + +;; Mostly useful for debugging. +(defcustom notmuch-show-all-multipart/alternative-parts nil + "Should all parts of multipart/alternative parts be shown?" + :type 'boolean + :group 'notmuch-show) + +(defcustom notmuch-show-indent-messages-width 1 + "Width of message indentation in threads. + +Messages are shown indented according to their depth in a thread. +This variable determines the width of this indentation measured +in number of blanks. Defaults to `1', choose `0' to disable +indentation." + :type 'integer + :group 'notmuch-show) + +(defcustom notmuch-show-indent-multipart nil + "Should the sub-parts of a multipart/* part be indented?" + ;; dme: Not sure which is a good default. + :type 'boolean + :group 'notmuch-show) + +(defvar notmuch-show-process-crypto nil) +(make-variable-buffer-local 'notmuch-show-process-crypto) +(put 'notmuch-show-process-crypto 'permanent-local t) + +(defvar notmuch-show-indent-content t) +(make-variable-buffer-local 'notmuch-show-indent-content) +(put 'notmuch-show-indent-content 'permanent-local t) + +(defun notmuch-show-fontify-header () + (let ((face (cond + ((looking-at "[Tt]o:") + 'message-header-to) + ((looking-at "[Bb]?[Cc][Cc]:") + 'message-header-cc) + ((looking-at "[Ss]ubject:") + 'message-header-subject) + ((looking-at "[Ff]rom:") + 'message-header-from) + (t + 'message-header-other)))) + + (overlay-put (make-overlay (point) (re-search-forward ":")) + 'face 'message-header-name) + (overlay-put (make-overlay (point) (re-search-forward ".*$")) + 'face face))) + +(defun notmuch-show-colour-headers () + "Apply some colouring to the current headers." + (goto-char (point-min)) + (while (looking-at "^[A-Za-z][-A-Za-z0-9]*:") + (notmuch-show-fontify-header) + (forward-line))) + +(defun notmuch-show-spaces-n (n) + "Return a string comprised of `n' spaces." + (make-string n ? )) + +(defun notmuch-clean-address (address) + "Try to clean a single email ADDRESS for display. Return a cons +cell of (AUTHOR_EMAIL AUTHOR_NAME). Return (ADDRESS nil) if +parsing fails." + (condition-case nil + (let (p-name p-address) + ;; It would be convenient to use `mail-header-parse-address', + ;; but that expects un-decoded mailbox parts, whereas our + ;; mailbox parts are already decoded (and hence may contain + ;; UTF-8). Given that notmuch should handle most of the awkward + ;; cases, some simple string deconstruction should be sufficient + ;; here. + (cond + ;; "User " style. + ((string-match "\\(.*\\) <\\(.*\\)>" address) + (setq p-name (match-string 1 address) + p-address (match-string 2 address))) + + ;; "" style. + ((string-match "<\\(.*\\)>" address) + (setq p-address (match-string 1 address))) + + ;; Everything else. + (t + (setq p-address address))) + + (when p-name + ;; Remove elements of the mailbox part that are not relevant for + ;; display, even if they are required during transport: + ;; + ;; Backslashes. + (setq p-name (replace-regexp-in-string "\\\\" "" p-name)) + + ;; Outer single and double quotes, which might be nested. + (loop + with start-of-loop + do (setq start-of-loop p-name) + + when (string-match "^\"\\(.*\\)\"$" p-name) + do (setq p-name (match-string 1 p-name)) + + when (string-match "^'\\(.*\\)'$" p-name) + do (setq p-name (match-string 1 p-name)) + + until (string= start-of-loop p-name))) + + ;; If the address is 'foo@bar.com ' then show just + ;; 'foo@bar.com'. + (when (string= p-name p-address) + (setq p-name nil)) + + (cons p-address p-name)) + (error (cons address nil)))) + +(defun notmuch-show-clean-address (address) + "Try to clean a single email ADDRESS for display. Return +unchanged ADDRESS if parsing fails." + (let* ((clean-address (notmuch-clean-address address)) + (p-address (car clean-address)) + (p-name (cdr clean-address))) + ;; If no name, return just the address. + (if (not p-name) + p-address + ;; Otherwise format the name and address together. + (concat p-name " <" p-address ">")))) + +(defun notmuch-show-insert-headerline (headers date tags depth) + "Insert a notmuch style headerline based on HEADERS for a +message at DEPTH in the current thread." + (let ((start (point))) + (insert (notmuch-show-spaces-n (* notmuch-show-indent-messages-width depth)) + (notmuch-show-clean-address (plist-get headers :From)) + " (" + date + ") (" + (notmuch-tag-format-tags tags) + ")\n") + (overlay-put (make-overlay start (point)) 'face 'notmuch-message-summary-face))) + +(defun notmuch-show-insert-header (header header-value) + "Insert a single header." + (insert header ": " header-value "\n")) + +(defun notmuch-show-insert-headers (headers) + "Insert the headers of the current message." + (let ((start (point))) + (mapc (lambda (header) + (let* ((header-symbol (intern (concat ":" header))) + (header-value (plist-get headers header-symbol))) + (if (and header-value + (not (string-equal "" header-value))) + (notmuch-show-insert-header header header-value)))) + notmuch-message-headers) + (save-excursion + (save-restriction + (narrow-to-region start (point-max)) + (run-hooks 'notmuch-show-markup-headers-hook))))) + +(defun notmuch-show-insert-part-header (nth content-type declared-type &optional name comment) + (let ((button) + (base-label (concat (when name (concat name ": ")) + declared-type + (unless (string-equal declared-type content-type) + (concat " (as " content-type ")")) + comment))) + + (setq button + (insert-button + (concat "[ " base-label " ]") + :base-label base-label + :type 'notmuch-show-part-button-type + :notmuch-part nth + :notmuch-filename name + :notmuch-content-type content-type)) + (insert "\n") + ;; return button + button)) + +;; This is taken from notmuch-wash: maybe it should be unified? +(defun notmuch-show-toggle-part-invisibility (&optional button) + (interactive) + (let* ((button (or button (button-at (point)))) + (overlay (button-get button 'overlay))) + (when overlay + (let* ((show (overlay-get overlay 'invisible)) + (new-start (button-start button)) + (button-label (button-get button :base-label)) + (old-point (point)) + (inhibit-read-only t)) + (overlay-put overlay 'invisible (not show)) + (goto-char new-start) + (insert "[ " button-label (if show " ]" " (hidden) ]")) + (let ((old-end (button-end button))) + (move-overlay button new-start (point)) + (delete-region (point) old-end)) + (goto-char (min old-point (1- (button-end button)))))))) + +(defun notmuch-show-multipart/*-to-list (part) + (mapcar (lambda (inner-part) (plist-get inner-part :content-type)) + (plist-get part :content))) + +(defun notmuch-show-insert-part-multipart/alternative (msg part content-type nth depth declared-type) + (notmuch-show-insert-part-header nth declared-type content-type nil) + (let ((chosen-type (car (notmuch-multipart/alternative-choose (notmuch-show-multipart/*-to-list part)))) + (inner-parts (plist-get part :content)) + (start (point))) + ;; This inserts all parts of the chosen type rather than just one, + ;; but it's not clear that this is the wrong thing to do - which + ;; should be chosen if there are more than one that match? + (mapc (lambda (inner-part) + (let* ((inner-type (plist-get inner-part :content-type)) + (hide (not (or notmuch-show-all-multipart/alternative-parts + (string= chosen-type inner-type))))) + (notmuch-show-insert-bodypart msg inner-part depth hide))) + inner-parts) + + (when notmuch-show-indent-multipart + (indent-rigidly start (point) 1))) + t) + +(defun notmuch-show-setup-w3m () + "Instruct w3m how to retrieve content from a \"related\" part of a message." + (interactive) + (if (boundp 'w3m-cid-retrieve-function-alist) + (unless (assq 'notmuch-show-mode w3m-cid-retrieve-function-alist) + (push (cons 'notmuch-show-mode 'notmuch-show-w3m-cid-retrieve) + w3m-cid-retrieve-function-alist))) + (setq mm-inline-text-html-with-images t)) + +(defvar w3m-current-buffer) ;; From `w3m.el'. +(defvar notmuch-show-w3m-cid-store nil) +(make-variable-buffer-local 'notmuch-show-w3m-cid-store) + +(defun notmuch-show-w3m-cid-store-internal (content-id + message-id + part-number + content-type + content) + (push (list content-id + message-id + part-number + content-type + content) + notmuch-show-w3m-cid-store)) + +(defun notmuch-show-w3m-cid-store (msg part) + (let ((content-id (plist-get part :content-id))) + (when content-id + (notmuch-show-w3m-cid-store-internal (concat "cid:" content-id) + (plist-get msg :id) + (plist-get part :id) + (plist-get part :content-type) + nil)))) + +(defun notmuch-show-w3m-cid-retrieve (url &rest args) + (let ((matching-part (with-current-buffer w3m-current-buffer + (assoc url notmuch-show-w3m-cid-store)))) + (if matching-part + (let ((message-id (nth 1 matching-part)) + (part-number (nth 2 matching-part)) + (content-type (nth 3 matching-part)) + (content (nth 4 matching-part))) + ;; If we don't already have the content, get it and cache + ;; it, as some messages reference the same cid: part many + ;; times (hundreds!), which results in many calls to + ;; `notmuch part'. + (unless content + (setq content (notmuch-get-bodypart-internal (notmuch-id-to-query message-id) + part-number notmuch-show-process-crypto)) + (with-current-buffer w3m-current-buffer + (notmuch-show-w3m-cid-store-internal url + message-id + part-number + content-type + content))) + (insert content) + content-type) + nil))) + +(defun notmuch-show-insert-part-multipart/related (msg part content-type nth depth declared-type) + (notmuch-show-insert-part-header nth declared-type content-type nil) + (let ((inner-parts (plist-get part :content)) + (start (point))) + + ;; We assume that the first part is text/html and the remainder + ;; things that it references. + + ;; Stash the non-primary parts. + (mapc (lambda (part) + (notmuch-show-w3m-cid-store msg part)) + (cdr inner-parts)) + + ;; Render the primary part. + (notmuch-show-insert-bodypart msg (car inner-parts) depth) + + (when notmuch-show-indent-multipart + (indent-rigidly start (point) 1))) + t) + +(defun notmuch-show-insert-part-multipart/signed (msg part content-type nth depth declared-type) + (let ((button (notmuch-show-insert-part-header nth declared-type content-type nil))) + (button-put button 'face 'notmuch-crypto-part-header) + ;; add signature status button if sigstatus provided + (if (plist-member part :sigstatus) + (let* ((from (notmuch-show-get-header :From msg)) + (sigstatus (car (plist-get part :sigstatus)))) + (notmuch-crypto-insert-sigstatus-button sigstatus from)) + ;; if we're not adding sigstatus, tell the user how they can get it + (button-put button 'help-echo "Set notmuch-crypto-process-mime to process cryptographic MIME parts."))) + + (let ((inner-parts (plist-get part :content)) + (start (point))) + ;; Show all of the parts. + (mapc (lambda (inner-part) + (notmuch-show-insert-bodypart msg inner-part depth)) + inner-parts) + + (when notmuch-show-indent-multipart + (indent-rigidly start (point) 1))) + t) + +(defun notmuch-show-insert-part-multipart/encrypted (msg part content-type nth depth declared-type) + (let ((button (notmuch-show-insert-part-header nth declared-type content-type nil))) + (button-put button 'face 'notmuch-crypto-part-header) + ;; add encryption status button if encstatus specified + (if (plist-member part :encstatus) + (let ((encstatus (car (plist-get part :encstatus)))) + (notmuch-crypto-insert-encstatus-button encstatus) + ;; add signature status button if sigstatus specified + (if (plist-member part :sigstatus) + (let* ((from (notmuch-show-get-header :From msg)) + (sigstatus (car (plist-get part :sigstatus)))) + (notmuch-crypto-insert-sigstatus-button sigstatus from)))) + ;; if we're not adding encstatus, tell the user how they can get it + (button-put button 'help-echo "Set notmuch-crypto-process-mime to process cryptographic MIME parts."))) + + (let ((inner-parts (plist-get part :content)) + (start (point))) + ;; Show all of the parts. + (mapc (lambda (inner-part) + (notmuch-show-insert-bodypart msg inner-part depth)) + inner-parts) + + (when notmuch-show-indent-multipart + (indent-rigidly start (point) 1))) + t) + +(defun notmuch-show-insert-part-multipart/* (msg part content-type nth depth declared-type) + (notmuch-show-insert-part-header nth declared-type content-type nil) + (let ((inner-parts (plist-get part :content)) + (start (point))) + ;; Show all of the parts. + (mapc (lambda (inner-part) + (notmuch-show-insert-bodypart msg inner-part depth)) + inner-parts) + + (when notmuch-show-indent-multipart + (indent-rigidly start (point) 1))) + t) + +(defun notmuch-show-insert-part-message/rfc822 (msg part content-type nth depth declared-type) + (notmuch-show-insert-part-header nth declared-type content-type nil) + (let* ((message (car (plist-get part :content))) + (body (car (plist-get message :body))) + (start (point))) + + ;; Override `notmuch-message-headers' to force `From' to be + ;; displayed. + (let ((notmuch-message-headers '("From" "Subject" "To" "Cc" "Date"))) + (notmuch-show-insert-headers (plist-get message :headers))) + + ;; Blank line after headers to be compatible with the normal + ;; message display. + (insert "\n") + + ;; Show the body + (notmuch-show-insert-bodypart msg body depth) + + (when notmuch-show-indent-multipart + (indent-rigidly start (point) 1))) + t) + +(defun notmuch-show-insert-part-text/plain (msg part content-type nth depth declared-type) + (let ((start (point))) + ;; If this text/plain part is not the first part in the message, + ;; insert a header to make this clear. + (if (> nth 1) + (notmuch-show-insert-part-header nth declared-type content-type (plist-get part :filename))) + (insert (notmuch-get-bodypart-content msg part nth notmuch-show-process-crypto)) + (save-excursion + (save-restriction + (narrow-to-region start (point-max)) + (run-hook-with-args 'notmuch-show-insert-text/plain-hook msg depth)))) + t) + +(defun notmuch-show-insert-part-text/calendar (msg part content-type nth depth declared-type) + (notmuch-show-insert-part-header nth declared-type content-type (plist-get part :filename)) + (insert (with-temp-buffer + (insert (notmuch-get-bodypart-content msg part nth notmuch-show-process-crypto)) + ;; notmuch-get-bodypart-content provides "raw", non-converted + ;; data. Replace CRLF with LF before icalendar can use it. + (goto-char (point-min)) + (while (re-search-forward "\r\n" nil t) + (replace-match "\n" nil nil)) + (let ((file (make-temp-file "notmuch-ical")) + result) + (unwind-protect + (progn + (unless (icalendar-import-buffer file t) + (error "Icalendar import error. See *icalendar-errors* for more information")) + (set-buffer (get-file-buffer file)) + (setq result (buffer-substring (point-min) (point-max))) + (set-buffer-modified-p nil) + (kill-buffer (current-buffer))) + (delete-file file)) + result))) + t) + +;; For backwards compatibility. +(defun notmuch-show-insert-part-text/x-vcalendar (msg part content-type nth depth declared-type) + (notmuch-show-insert-part-text/calendar msg part content-type nth depth declared-type)) + +(defun notmuch-show-get-mime-type-of-application/octet-stream (part) + ;; If we can deduce a MIME type from the filename of the attachment, + ;; we return that. + (if (plist-get part :filename) + (let ((extension (file-name-extension (plist-get part :filename))) + mime-type) + (if extension + (progn + (mailcap-parse-mimetypes) + (setq mime-type (mailcap-extension-to-mime extension)) + (if (and mime-type + (not (string-equal mime-type "application/octet-stream"))) + mime-type + nil)) + nil)))) + +;; Handler for wash generated inline patch fake parts. +(defun notmuch-show-insert-part-inline-patch-fake-part (msg part content-type nth depth declared-type) + (notmuch-show-insert-part-*/* msg part content-type nth depth declared-type)) + +(defun notmuch-show-insert-part-text/html (msg part content-type nth depth declared-type) + ;; text/html handler to work around bugs in renderers and our + ;; invisibile parts code. In particular w3m sets up a keymap which + ;; "leaks" outside the invisible region and causes strange effects + ;; in notmuch. We set mm-inline-text-html-with-w3m-keymap to nil to + ;; tell w3m not to set a keymap (so the normal notmuch-show-mode-map + ;; remains). + (let ((mm-inline-text-html-with-w3m-keymap nil)) + (notmuch-show-insert-part-*/* msg part content-type nth depth declared-type))) + +(defun notmuch-show-insert-part-*/* (msg part content-type nth depth declared-type) + ;; This handler _must_ succeed - it is the handler of last resort. + (notmuch-show-insert-part-header nth content-type declared-type (plist-get part :filename)) + (notmuch-mm-display-part-inline msg part nth content-type notmuch-show-process-crypto) + t) + +;; Functions for determining how to handle MIME parts. + +(defun notmuch-show-handlers-for (content-type) + "Return a list of content handlers for a part of type CONTENT-TYPE." + (let (result) + (mapc (lambda (func) + (if (functionp func) + (push func result))) + ;; Reverse order of prefrence. + (list (intern (concat "notmuch-show-insert-part-*/*")) + (intern (concat + "notmuch-show-insert-part-" + (car (notmuch-split-content-type content-type)) + "/*")) + (intern (concat "notmuch-show-insert-part-" content-type)))) + result)) + +;; + +(defun notmuch-show-insert-bodypart-internal (msg part content-type nth depth declared-type) + (let ((handlers (notmuch-show-handlers-for content-type))) + ;; Run the content handlers until one of them returns a non-nil + ;; value. + (while (and handlers + (not (condition-case err + (funcall (car handlers) msg part content-type nth depth declared-type) + (error (progn + (insert "!!! Bodypart insert error: ") + (insert (error-message-string err)) + (insert " !!!\n") nil))))) + (setq handlers (cdr handlers)))) + t) + +(defun notmuch-show-create-part-overlays (msg beg end hide) + "Add an overlay to the part between BEG and END" + (let* ((button (button-at beg)) + (part-beg (and button (1+ (button-end button))))) + + ;; If the part contains no text we do not make it toggleable. We + ;; also need to check that the button is a genuine part button not + ;; a notmuch-wash button. + (when (and button (/= part-beg end) (button-get button :base-label)) + (button-put button 'overlay (make-overlay part-beg end)) + ;; We toggle the button for hidden parts as that gets the + ;; button label right. + (save-excursion + (when hide + (notmuch-show-toggle-part-invisibility button)))))) + +(defun notmuch-show-insert-bodypart (msg part depth &optional hide) + "Insert the body part PART at depth DEPTH in the current thread. + +If HIDE is non-nil then initially hide this part." + (let* ((content-type (downcase (plist-get part :content-type))) + (mime-type (or (and (string= content-type "application/octet-stream") + (notmuch-show-get-mime-type-of-application/octet-stream part)) + (and (string= content-type "inline patch") + "text/x-diff") + content-type)) + (nth (plist-get part :id)) + (beg (point))) + + (notmuch-show-insert-bodypart-internal msg part mime-type nth depth content-type) + ;; Some of the body part handlers leave point somewhere up in the + ;; part, so we make sure that we're down at the end. + (goto-char (point-max)) + ;; Ensure that the part ends with a carriage return. + (unless (bolp) + (insert "\n")) + (notmuch-show-create-part-overlays msg beg (point) hide))) + +(defun notmuch-show-insert-body (msg body depth) + "Insert the body BODY at depth DEPTH in the current thread." + (mapc (lambda (part) (notmuch-show-insert-bodypart msg part depth)) body)) + +(defun notmuch-show-strip-re (string) + (replace-regexp-in-string "^\\([Rr]e: *\\)+" "" string)) + +(defvar notmuch-show-previous-subject "") +(make-variable-buffer-local 'notmuch-show-previous-subject) + +(defun notmuch-show-insert-msg (msg depth) + "Insert the message MSG at depth DEPTH in the current thread." + (let* ((headers (plist-get msg :headers)) + ;; Indentation causes the buffer offset of the start/end + ;; points to move, so we must use markers. + message-start message-end + content-start content-end + headers-start headers-end + (bare-subject (notmuch-show-strip-re (plist-get headers :Subject)))) + + (setq message-start (point-marker)) + + (notmuch-show-insert-headerline headers + (or (if notmuch-show-relative-dates + (plist-get msg :date_relative) + nil) + (plist-get headers :Date)) + (plist-get msg :tags) depth) + + (setq content-start (point-marker)) + + ;; Set `headers-start' to point after the 'Subject:' header to be + ;; compatible with the existing implementation. This just sets it + ;; to after the first header. + (notmuch-show-insert-headers headers) + (save-excursion + (goto-char content-start) + ;; If the subject of this message is the same as that of the + ;; previous message, don't display it when this message is + ;; collapsed. + (when (not (string= notmuch-show-previous-subject + bare-subject)) + (forward-line 1)) + (setq headers-start (point-marker))) + (setq headers-end (point-marker)) + + (setq notmuch-show-previous-subject bare-subject) + + ;; A blank line between the headers and the body. + (insert "\n") + (notmuch-show-insert-body msg (plist-get msg :body) + (if notmuch-show-indent-content depth 0)) + ;; Ensure that the body ends with a newline. + (unless (bolp) + (insert "\n")) + (setq content-end (point-marker)) + + ;; Indent according to the depth in the thread. + (if notmuch-show-indent-content + (indent-rigidly content-start content-end (* notmuch-show-indent-messages-width depth))) + + (setq message-end (point-max-marker)) + + ;; Save the extents of this message over the whole text of the + ;; message. + (put-text-property message-start message-end :notmuch-message-extent (cons message-start message-end)) + + ;; Create overlays used to control visibility + (plist-put msg :headers-overlay (make-overlay headers-start headers-end)) + (plist-put msg :message-overlay (make-overlay headers-start content-end)) + + (plist-put msg :depth depth) + + ;; Save the properties for this message. Currently this saves the + ;; entire message (augmented it with other stuff), which seems + ;; like overkill. We might save a reduced subset (for example, not + ;; the content). + (notmuch-show-set-message-properties msg) + + ;; Set header visibility. + (notmuch-show-headers-visible msg notmuch-message-headers-visible) + + ;; Message visibility depends on whether it matched the search + ;; criteria. + (notmuch-show-message-visible msg (and (plist-get msg :match) + (not (plist-get msg :excluded)))))) + +(defun notmuch-show-insert-tree (tree depth) + "Insert the message tree TREE at depth DEPTH in the current thread." + (let ((msg (car tree)) + (replies (cadr tree))) + ;; We test whether there is a message or just some replies. + (when msg + (notmuch-show-insert-msg msg depth)) + (notmuch-show-insert-thread replies (1+ depth)))) + +(defun notmuch-show-insert-thread (thread depth) + "Insert the thread THREAD at depth DEPTH in the current forest." + (mapc (lambda (tree) (notmuch-show-insert-tree tree depth)) thread)) + +(defun notmuch-show-insert-forest (forest) + "Insert the forest of threads FOREST." + (mapc (lambda (thread) (notmuch-show-insert-thread thread 0)) forest)) + +;; Functions relating to the visibility of messages and their +;; components. + +(defun notmuch-show-message-visible (props visible-p) + (overlay-put (plist-get props :message-overlay) 'invisible (not visible-p)) + (notmuch-show-set-prop :message-visible visible-p props)) + +(defun notmuch-show-headers-visible (props visible-p) + (overlay-put (plist-get props :headers-overlay) 'invisible (not visible-p)) + (notmuch-show-set-prop :headers-visible visible-p props)) + +;; + +(provide 'notmuch-show-display) diff --git a/emacs/notmuch-show.el b/emacs/notmuch-show.el index 37ba911..9e3401d 100644 --- a/emacs/notmuch-show.el +++ b/emacs/notmuch-show.el @@ -22,17 +22,12 @@ ;; David Edmondson (eval-when-compile (require 'cl)) -(require 'mm-view) -(require 'message) -(require 'mm-decode) -(require 'mailcap) (require 'icalendar) (require 'goto-addr) (require 'notmuch-lib) (require 'notmuch-tag) (require 'notmuch-query) -(require 'notmuch-wash) (require 'notmuch-mua) (require 'notmuch-crypto) (require 'notmuch-print) @@ -43,36 +38,6 @@ (declare-function notmuch-search-previous-thread "notmuch" nil) (declare-function notmuch-search-show-thread "notmuch" nil) -(defcustom notmuch-message-headers '("Subject" "To" "Cc" "Date") - "Headers that should be shown in a message, in this order. - -For an open message, all of these headers will be made visible -according to `notmuch-message-headers-visible' or can be toggled -with `notmuch-show-toggle-visibility-headers'. For a closed message, -only the first header in the list will be visible." - :type '(repeat string) - :group 'notmuch-show) - -(defcustom notmuch-message-headers-visible t - "Should the headers be visible by default? - -If this value is non-nil, then all of the headers defined in -`notmuch-message-headers' will be visible by default in the display -of each message. Otherwise, these headers will be hidden and -`notmuch-show-toggle-visibility-headers' can be used to make them -visible for any given message." - :type 'boolean - :group 'notmuch-show) - -(defcustom notmuch-show-relative-dates t - "Display relative dates in the message summary line." - :type 'boolean - :group 'notmuch-show) - -(defvar notmuch-show-markup-headers-hook '(notmuch-show-colour-headers) - "A list of functions called to decorate the headers listed in -`notmuch-message-headers'.") - (defcustom notmuch-show-hook '(notmuch-show-turn-on-visual-line-mode) "Functions called after populating a `notmuch-show' buffer." :type 'hook @@ -80,42 +45,6 @@ visible for any given message." :group 'notmuch-show :group 'notmuch-hooks) -(defcustom notmuch-show-insert-text/plain-hook '(notmuch-wash-wrap-long-lines - notmuch-wash-tidy-citations - notmuch-wash-elide-blank-lines - notmuch-wash-excerpt-citations) - "Functions used to improve the display of text/plain parts." - :type 'hook - :options '(notmuch-wash-convert-inline-patch-to-part - notmuch-wash-wrap-long-lines - notmuch-wash-tidy-citations - notmuch-wash-elide-blank-lines - notmuch-wash-excerpt-citations) - :group 'notmuch-show - :group 'notmuch-hooks) - -;; Mostly useful for debugging. -(defcustom notmuch-show-all-multipart/alternative-parts nil - "Should all parts of multipart/alternative parts be shown?" - :type 'boolean - :group 'notmuch-show) - -(defcustom notmuch-show-indent-messages-width 1 - "Width of message indentation in threads. - -Messages are shown indented according to their depth in a thread. -This variable determines the width of this indentation measured -in number of blanks. Defaults to `1', choose `0' to disable -indentation." - :type 'integer - :group 'notmuch-show) - -(defcustom notmuch-show-indent-multipart nil - "Should the sub-parts of a multipart/* part be indented?" - ;; dme: Not sure which is a good default. - :type 'boolean - :group 'notmuch-show) - (defcustom notmuch-show-part-button-default-action 'notmuch-show-save-part "Default part header button action (on ENTER or mouse click)." :group 'notmuch-show @@ -143,18 +72,10 @@ indentation." (make-variable-buffer-local 'notmuch-show-query-context) (put 'notmuch-show-query-context 'permanent-local t) -(defvar notmuch-show-process-crypto nil) -(make-variable-buffer-local 'notmuch-show-process-crypto) -(put 'notmuch-show-process-crypto 'permanent-local t) - (defvar notmuch-show-elide-non-matching-messages nil) (make-variable-buffer-local 'notmuch-show-elide-non-matching-messages) (put 'notmuch-show-elide-non-matching-messages 'permanent-local t) -(defvar notmuch-show-indent-content t) -(make-variable-buffer-local 'notmuch-show-indent-content) -(put 'notmuch-show-indent-content 'permanent-local t) - (defcustom notmuch-show-stash-mlarchive-link-alist '(("Gmane" . "http://mid.gmane.org/") ("MARC" . "http://marc.info/?i=") @@ -328,35 +249,6 @@ operation on the contents of the current buffer." (interactive) (notmuch-show-with-message-as-text 'notmuch-print-message)) -(defun notmuch-show-fontify-header () - (let ((face (cond - ((looking-at "[Tt]o:") - 'message-header-to) - ((looking-at "[Bb]?[Cc][Cc]:") - 'message-header-cc) - ((looking-at "[Ss]ubject:") - 'message-header-subject) - ((looking-at "[Ff]rom:") - 'message-header-from) - (t - 'message-header-other)))) - - (overlay-put (make-overlay (point) (re-search-forward ":")) - 'face 'message-header-name) - (overlay-put (make-overlay (point) (re-search-forward ".*$")) - 'face face))) - -(defun notmuch-show-colour-headers () - "Apply some colouring to the current headers." - (goto-char (point-min)) - (while (looking-at "^[A-Za-z][-A-Za-z0-9]*:") - (notmuch-show-fontify-header) - (forward-line))) - -(defun notmuch-show-spaces-n (n) - "Return a string comprised of `n' spaces." - (make-string n ? )) - (defun notmuch-show-update-tags (tags) "Update the displayed tags of the current message." (save-excursion @@ -367,104 +259,6 @@ operation on the contents of the current buffer." (notmuch-tag-format-tags tags) ")")))))) -(defun notmuch-clean-address (address) - "Try to clean a single email ADDRESS for display. Return a cons -cell of (AUTHOR_EMAIL AUTHOR_NAME). Return (ADDRESS nil) if -parsing fails." - (condition-case nil - (let (p-name p-address) - ;; It would be convenient to use `mail-header-parse-address', - ;; but that expects un-decoded mailbox parts, whereas our - ;; mailbox parts are already decoded (and hence may contain - ;; UTF-8). Given that notmuch should handle most of the awkward - ;; cases, some simple string deconstruction should be sufficient - ;; here. - (cond - ;; "User " style. - ((string-match "\\(.*\\) <\\(.*\\)>" address) - (setq p-name (match-string 1 address) - p-address (match-string 2 address))) - - ;; "" style. - ((string-match "<\\(.*\\)>" address) - (setq p-address (match-string 1 address))) - - ;; Everything else. - (t - (setq p-address address))) - - (when p-name - ;; Remove elements of the mailbox part that are not relevant for - ;; display, even if they are required during transport: - ;; - ;; Backslashes. - (setq p-name (replace-regexp-in-string "\\\\" "" p-name)) - - ;; Outer single and double quotes, which might be nested. - (loop - with start-of-loop - do (setq start-of-loop p-name) - - when (string-match "^\"\\(.*\\)\"$" p-name) - do (setq p-name (match-string 1 p-name)) - - when (string-match "^'\\(.*\\)'$" p-name) - do (setq p-name (match-string 1 p-name)) - - until (string= start-of-loop p-name))) - - ;; If the address is 'foo@bar.com ' then show just - ;; 'foo@bar.com'. - (when (string= p-name p-address) - (setq p-name nil)) - - (cons p-address p-name)) - (error (cons address nil)))) - -(defun notmuch-show-clean-address (address) - "Try to clean a single email ADDRESS for display. Return -unchanged ADDRESS if parsing fails." - (let* ((clean-address (notmuch-clean-address address)) - (p-address (car clean-address)) - (p-name (cdr clean-address))) - ;; If no name, return just the address. - (if (not p-name) - p-address - ;; Otherwise format the name and address together. - (concat p-name " <" p-address ">")))) - -(defun notmuch-show-insert-headerline (headers date tags depth) - "Insert a notmuch style headerline based on HEADERS for a -message at DEPTH in the current thread." - (let ((start (point))) - (insert (notmuch-show-spaces-n (* notmuch-show-indent-messages-width depth)) - (notmuch-show-clean-address (plist-get headers :From)) - " (" - date - ") (" - (notmuch-tag-format-tags tags) - ")\n") - (overlay-put (make-overlay start (point)) 'face 'notmuch-message-summary-face))) - -(defun notmuch-show-insert-header (header header-value) - "Insert a single header." - (insert header ": " header-value "\n")) - -(defun notmuch-show-insert-headers (headers) - "Insert the headers of the current message." - (let ((start (point))) - (mapc (lambda (header) - (let* ((header-symbol (intern (concat ":" header))) - (header-value (plist-get headers header-symbol))) - (if (and header-value - (not (string-equal "" header-value))) - (notmuch-show-insert-header header header-value)))) - notmuch-message-headers) - (save-excursion - (save-restriction - (narrow-to-region start (point-max)) - (run-hooks 'notmuch-show-markup-headers-hook))))) - (define-button-type 'notmuch-show-part-button-type 'action 'notmuch-show-part-button-default 'keymap 'notmuch-show-part-button-map @@ -483,26 +277,6 @@ message at DEPTH in the current thread." "Submap for button commands") (fset 'notmuch-show-part-button-map notmuch-show-part-button-map) -(defun notmuch-show-insert-part-header (nth content-type declared-type &optional name comment) - (let ((button) - (base-label (concat (when name (concat name ": ")) - declared-type - (unless (string-equal declared-type content-type) - (concat " (as " content-type ")")) - comment))) - - (setq button - (insert-button - (concat "[ " base-label " ]") - :base-label base-label - :type 'notmuch-show-part-button-type - :notmuch-part nth - :notmuch-filename name - :notmuch-content-type content-type)) - (insert "\n") - ;; return button - button)) - ;; Functions handling particular MIME parts. (defmacro notmuch-with-temp-part-buffer (message-id nth &rest body) @@ -550,447 +324,9 @@ message at DEPTH in the current thread." (let ((handle (mm-make-handle (current-buffer) (list content-type)))) (mm-pipe-part handle)))) -;; This is taken from notmuch-wash: maybe it should be unified? -(defun notmuch-show-toggle-part-invisibility (&optional button) - (interactive) - (let* ((button (or button (button-at (point)))) - (overlay (button-get button 'overlay))) - (when overlay - (let* ((show (overlay-get overlay 'invisible)) - (new-start (button-start button)) - (button-label (button-get button :base-label)) - (old-point (point)) - (inhibit-read-only t)) - (overlay-put overlay 'invisible (not show)) - (goto-char new-start) - (insert "[ " button-label (if show " ]" " (hidden) ]")) - (let ((old-end (button-end button))) - (move-overlay button new-start (point)) - (delete-region (point) old-end)) - (goto-char (min old-point (1- (button-end button)))))))) - -(defun notmuch-show-multipart/*-to-list (part) - (mapcar (lambda (inner-part) (plist-get inner-part :content-type)) - (plist-get part :content))) - -(defun notmuch-show-insert-part-multipart/alternative (msg part content-type nth depth declared-type) - (notmuch-show-insert-part-header nth declared-type content-type nil) - (let ((chosen-type (car (notmuch-multipart/alternative-choose (notmuch-show-multipart/*-to-list part)))) - (inner-parts (plist-get part :content)) - (start (point))) - ;; This inserts all parts of the chosen type rather than just one, - ;; but it's not clear that this is the wrong thing to do - which - ;; should be chosen if there are more than one that match? - (mapc (lambda (inner-part) - (let* ((inner-type (plist-get inner-part :content-type)) - (hide (not (or notmuch-show-all-multipart/alternative-parts - (string= chosen-type inner-type))))) - (notmuch-show-insert-bodypart msg inner-part depth hide))) - inner-parts) - - (when notmuch-show-indent-multipart - (indent-rigidly start (point) 1))) - t) - -(defun notmuch-show-setup-w3m () - "Instruct w3m how to retrieve content from a \"related\" part of a message." - (interactive) - (if (boundp 'w3m-cid-retrieve-function-alist) - (unless (assq 'notmuch-show-mode w3m-cid-retrieve-function-alist) - (push (cons 'notmuch-show-mode 'notmuch-show-w3m-cid-retrieve) - w3m-cid-retrieve-function-alist))) - (setq mm-inline-text-html-with-images t)) - -(defvar w3m-current-buffer) ;; From `w3m.el'. -(defvar notmuch-show-w3m-cid-store nil) -(make-variable-buffer-local 'notmuch-show-w3m-cid-store) - -(defun notmuch-show-w3m-cid-store-internal (content-id - message-id - part-number - content-type - content) - (push (list content-id - message-id - part-number - content-type - content) - notmuch-show-w3m-cid-store)) - -(defun notmuch-show-w3m-cid-store (msg part) - (let ((content-id (plist-get part :content-id))) - (when content-id - (notmuch-show-w3m-cid-store-internal (concat "cid:" content-id) - (plist-get msg :id) - (plist-get part :id) - (plist-get part :content-type) - nil)))) - -(defun notmuch-show-w3m-cid-retrieve (url &rest args) - (let ((matching-part (with-current-buffer w3m-current-buffer - (assoc url notmuch-show-w3m-cid-store)))) - (if matching-part - (let ((message-id (nth 1 matching-part)) - (part-number (nth 2 matching-part)) - (content-type (nth 3 matching-part)) - (content (nth 4 matching-part))) - ;; If we don't already have the content, get it and cache - ;; it, as some messages reference the same cid: part many - ;; times (hundreds!), which results in many calls to - ;; `notmuch part'. - (unless content - (setq content (notmuch-get-bodypart-internal (notmuch-id-to-query message-id) - part-number notmuch-show-process-crypto)) - (with-current-buffer w3m-current-buffer - (notmuch-show-w3m-cid-store-internal url - message-id - part-number - content-type - content))) - (insert content) - content-type) - nil))) - -(defun notmuch-show-insert-part-multipart/related (msg part content-type nth depth declared-type) - (notmuch-show-insert-part-header nth declared-type content-type nil) - (let ((inner-parts (plist-get part :content)) - (start (point))) - - ;; We assume that the first part is text/html and the remainder - ;; things that it references. - - ;; Stash the non-primary parts. - (mapc (lambda (part) - (notmuch-show-w3m-cid-store msg part)) - (cdr inner-parts)) - - ;; Render the primary part. - (notmuch-show-insert-bodypart msg (car inner-parts) depth) - - (when notmuch-show-indent-multipart - (indent-rigidly start (point) 1))) - t) - -(defun notmuch-show-insert-part-multipart/signed (msg part content-type nth depth declared-type) - (let ((button (notmuch-show-insert-part-header nth declared-type content-type nil))) - (button-put button 'face 'notmuch-crypto-part-header) - ;; add signature status button if sigstatus provided - (if (plist-member part :sigstatus) - (let* ((from (notmuch-show-get-header :From msg)) - (sigstatus (car (plist-get part :sigstatus)))) - (notmuch-crypto-insert-sigstatus-button sigstatus from)) - ;; if we're not adding sigstatus, tell the user how they can get it - (button-put button 'help-echo "Set notmuch-crypto-process-mime to process cryptographic MIME parts."))) - - (let ((inner-parts (plist-get part :content)) - (start (point))) - ;; Show all of the parts. - (mapc (lambda (inner-part) - (notmuch-show-insert-bodypart msg inner-part depth)) - inner-parts) - - (when notmuch-show-indent-multipart - (indent-rigidly start (point) 1))) - t) - -(defun notmuch-show-insert-part-multipart/encrypted (msg part content-type nth depth declared-type) - (let ((button (notmuch-show-insert-part-header nth declared-type content-type nil))) - (button-put button 'face 'notmuch-crypto-part-header) - ;; add encryption status button if encstatus specified - (if (plist-member part :encstatus) - (let ((encstatus (car (plist-get part :encstatus)))) - (notmuch-crypto-insert-encstatus-button encstatus) - ;; add signature status button if sigstatus specified - (if (plist-member part :sigstatus) - (let* ((from (notmuch-show-get-header :From msg)) - (sigstatus (car (plist-get part :sigstatus)))) - (notmuch-crypto-insert-sigstatus-button sigstatus from)))) - ;; if we're not adding encstatus, tell the user how they can get it - (button-put button 'help-echo "Set notmuch-crypto-process-mime to process cryptographic MIME parts."))) - - (let ((inner-parts (plist-get part :content)) - (start (point))) - ;; Show all of the parts. - (mapc (lambda (inner-part) - (notmuch-show-insert-bodypart msg inner-part depth)) - inner-parts) - - (when notmuch-show-indent-multipart - (indent-rigidly start (point) 1))) - t) - -(defun notmuch-show-insert-part-multipart/* (msg part content-type nth depth declared-type) - (notmuch-show-insert-part-header nth declared-type content-type nil) - (let ((inner-parts (plist-get part :content)) - (start (point))) - ;; Show all of the parts. - (mapc (lambda (inner-part) - (notmuch-show-insert-bodypart msg inner-part depth)) - inner-parts) - - (when notmuch-show-indent-multipart - (indent-rigidly start (point) 1))) - t) - -(defun notmuch-show-insert-part-message/rfc822 (msg part content-type nth depth declared-type) - (notmuch-show-insert-part-header nth declared-type content-type nil) - (let* ((message (car (plist-get part :content))) - (body (car (plist-get message :body))) - (start (point))) - - ;; Override `notmuch-message-headers' to force `From' to be - ;; displayed. - (let ((notmuch-message-headers '("From" "Subject" "To" "Cc" "Date"))) - (notmuch-show-insert-headers (plist-get message :headers))) - - ;; Blank line after headers to be compatible with the normal - ;; message display. - (insert "\n") - - ;; Show the body - (notmuch-show-insert-bodypart msg body depth) - - (when notmuch-show-indent-multipart - (indent-rigidly start (point) 1))) - t) - -(defun notmuch-show-insert-part-text/plain (msg part content-type nth depth declared-type) - (let ((start (point))) - ;; If this text/plain part is not the first part in the message, - ;; insert a header to make this clear. - (if (> nth 1) - (notmuch-show-insert-part-header nth declared-type content-type (plist-get part :filename))) - (insert (notmuch-get-bodypart-content msg part nth notmuch-show-process-crypto)) - (save-excursion - (save-restriction - (narrow-to-region start (point-max)) - (run-hook-with-args 'notmuch-show-insert-text/plain-hook msg depth)))) - t) - -(defun notmuch-show-insert-part-text/calendar (msg part content-type nth depth declared-type) - (notmuch-show-insert-part-header nth declared-type content-type (plist-get part :filename)) - (insert (with-temp-buffer - (insert (notmuch-get-bodypart-content msg part nth notmuch-show-process-crypto)) - ;; notmuch-get-bodypart-content provides "raw", non-converted - ;; data. Replace CRLF with LF before icalendar can use it. - (goto-char (point-min)) - (while (re-search-forward "\r\n" nil t) - (replace-match "\n" nil nil)) - (let ((file (make-temp-file "notmuch-ical")) - result) - (unwind-protect - (progn - (unless (icalendar-import-buffer file t) - (error "Icalendar import error. See *icalendar-errors* for more information")) - (set-buffer (get-file-buffer file)) - (setq result (buffer-substring (point-min) (point-max))) - (set-buffer-modified-p nil) - (kill-buffer (current-buffer))) - (delete-file file)) - result))) - t) - -;; For backwards compatibility. -(defun notmuch-show-insert-part-text/x-vcalendar (msg part content-type nth depth declared-type) - (notmuch-show-insert-part-text/calendar msg part content-type nth depth declared-type)) - -(defun notmuch-show-get-mime-type-of-application/octet-stream (part) - ;; If we can deduce a MIME type from the filename of the attachment, - ;; we return that. - (if (plist-get part :filename) - (let ((extension (file-name-extension (plist-get part :filename))) - mime-type) - (if extension - (progn - (mailcap-parse-mimetypes) - (setq mime-type (mailcap-extension-to-mime extension)) - (if (and mime-type - (not (string-equal mime-type "application/octet-stream"))) - mime-type - nil)) - nil)))) - -;; Handler for wash generated inline patch fake parts. -(defun notmuch-show-insert-part-inline-patch-fake-part (msg part content-type nth depth declared-type) - (notmuch-show-insert-part-*/* msg part content-type nth depth declared-type)) - -(defun notmuch-show-insert-part-text/html (msg part content-type nth depth declared-type) - ;; text/html handler to work around bugs in renderers and our - ;; invisibile parts code. In particular w3m sets up a keymap which - ;; "leaks" outside the invisible region and causes strange effects - ;; in notmuch. We set mm-inline-text-html-with-w3m-keymap to nil to - ;; tell w3m not to set a keymap (so the normal notmuch-show-mode-map - ;; remains). - (let ((mm-inline-text-html-with-w3m-keymap nil)) - (notmuch-show-insert-part-*/* msg part content-type nth depth declared-type))) - -(defun notmuch-show-insert-part-*/* (msg part content-type nth depth declared-type) - ;; This handler _must_ succeed - it is the handler of last resort. - (notmuch-show-insert-part-header nth content-type declared-type (plist-get part :filename)) - (notmuch-mm-display-part-inline msg part nth content-type notmuch-show-process-crypto) - t) - -;; Functions for determining how to handle MIME parts. - -(defun notmuch-show-handlers-for (content-type) - "Return a list of content handlers for a part of type CONTENT-TYPE." - (let (result) - (mapc (lambda (func) - (if (functionp func) - (push func result))) - ;; Reverse order of prefrence. - (list (intern (concat "notmuch-show-insert-part-*/*")) - (intern (concat - "notmuch-show-insert-part-" - (car (notmuch-split-content-type content-type)) - "/*")) - (intern (concat "notmuch-show-insert-part-" content-type)))) - result)) - -;; - -(defun notmuch-show-insert-bodypart-internal (msg part content-type nth depth declared-type) - (let ((handlers (notmuch-show-handlers-for content-type))) - ;; Run the content handlers until one of them returns a non-nil - ;; value. - (while (and handlers - (not (condition-case err - (funcall (car handlers) msg part content-type nth depth declared-type) - (error (progn - (insert "!!! Bodypart insert error: ") - (insert (error-message-string err)) - (insert " !!!\n") nil))))) - (setq handlers (cdr handlers)))) - t) - -(defun notmuch-show-create-part-overlays (msg beg end hide) - "Add an overlay to the part between BEG and END" - (let* ((button (button-at beg)) - (part-beg (and button (1+ (button-end button))))) - - ;; If the part contains no text we do not make it toggleable. We - ;; also need to check that the button is a genuine part button not - ;; a notmuch-wash button. - (when (and button (/= part-beg end) (button-get button :base-label)) - (button-put button 'overlay (make-overlay part-beg end)) - ;; We toggle the button for hidden parts as that gets the - ;; button label right. - (save-excursion - (when hide - (notmuch-show-toggle-part-invisibility button)))))) - -(defun notmuch-show-insert-bodypart (msg part depth &optional hide) - "Insert the body part PART at depth DEPTH in the current thread. - -If HIDE is non-nil then initially hide this part." - (let* ((content-type (downcase (plist-get part :content-type))) - (mime-type (or (and (string= content-type "application/octet-stream") - (notmuch-show-get-mime-type-of-application/octet-stream part)) - (and (string= content-type "inline patch") - "text/x-diff") - content-type)) - (nth (plist-get part :id)) - (beg (point))) - - (notmuch-show-insert-bodypart-internal msg part mime-type nth depth content-type) - ;; Some of the body part handlers leave point somewhere up in the - ;; part, so we make sure that we're down at the end. - (goto-char (point-max)) - ;; Ensure that the part ends with a carriage return. - (unless (bolp) - (insert "\n")) - (notmuch-show-create-part-overlays msg beg (point) hide))) - -(defun notmuch-show-insert-body (msg body depth) - "Insert the body BODY at depth DEPTH in the current thread." - (mapc (lambda (part) (notmuch-show-insert-bodypart msg part depth)) body)) - (defun notmuch-show-make-symbol (type) (make-symbol (concat "notmuch-show-" type))) -(defun notmuch-show-strip-re (string) - (replace-regexp-in-string "^\\([Rr]e: *\\)+" "" string)) - -(defvar notmuch-show-previous-subject "") -(make-variable-buffer-local 'notmuch-show-previous-subject) - -(defun notmuch-show-insert-msg (msg depth) - "Insert the message MSG at depth DEPTH in the current thread." - (let* ((headers (plist-get msg :headers)) - ;; Indentation causes the buffer offset of the start/end - ;; points to move, so we must use markers. - message-start message-end - content-start content-end - headers-start headers-end - (bare-subject (notmuch-show-strip-re (plist-get headers :Subject)))) - - (setq message-start (point-marker)) - - (notmuch-show-insert-headerline headers - (or (if notmuch-show-relative-dates - (plist-get msg :date_relative) - nil) - (plist-get headers :Date)) - (plist-get msg :tags) depth) - - (setq content-start (point-marker)) - - ;; Set `headers-start' to point after the 'Subject:' header to be - ;; compatible with the existing implementation. This just sets it - ;; to after the first header. - (notmuch-show-insert-headers headers) - (save-excursion - (goto-char content-start) - ;; If the subject of this message is the same as that of the - ;; previous message, don't display it when this message is - ;; collapsed. - (when (not (string= notmuch-show-previous-subject - bare-subject)) - (forward-line 1)) - (setq headers-start (point-marker))) - (setq headers-end (point-marker)) - - (setq notmuch-show-previous-subject bare-subject) - - ;; A blank line between the headers and the body. - (insert "\n") - (notmuch-show-insert-body msg (plist-get msg :body) - (if notmuch-show-indent-content depth 0)) - ;; Ensure that the body ends with a newline. - (unless (bolp) - (insert "\n")) - (setq content-end (point-marker)) - - ;; Indent according to the depth in the thread. - (if notmuch-show-indent-content - (indent-rigidly content-start content-end (* notmuch-show-indent-messages-width depth))) - - (setq message-end (point-max-marker)) - - ;; Save the extents of this message over the whole text of the - ;; message. - (put-text-property message-start message-end :notmuch-message-extent (cons message-start message-end)) - - ;; Create overlays used to control visibility - (plist-put msg :headers-overlay (make-overlay headers-start headers-end)) - (plist-put msg :message-overlay (make-overlay headers-start content-end)) - - (plist-put msg :depth depth) - - ;; Save the properties for this message. Currently this saves the - ;; entire message (augmented it with other stuff), which seems - ;; like overkill. We might save a reduced subset (for example, not - ;; the content). - (notmuch-show-set-message-properties msg) - - ;; Set header visibility. - (notmuch-show-headers-visible msg notmuch-message-headers-visible) - - ;; Message visibility depends on whether it matched the search - ;; criteria. - (notmuch-show-message-visible msg (and (plist-get msg :match) - (not (plist-get msg :excluded)))))) - (defun notmuch-show-toggle-process-crypto () "Toggle the processing of cryptographic MIME parts." (interactive) @@ -1018,23 +354,6 @@ If HIDE is non-nil then initially hide this part." "Content is not indented.")) (notmuch-show-refresh-view)) -(defun notmuch-show-insert-tree (tree depth) - "Insert the message tree TREE at depth DEPTH in the current thread." - (let ((msg (car tree)) - (replies (cadr tree))) - ;; We test whether there is a message or just some replies. - (when msg - (notmuch-show-insert-msg msg depth)) - (notmuch-show-insert-thread replies (1+ depth)))) - -(defun notmuch-show-insert-thread (thread depth) - "Insert the thread THREAD at depth DEPTH in the current forest." - (mapc (lambda (tree) (notmuch-show-insert-tree tree depth)) thread)) - -(defun notmuch-show-insert-forest (forest) - "Insert the forest of threads FOREST." - (mapc (lambda (thread) (notmuch-show-insert-thread thread 0)) forest)) - (defvar notmuch-id-regexp (concat ;; Match the id: prefix only if it begins a word (to disallow, for @@ -1373,17 +692,6 @@ effects." (loop do (funcall function) while (notmuch-show-goto-message-next)))) -;; Functions relating to the visibility of messages and their -;; components. - -(defun notmuch-show-message-visible (props visible-p) - (overlay-put (plist-get props :message-overlay) 'invisible (not visible-p)) - (notmuch-show-set-prop :message-visible visible-p props)) - -(defun notmuch-show-headers-visible (props visible-p) - (overlay-put (plist-get props :headers-overlay) 'invisible (not visible-p)) - (notmuch-show-set-prop :headers-visible visible-p props)) - ;; Functions for setting and getting attributes of the current ;; message. -- 1.7.9.1