--- /dev/null
+Return-Path: <damien.cassou@gmail.com>\r
+X-Original-To: notmuch@notmuchmail.org\r
+Delivered-To: notmuch@notmuchmail.org\r
+Received: from localhost (localhost [127.0.0.1])\r
+ by olra.theworths.org (Postfix) with ESMTP id B9F2F431FB6\r
+ for <notmuch@notmuchmail.org>; Tue, 6 Nov 2012 12:40:15 -0800 (PST)\r
+X-Virus-Scanned: Debian amavisd-new at olra.theworths.org\r
+X-Spam-Flag: NO\r
+X-Spam-Score: -0.799\r
+X-Spam-Level: \r
+X-Spam-Status: No, score=-0.799 tagged_above=-999 required=5\r
+ tests=[DKIM_SIGNED=0.1, DKIM_VALID=-0.1, DKIM_VALID_AU=-0.1,\r
+ FREEMAIL_FROM=0.001, RCVD_IN_DNSWL_LOW=-0.7] autolearn=disabled\r
+Received: from olra.theworths.org ([127.0.0.1])\r
+ by localhost (olra.theworths.org [127.0.0.1]) (amavisd-new, port 10024)\r
+ with ESMTP id Lt+MmRcFhIBF for <notmuch@notmuchmail.org>;\r
+ Tue, 6 Nov 2012 12:40:13 -0800 (PST)\r
+Received: from mail-we0-f181.google.com (mail-we0-f181.google.com\r
+ [74.125.82.181]) (using TLSv1 with cipher RC4-SHA (128/128 bits))\r
+ (No client certificate requested)\r
+ by olra.theworths.org (Postfix) with ESMTPS id 72B10431FAE\r
+ for <notmuch@notmuchmail.org>; Tue, 6 Nov 2012 12:40:13 -0800 (PST)\r
+Received: by mail-we0-f181.google.com with SMTP id u54so437806wey.26\r
+ for <notmuch@notmuchmail.org>; Tue, 06 Nov 2012 12:40:12 -0800 (PST)\r
+DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20120113;\r
+ h=from:to:cc:subject:date:message-id:x-mailer:mime-version\r
+ :content-type:content-transfer-encoding;\r
+ bh=G0BgcANAm/j6xKyI8+ivHjn0FY4IBg705bo2z46F2V8=;\r
+ b=LZ/rsdRWEXQI/i0Gv6KaG/PVWpep9sJDe0c8kKBAlL+VNs77An8/9UIx7vI8gM77DV\r
+ 5wTREtd7dST/UcHfUngqXpoycLSaslbUd/ERAuITFNU3GEfot74HwHvVB7HNDm46yZIK\r
+ Aq8t4jkbhWua+cYuszJRyDzO8w8LuQkpbsR0788Z+ALu+3KgKIUbs7YvF8122Y0GFkA9\r
+ J1O4QAaIeU3sw69ytuWScFPsNje+26wAXz416KUEbipz9A+uydY7YgrTqatzJ5Z23wJE\r
+ WqJwgSeSVl44fcVdypV4+feoz8wFS9AvoZh01MVJe73m8pfN1JnKxHj/xpveGzuLiMT5\r
+ r4YQ==\r
+Received: by 10.180.92.71 with SMTP id ck7mr4184318wib.20.1352234412288;\r
+ Tue, 06 Nov 2012 12:40:12 -0800 (PST)\r
+Received: from localhost.localdomain (ble59-4-82-228-190-150.fbx.proxad.net.\r
+ [82.228.190.150])\r
+ by mx.google.com with ESMTPS id gg4sm415275wib.6.2012.11.06.12.40.10\r
+ (version=TLSv1/SSLv3 cipher=OTHER);\r
+ Tue, 06 Nov 2012 12:40:11 -0800 (PST)\r
+From: Damien Cassou <damien.cassou@gmail.com>\r
+To: notmuch mailing list <notmuch@notmuchmail.org>\r
+Subject: [PATCH] emacs: display tags in notmuch-show's header-line with links to search\r
+Date: Tue, 6 Nov 2012 21:39:04 +0100\r
+Message-Id: <1352234344-28119-1-git-send-email-damien.cassou@gmail.com>\r
+X-Mailer: git-send-email 1.7.10.4\r
+MIME-Version: 1.0\r
+Content-Type: text/plain; charset=UTF-8\r
+Content-Transfer-Encoding: 8bit\r
+X-BeenThere: notmuch@notmuchmail.org\r
+X-Mailman-Version: 2.1.13\r
+Precedence: list\r
+List-Id: "Use and development of the notmuch mail system."\r
+ <notmuch.notmuchmail.org>\r
+List-Unsubscribe: <http://notmuchmail.org/mailman/options/notmuch>,\r
+ <mailto:notmuch-request@notmuchmail.org?subject=unsubscribe>\r
+List-Archive: <http://notmuchmail.org/pipermail/notmuch>\r
+List-Post: <mailto:notmuch@notmuchmail.org>\r
+List-Help: <mailto:notmuch-request@notmuchmail.org?subject=help>\r
+List-Subscribe: <http://notmuchmail.org/mailman/listinfo/notmuch>,\r
+ <mailto:notmuch-request@notmuchmail.org?subject=subscribe>\r
+X-List-Received-Date: Tue, 06 Nov 2012 20:40:15 -0000\r
+\r
+In notmuch-show, the header-line was previously only showing the\r
+subject of the current thread. With this commit, the header-line now\r
+additionally shows all the tags associated to the thread. Each tag is\r
+a link to open a new notmuch-search buffer for this tag.\r
+\r
+This patch is the first one of an upcoming series whose goal is to\r
+integrate notmuch-labeler into notmuch. See the following for more\r
+details:\r
+https://github.com/DamienCassou/notmuch-labeler\r
+\r
+This patch includes header-button.el, a package contributed by Jonas\r
+Bernoulli that fixes a limitation of the button.el Emacs library.\r
+\r
+ATTENTION: Because I didn't get the permission of Jonas Bernoulli yet,\r
+I recommend *not* to integrate this patch into notmuch right now.\r
+Please see this email as a call for review.\r
+\r
+Note: This code breaks the two unit-tests "Do not call notmuch for\r
+non-inlinable..." that are in test/emacs. This is because these tests\r
+expect that notmuch would be called only once, but my patch forces an\r
+additional call to notmuch to get the list of tags for the current\r
+thread.\r
+\r
+---\r
+ emacs/header-button.el | 133 ++++++++++++++++++++++++++++++++++++++++++++++++\r
+ emacs/notmuch-query.el | 16 ++++++\r
+ emacs/notmuch-show.el | 20 ++++++--\r
+ emacs/notmuch-tager.el | 76 +++++++++++++++++++++++++++\r
+ test/emacs | 37 ++++++++++++++\r
+ 5 files changed, 279 insertions(+), 3 deletions(-)\r
+ create mode 100644 emacs/header-button.el\r
+ create mode 100644 emacs/notmuch-tager.el\r
+\r
+diff --git a/emacs/notmuch-query.el b/emacs/notmuch-query.el\r
+index d66baea..c1d2ec9 100644\r
+--- a/emacs/notmuch-query.el\r
++++ b/emacs/notmuch-query.el\r
+@@ -81,4 +81,20 @@ See the function notmuch-query-get-threads for more information."\r
+ (lambda (msg) (plist-get msg :id))\r
+ (notmuch-query-get-threads search-terms)))\r
+ \r
++(defun notmuch-query-thread-tags-from-id (thread-id)\r
++ "Return the tags of thread whose id is THREAD-ID.\r
++The thread tags are the union of the tags of emails in the\r
++thread."\r
++ (let ((tag-lists\r
++ (notmuch-query-map-forest\r
++ (lambda (msg) (plist-get msg :tags))\r
++ (car (notmuch-query-get-threads\r
++ (list (concat "thread:" thread-id)))))))\r
++ (case (length tag-lists)\r
++ (0 nil)\r
++ (1 (car tag-lists))\r
++ (otherwise (reduce (lambda (l1 l2)\r
++ (union l1 l2 :test 'string=))\r
++ tag-lists)))))\r
++\r
+ (provide 'notmuch-query)\r
+diff --git a/emacs/notmuch-show.el b/emacs/notmuch-show.el\r
+index f273eb4..3a09998 100644\r
+--- a/emacs/notmuch-show.el\r
++++ b/emacs/notmuch-show.el\r
+@@ -36,6 +36,7 @@\r
+ (require 'notmuch-mua)\r
+ (require 'notmuch-crypto)\r
+ (require 'notmuch-print)\r
++(require 'notmuch-tager)\r
+ \r
+ (declare-function notmuch-call-notmuch-process "notmuch" (&rest args))\r
+ (declare-function notmuch-fontify-headers "notmuch" nil)\r
+@@ -1048,6 +1049,12 @@ function is used."\r
+ (notmuch-show-goto-first-wanted-message)\r
+ (current-buffer)))\r
+ \r
++(defun notmuch-show-thread-id ()\r
++ "Return the raw thread id of the currently visited thread."\r
++ ;; `notmuch-show-thread-id' is of the form "thread:00001212" so we\r
++ ;; have to extract the second part.\r
++ (second (split-string notmuch-show-thread-id ":")))\r
++\r
+ (defun notmuch-show-build-buffer ()\r
+ (let ((inhibit-read-only t))\r
+ \r
+@@ -1077,11 +1084,18 @@ function is used."\r
+ \r
+ (jit-lock-register #'notmuch-show-buttonise-links)\r
+ \r
+- ;; Set the header line to the subject of the first message.\r
+- (setq header-line-format (notmuch-show-strip-re (notmuch-show-get-subject)))\r
+-\r
++ (notmuch-show-update-header-line)\r
+ (run-hooks 'notmuch-show-hook))))\r
+ \r
++(defun notmuch-show-update-header-line ()\r
++ "Make the header-line show the thread's subject and tags."\r
++ (let ((thread-subject (notmuch-show-strip-re (notmuch-show-get-subject))))\r
++ (setq header-line-format\r
++ (cons\r
++ thread-subject\r
++ (notmuch-tager-present-tags\r
++ (notmuch-query-thread-tags-from-id (notmuch-show-thread-id)))))))\r
++\r
+ (defun notmuch-show-capture-state ()\r
+ "Capture the state of the current buffer.\r
+ \r
+diff --git a/emacs/notmuch-tager.el b/emacs/notmuch-tager.el\r
+new file mode 100644\r
+index 0000000..1f83e29\r
+--- /dev/null\r
++++ b/emacs/notmuch-tager.el\r
+@@ -0,0 +1,76 @@\r
++;; notmuch-tager.el --- Library to show labels as links\r
++;;\r
++;; Copyright © Damien Cassou\r
++;;\r
++;; This file is part of Notmuch.\r
++;;\r
++;; Notmuch is free software: you can redistribute it and/or modify it\r
++;; under the terms of the GNU General Public License as published by\r
++;; the Free Software Foundation, either version 3 of the License, or\r
++;; (at your option) any later version.\r
++;;\r
++;; Notmuch is distributed in the hope that it will be useful, but\r
++;; WITHOUT ANY WARRANTY; without even the implied warranty of\r
++;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU\r
++;; General Public License for more details.\r
++;;\r
++;; You should have received a copy of the GNU General Public License\r
++;; along with Notmuch. If not, see <http://www.gnu.org/licenses/>.\r
++;;\r
++;; Authors: Damien Cassou <damien.cassou@gmail.com>\r
++;;; Commentary:\r
++;;\r
++;;; Code:\r
++;;\r
++\r
++(require 'button)\r
++(require 'header-button)\r
++\r
++(defun notmuch-tager-separate-elems (list sep)\r
++ "Return a list with all elements of LIST separated by SEP."\r
++ (let ((first t)\r
++ (res nil))\r
++ (dolist (elt (reverse list) res)\r
++ (unless first\r
++ (push sep res))\r
++ (setq first nil)\r
++ (push elt res))))\r
++\r
++(defun notmuch-tager-goto-target (target)\r
++ "Show a `notmuch-search' buffer for the TARGET tag."\r
++ (notmuch-search (concat "tag:" target)))\r
++\r
++(defun notmuch-tager-button-action (button)\r
++ "Open `notmuch-search' for the tag referenced by BUTTON."\r
++ (let ((tag (header-button-get button :notmuch-tager-tag)))\r
++ (notmuch-tager-goto-target tag)))\r
++\r
++(define-button-type 'notmuch-tager-button-type\r
++ :supertype 'header\r
++ :action 'notmuch-tager-button-action\r
++ :follow-link t)\r
++\r
++(defun notmuch-tager-make-link (target)\r
++ "Return a property list that presents a link to TARGET.\r
++\r
++TARGET is a notmuch tag."\r
++ (header-button-format\r
++ target\r
++ :type 'notmuch-tager-button-type\r
++ :notmuch-tager-tag target\r
++ :help-echo (format "%s: Search other messages like this" target)))\r
++\r
++(defun notmuch-tager-format-tags (tags)\r
++ "Return a format list for TAGS suitable for use in header line.\r
++See Info node `(elisp)Mode Line Format' for more information."\r
++ (mapcar 'notmuch-tager-make-link tags))\r
++\r
++(defun notmuch-tager-present-tags (tags)\r
++ "Return a property list which nicely presents all TAGS."\r
++ (list\r
++ " ("\r
++ (notmuch-tager-separate-elems (notmuch-tager-format-tags tags) ", ")\r
++ ")"))\r
++\r
++(provide 'notmuch-tager)\r
++;;; notmuch-tager.el ends here\r
+diff --git a/test/emacs b/test/emacs\r
+index 44f641e..c062e4d 100755\r
+--- a/test/emacs\r
++++ b/test/emacs\r
+@@ -820,5 +820,42 @@ Date: Fri, 05 Jan 2001 15:43:57 +0000\r
+ EOF\r
+ test_expect_equal_file OUTPUT EXPECTED\r
+ \r
++test_begin_subtest "Extracting all tags from a thread"\r
++add_message \\r
++ '[subject]="Extracting all tags from a thread"' \\r
++ '[body]="body 1"'\r
++parent=${gen_msg_id}\r
++add_message \\r
++ '[subject]="Extracting all tags from a thread"' \\r
++ '[body]="body 2"' \\r
++ "[in-reply-to]=\<$parent\>"\r
++add_message \\r
++ '[subject]="Extracting all tags from a thread"' \\r
++ '[body]="body 3"' \\r
++ "[in-reply-to]=\<$parent\>"\r
++latest=${gen_msg_id}\r
++# Extract the thread-id from one of the emails\r
++thread_id=$(notmuch search id:${latest} | sed -e "s/thread:\([a-f0-9]*\).*/\1/")\r
++# Add tag "mytagfoo" to one of the emails\r
++notmuch tag +mytagfoo id:${latest}\r
++test_emacs_expect_t \\r
++ "(let ((output (notmuch-query-thread-tags-from-id \"${thread_id}\"))\r
++ (expected '(\"inbox\" \"mytagfoo\" \"unread\")))\r
++ (notmuch-test-expect-equal output expected))"\r
++\r
++test_begin_subtest "The tags appear in the header-line of notmuch-show"\r
++add_message \\r
++ '[subject]="foo bar"' \\r
++ '[body]="body 1"'\r
++parent=${gen_msg_id}\r
++# Add tag "mytagfoo" to one of the emails\r
++notmuch tag +mytagfoo id:${parent}\r
++# Extract the thread-id from one of the emails\r
++thread_id=$(notmuch search id:${latest} | sed -e "s/thread:\([a-f0-9]*\).*/\1/")\r
++test_emacs_expect_t \\r
++ "(notmuch-show \"thread:${thread_id}\")\r
++ (if (string-match-p \"mytagfoo\" (format-mode-line header-line-format))\r
++ t\r
++ \"The tag mytagfoo was not in the header-line-format\")"\r
+ \r
+ test_done\r
+\r
+diff --git a/emacs/header-button.el b/emacs/header-button.el\r
+new file mode 100644\r
+index 0000000..9b0cbcf\r
+--- /dev/null\r
++++ b/emacs/header-button.el\r
+@@ -0,0 +1,133 @@\r
++;;; header-button.el --- clickable buttons in header lines\r
++\r
++;; Copyright (C) 2010-2012 Jonas Bernoulli\r
++\r
++;; Author: Jonas Bernoulli <jonas@bernoul.li>\r
++;; Created: 20100604\r
++;; Version: 0.2.2\r
++;; Homepage: https://github.com/tarsius/header-button\r
++;; Keywords: extensions\r
++\r
++;; This file is not part of GNU Emacs.\r
++\r
++;; This file is free software; you can redistribute it and/or modify\r
++;; it under the terms of the GNU General Public License as published by\r
++;; the Free Software Foundation; either version 3, or (at your option)\r
++;; any later version.\r
++\r
++;; This file is distributed in the hope that it will be useful,\r
++;; but WITHOUT ANY WARRANTY; without even the implied warranty of\r
++;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\r
++;; GNU General Public License for more details.\r
++\r
++;; You should have received a copy of the GNU General Public License\r
++;; along with this program. If not, see <http://www.gnu.org/licenses/>.\r
++\r
++;;; Commentary:\r
++\r
++;; This package extends `button' by adding support for adding buttons to\r
++;; the header line. Since the header line is very limited compared to a\r
++;; buffer most of the functionality provided by `button' is not available\r
++;; for buttons in the header line.\r
++\r
++;; While `button' provides the function `insert-button' (as well as\r
++;; others) to insert a button into a buffer at point, something similar\r
++;; can't be done here, due to the lack of point in header lines.\r
++\r
++;; Instead us `header-button-format' like this:\r
++;;\r
++;; (setq header-line-format\r
++;; (concat "Here's a button: "\r
++;; (header-button-format "Click me!" :action 'my-action)))\r
++\r
++;; Like with `button' you can create your own derived button types:\r
++;;\r
++;; (define-button-type 'my-header\r
++;; :supertype 'header\r
++;; :action 'my-action)\r
++;;\r
++;; (setq header-line-format\r
++;; (concat (header-button-format "Click me!" :action 'my-action) " "\r
++;; (header-button-format "No me!" :type 'my-header)))\r
++\r
++;; The function associated with `:action' is called with the button plist\r
++;; as only argument. Do no use `plist-get' to extract a value from it.\r
++;; Instead use `header-button-get' which will also extract values stored\r
++;; in it's type.\r
++;;\r
++;; (defun my-action (button)\r
++;; (message "This button labeled `%s' belongs to category `%s'"\r
++;; (header-button-label button)\r
++;; (header-button-get button 'category)))\r
++\r
++;;; Code:\r
++\r
++(require 'button)\r
++\r
++(defvar header-button-map\r
++ (let ((map (make-sparse-keymap)))\r
++ ;; $$$ follow-link does not work here\r
++ (define-key map [header-line mouse-1] 'header-button-push)\r
++ (define-key map [header-line mouse-2] 'header-button-push)\r
++ map)\r
++ "Keymap used by buttons in header lines.")\r
++\r
++(define-button-type 'header\r
++ 'keymap header-button-map\r
++ 'help-echo (purecopy "mouse-1: Push this button"))\r
++\r
++(defun header-button-get (button prop)\r
++ "Get the property of header button BUTTON named PROP."\r
++ (let ((entry (plist-member button prop)))\r
++ (if entry\r
++ (cadr entry)\r
++ (get (plist-get button 'category) prop))))\r
++\r
++(defun header-button-label (button)\r
++ "Return header button BUTTON's text label."\r
++ (plist-get button 'label))\r
++\r
++(defun header-button-format (label &rest properties)\r
++ "Format a header button string with the label LABEL.\r
++The remaining arguments form a sequence of PROPERTY VALUE pairs,\r
++specifying properties to add to the button.\r
++In addition, the keyword argument :type may be used to specify a\r
++button-type from which to inherit other properties; see\r
++`define-button-type'.\r
++\r
++To actually create the header button set the value of variable\r
++`header-line-format' to the string returned by this function\r
++\(or a string created by concatenating that string with others."\r
++ (let ((type-entry (or (plist-member properties 'type)\r
++ (plist-member properties :type))))\r
++ (when (plist-get properties 'category)\r
++ (error "Button `category' property may not be set directly"))\r
++ (if (null type-entry)\r
++ (setq properties\r
++ (cons 'category\r
++ (cons (button-category-symbol 'header) properties)))\r
++ (setcar type-entry 'category)\r
++ (setcar (cdr type-entry)\r
++ (button-category-symbol (car (cdr type-entry)))))\r
++ (apply #'propertize label\r
++ (nconc (list 'button (list t) 'label label) properties))))\r
++\r
++(defun header-button-activate (button)\r
++ "Call header button BUTTON's `:action' property."\r
++ (funcall (header-button-get button :action) button))\r
++\r
++(defun header-button-push ()\r
++ "Perform the action specified by the pressed header button."\r
++ (interactive)\r
++ (let* ((posn (event-start last-command-event))\r
++ (object (posn-object posn))\r
++ (buffer (window-buffer (posn-window posn)))\r
++ (button (text-properties-at (cdr object) (car object))))\r
++ (with-current-buffer buffer\r
++ (header-button-activate button))))\r
++\r
++(provide 'header-button)\r
++;; Local Variables:\r
++;; indent-tabs-mode: nil\r
++;; End:\r
++;;; header-button.el ends here\r
+-- \r
+1.7.10.4\r
+\r
projects / notmuch-archives.git / commitdiff