X-Git-Url: https://code.delx.au/gnu-emacs-elpa/blobdiff_plain/518a30e128e4035c02385178501f60d5686f97bd..368dbd026fe0ebd0f9f50be09d0f2a5f58d06c0a:/packages/debbugs/debbugs.el diff --git a/packages/debbugs/debbugs.el b/packages/debbugs/debbugs.el index 158390a2a..03211a1fc 100644 --- a/packages/debbugs/debbugs.el +++ b/packages/debbugs/debbugs.el @@ -1,11 +1,11 @@ ;;; debbugs.el --- SOAP library to access debbugs servers -;; Copyright (C) 2011 Free Software Foundation, Inc. +;; Copyright (C) 2011, 2012 Free Software Foundation, Inc. ;; Author: Michael Albinus ;; Keywords: comm, hypermedia ;; Package: debbugs -;; Version: 0.1 +;; Version: 0.3 ;; This file is part of GNU Emacs. @@ -27,8 +27,7 @@ ;; This package provides some basic functions to access a debbugs SOAP ;; server (see ). -;; The SOAP functions "get_usertag" and "get_versions" are not -;; implemented (yet). +;; The SOAP function "get_versions" is not implemented (yet). ;;; Code: @@ -98,22 +97,34 @@ This corresponds to the Debbugs server to be accessed, either (defun debbugs-get-bugs (&rest query) "Return a list of bug numbers which match QUERY. -QUERY is a keyword value sequence, whereby the values are strings. -All queries are concatenated via AND. +QUERY is a sequence of keyword-value pairs where the values are +strings, i.e. :KEYWORD \"VALUE\" [:KEYWORD \"VALUE\"]* + +The keyword-value pair is a subquery. The keywords are allowed to +have multiple occurrence within the query at any place. The +subqueries with the same keyword form the logical subquery, which +returns the union of bugs of every subquery it contains. + +The result of the QUERY is an intersection of results of all +subqueries. Valid keywords are: :package -- The value is the name of the package a bug belongs to, like \"emacs\", \"coreutils\", \"gnus\", or \"tramp\". - :severity -- This is the severity of the bug. Currently, - there exists the severities \"important\", \"grave\", - \"normal\", \"minor\" and \"wishlist\". + :src -- This is used to retrieve bugs that belong to source + with given name. + + :severity -- This is the severity of the bug. The exact set of + allowed values depends on the Debbugs port. Examples are + \"normal\", \"minor\", \"wishlist\" etc. :tag -- An arbitrary string the bug is annotated with. Usually, this is used to mark the status of the bug, like \"fixed\", \"moreinfo\", \"notabug\", \"patch\", - \"unreproducible\" or \"wontfix\". + \"unreproducible\" or \"wontfix\". The exact set of tags + depends on the Debbugs port. :owner -- This is used to identify bugs by the owner's email address. The special email address \"me\" is used as pattern, @@ -123,50 +134,78 @@ Valid keywords are: by the submitter's email address. The special email address \"me\" is used as pattern, replaced with `user-mail-address'. + :maint -- This is used to find bugs of the packages which are + maintained by the person with the given email address. The + special email address \"me\" is used as pattern, replaced with + `user-mail-address'. + + :correspondent -- This allows to find bug reports where the + person with the given email address has participated. The + special email address \"me\" is used as pattern, replaced with + `user-mail-address'. + + :affects -- With this keyword it is possible to find bugs which + affect the package with the given name. The bugs are chosen by + the value of field `affects' in bug's status. The returned bugs + do not necessary belong to this package. + + :status -- Status of bug. Valid values are \"done\", + \"forwarded\" and \"open\". + :archive -- A keyword to filter for bugs which are already archived, or not. Valid values are \"0\" (not archived), \"1\" (archived) or \"both\". If this keyword is not given in the query, `:archive \"0\"' is assumed by default. -Example: +Example. Get all opened and forwarded release critical bugs for +the packages which are maintained by \"me\" and which have a +patch: - \(debbugs-get-bugs :submitter \"me\" :archive \"both\") - => \(5516 5551 5645 7259)" + \(debbugs-get-bugs :maint \"me\" :tag \"patch\" + :severity \"critical\" + :status \"open\" + :severity \"grave\" + :status \"forwarded\" + :severity \"serious\")" - (let (vec key val) + (let (vec kw key val) ;; Check query. (while (and (consp query) (<= 2 (length query))) - (setq key (pop query) - val (pop query) - vec (vconcat vec (list (substring (symbol-name key) 1)))) - (unless (and (keywordp key) (stringp val)) - (error "Wrong query: %s %s" key val)) - (case key - ((:package :severity :tag) + (setq kw (pop query) + val (pop query)) + (unless (and (keywordp kw) (stringp val)) + (error "Wrong query: %s %s" kw val)) + (setq key (substring (symbol-name kw) 1)) + (case kw + ((:package :severity :tag :src :affects) ;; Value shall be one word. - (if (string-match "\\`[A-Za-z]+\\'" val) - (setq vec (vconcat vec (list val))) - (error "Wrong %s: %s" (car (last vec)) val))) - ;; Value is an email address. - ((:owner :submitter) + (if (string-match "\\`\\S-+\\'" val) + (setq vec (vconcat vec (list key val))) + (error "Wrong %s: %s" key val))) + ((:owner :submitter :maint :correspondent) + ;; Value is an email address. (if (string-match "\\`\\S-+\\'" val) (progn (when (string-equal "me" val) (setq val user-mail-address)) (when (string-match "<\\(.+\\)>" val) (setq val (match-string 1 val))) - (setq vec (vconcat vec (list val)))) - (error "Wrong %s: %s" (car (last vec)) val))) + (setq vec (vconcat vec (list key val)))) + (error "Wrong %s: %s" key val))) + (:status + ;; Possible values: "done", "forwarded" and "open" + (if (string-match "\\`\\(done\\|forwarded\\|open\\)\\'" val) + (setq vec (vconcat vec (list key val))) + (error "Wrong %s: %s" key val))) (:archive ;; Value is `0' or `1' or `both'. (if (string-match "\\`\\(0\\|1\\|both\\)\\'" val) - (setq vec (vconcat vec (list val))) - (error "Wrong %s: %s" (car (last vec)) val))) - (t (error "Unknown key: %s" (car (last vec)))))) + (setq vec (vconcat vec (list key val))) + (error "Wrong %s: %s" key val))) + (t (error "Unknown key: %s" kw)))) (unless (null query) (error "Unknown key: %s" (car query))) - (sort (car (soap-invoke debbugs-wsdl debbugs-port "get_bugs" vec)) '<))) (defun debbugs-newest-bugs (amount) @@ -234,7 +273,7 @@ Example: \(debbugs-get-status 10) - => ;; Attributes with empty values are not show + => ;; Attributes with empty values are not shown \(\(\(bug_num . 10) \(source . \"unknown\") \(date . 1203606305.0) @@ -248,37 +287,114 @@ Example: \(last_modified . 1271200046.0) \(pending . \"pending\") \(package \"emacs\")))" - (let ((object - (car - (soap-invoke - debbugs-wsdl debbugs-port "get_status" - (apply 'vector bug-numbers))))) - (mapcar - (lambda (x) - (let (y) - ;; "archived" is the number 1 or 0. - (setq y (assoc 'archived (cdr (assoc 'value x)))) - (setcdr y (= (cdr y) 1)) - ;; "found_versions" and "fixed_versions" are lists, - ;; containing strings or numbers. - (dolist (attribute '(found_versions fixed_versions)) - (setq y (assoc attribute (cdr (assoc 'value x)))) - (setcdr y (mapcar - (lambda (z) (if (numberp z) (number-to-string z) z)) - (cdr y)))) - ;; "mergedwith" is a string, containing blank separated bug numbers. - (setq y (assoc 'mergedwith (cdr (assoc 'value x)))) - (when (stringp (cdr y)) - (setcdr y (mapcar 'string-to-number (split-string (cdr y) " " t)))) - ;; "package" is a string, containing comma separated package names. - ;; "keywords" and "tags" are strings, containing blank - ;; separated package names. - (dolist (attribute '(package keywords tags)) - (setq y (assoc attribute (cdr (assoc 'value x)))) + (when bug-numbers + (let ((object + (car + (soap-invoke + debbugs-wsdl debbugs-port "get_status" + (apply 'vector bug-numbers))))) + (mapcar + (lambda (x) + (let (y) + ;; "archived" is the number 1 or 0. + (setq y (assoc 'archived (cdr (assoc 'value x)))) + (setcdr y (= (cdr y) 1)) + ;; "found_versions" and "fixed_versions" are lists, + ;; containing strings or numbers. + (dolist (attribute '(found_versions fixed_versions)) + (setq y (assoc attribute (cdr (assoc 'value x)))) + (setcdr y (mapcar + (lambda (z) (if (numberp z) (number-to-string z) z)) + (cdr y)))) + ;; "mergedwith" is a string, containing blank separated bug numbers. + (setq y (assoc 'mergedwith (cdr (assoc 'value x)))) (when (stringp (cdr y)) - (setcdr y (split-string (cdr y) ",\\| " t)))) - (cdr (assoc 'value x)))) - object))) + (setcdr y (mapcar 'string-to-number (split-string (cdr y) " " t)))) + ;; "package" is a string, containing comma separated + ;; package names. "keywords" and "tags" are strings, + ;; containing blank separated package names. + (dolist (attribute '(package keywords tags)) + (setq y (assoc attribute (cdr (assoc 'value x)))) + (when (stringp (cdr y)) + (setcdr y (split-string (cdr y) ",\\| " t)))) + (cdr (assoc 'value x)))) + object)))) + +(defun debbugs-get-usertag (&rest query) + "Return a list of bug numbers which match QUERY. + +QUERY is a sequence of keyword-value pairs where the values are +strings, i.e. :KEYWORD \"VALUE\" [:KEYWORD \"VALUE\"]* + +Valid keywords are: + + :user -- The value is the name of the package a bug belongs to, + like \"emacs\", \"coreutils\", \"gnus\", or \"tramp\". It can + also be an email address of a user who has applied a user tag. + The special email address \"me\" is used as pattern, replaced + with `user-mail-address'. There must be at least one such + entry; it is recommended to have exactly one. + + :tag -- A string applied as user tag. Often, it is a + subproduct identification, like \"cedet\" or \"tramp\" for the + package \"emacs\". + +If there is no :tag entry, no bug numbers will be returned but a list of +existing user tags for :user. + +Example: + + \(debbugs-get-usertag :user \"emacs\") + + => (\"www\" \"solaris\" \"ls-lisp\" \"cygwin\") + + \(debbugs-get-usertag :user \"emacs\" :tag \"www\" :tag \"cygwin\") + + => (807 1223 5637)" + + (let (user tags kw key val object result) + ;; Check query. + (while (and (consp query) (<= 2 (length query))) + (setq kw (pop query) + val (pop query)) + (unless (and (keywordp kw) (stringp val)) + (error "Wrong query: %s %s" kw val)) + (setq key (substring (symbol-name kw) 1)) + (case kw + ((:user) + ;; Value shall be one word. Extract email address, if existing. + (if (string-match "\\`\\S-+\\'" val) + (progn + (when (string-equal "me" val) + (setq val user-mail-address)) + (when (string-match "<\\(.+\\)>" val) + (setq val (match-string 1 val))) + (add-to-list 'user val)) + (error "Wrong %s: %s" key val))) + ((:tag) + ;; Value shall be one word. + (if (string-match "\\`\\S-+\\'" val) + (add-to-list 'tags val) + (error "Wrong %s: %s" key val))) + (t (error "Unknown key: %s" kw)))) + + (unless (null query) + (error "Unknown key: %s" (car query))) + (unless (= (length user) 1) + (error "There must be exactly one :user entry")) + + (setq + object + (car (soap-invoke debbugs-wsdl debbugs-port "get_usertag" (car user)))) + + (if (null tags) + ;; Return the list of existing tags. + (mapcar (lambda (x) (symbol-name (car x))) object) + + ;; Return bug numbers. + (dolist (elt object result) + (when (member (symbol-name (car elt)) tags) + (setq result (append (cdr elt) result))))))) (defun debbugs-get-bug-log (bug-number) "Return a list of messages related to BUG-NUMBER. @@ -296,6 +412,252 @@ Every message is an association list with the following attributes: implemented yet server side." (car (soap-invoke debbugs-wsdl debbugs-port "get_bug_log" bug-number))) +(defun debbugs-search-est (&rest query) + "Return the result of a full text search according to QUERY. + +QUERY is a sequence of lists of keyword-value pairs where the +values are strings or numbers, i.e. :KEYWORD \"VALUE\" [:KEYWORD +VALUE]* + +Every sublist of the QUERY forms a hyperestraier condition. A +detailed description of hyperestraier conditions can be found at +URL `http://fallabs.com/hyperestraier/uguide-en.html#searchcond'. + +The following conditions are possible: + +\[:phrase SEARCH-PHRASE :skip NUMBER :max NUMBER\] + + The string SEARCH-PHRASE forms the search on the database. It + contains words to be searched for, combined by operators like + AND, ANDNOT and OR. If there is no operator between the words, + AND is used by default. The phrase keyword and value can also + be omitted, this is useful in combination with other conditions. + + :skip and :max are optional. They specify, how many hits are + skipped, and how many maximal hits are returned. This can be + used for paged results. Per default, :skip is 0 and :max is 10. + + There must be exactly one such condition. + +\[ATTRIBUTE VALUE+ :operation OPERATION :order ORDER\] + + ATTRIBUTE is one of the following keywords: + + :status -- Status of bug. Valid values are \"done\", + \"forwarded\" and \"open\". + + :subject, :@title -- The subject of a message or the title of + the bug, a string. + + :date, :@cdate -- The submission or modification dates of a + message, a number. + + :submitter, :@author -- The email address of the submitter of a + bug or the author of a message belonging to this bug, a string. + The special email address \"me\" is used as pattern, replaced + with `user-mail-address'. + + :package -- The value is the name of the package a bug belongs + to, like \"emacs\", \"coreutils\", \"gnus\", or \"tramp\". + + :tags -- An arbitrary string the bug is annotated with. + + :severity -- This is the severity of the bug. The exact set of + allowed values depends on the Debbugs port. Examples are + \"normal\", \"minor\", \"wishlist\" etc. + + :operator defines the comparison operator to be applied to + ATTRIBUTE. For string attributes this could be \"STREQ\" \(is + equal to the string), \"STRNE\" \(is not equal to the string), + \"STRINC\" \(includes the string), \"STRBW\" \(begins with the + string), \"STREW\" \(ends with the string), \"STRAND\" + \(includes all tokens in the string), \"STROR\" \(includes at + least one token in the string), \"STROREQ\" \(is equal to at + least one token in the string) or \"STRRX\" \(matches regular + expressions of the string). For operators with tokens, several + values for ATTRIBUTE shall be used. + + Numbers can be compared by the operators \"NUMEQ\" \(is equal + to the number), \"NUMNE\" \(is not equal to the number), + \"NUMGT\" \(is greater than the number), \"NUMGE\" \(is greater + than or equal to the number), \"NUMLT\" \(is less than the + number), \"NUMLE\" \(is less than or equal to the number) or + \"NUMBT\" \(is between the two numbers). In the last case, + there must be two values for ATTRIBUTE. + + If an operator is leaded by \"!\", the meaning is inverted. If + a string operator is leaded by \"I\", the case of the value is + ignored. + + The optional :order can be specified only in one condition. It + means, that ATTRIBUTE is used for sorting the results. The + following order operators exist: \"STRA\" \(ascending by + string), \"STRD\" \(descending by string), \"NUMA\" \(ascending + by number) or \"NUMD\" \(descending by number). + + A special case is an :order, where there is no corresponding + attribute value and no operator. In this case, ATTRIBUTE is + not used for the search. + +The result of the QUERY is a list of association lists with the +same attributes as in the conditions. Additional attributes are + + `id': The bug number. + + `msg_num': The number of the message inside the bug log. + + `snippet': The surrounding text found by the search. For the + syntax of the snippet, consult the hyperestraier user guide. + +Examples: + + \(debbugs-search-est + '\(:phrase \"armstrong AND debbugs\" :skip 10 :max 2) + '\(:severity \"normal\" :operator \"STRINC\") + '\(:date :order \"NUMA\")) + + => \(\(\(msg_num . 21) + \(date . 1229208302) + \(@author . \"Glenn Morris \") + \(@title . \"Re: bug#1567: Mailing an archived bug\") + \(id . 1567) + \(severity . \"normal\") + \(@cdate . \"Wed, 17 Dec 2008 14:34:50 -0500\") + \(snippet . \"...\") + \(subject . \"Mailing an archived bug\") + \(package . \"debbugs.gnu.org\")) + ...) + + ;; Show all messages from me between 2011-08-01 and 2011-08-31. + \(debbugs-search-est + '\(:max 20) + '\(:@author \"me\" :operator \"ISTRINC\") + `\(:date + ,\(floor \(float-time \(encode-time 0 0 0 1 8 2011))) + ,\(floor \(float-time \(encode-time 0 0 0 31 8 2011))) + :operator \"NUMBT\"))" + + (let (args result) + ;; Compile search arguments. + (dolist (elt query) + (let (vec kw key val + phrase-cond attr-cond) + + ;; Phrase is mandatory, even if empty. + (when (and (or (member :skip elt) (member :max elt)) + (not (member :phrase elt))) + (setq vec (vector "phrase" ""))) + + ;; Parse condition. + (while (consp elt) + (setq kw (pop elt)) + (unless (keywordp kw) + (error "Wrong keyword: %s" kw)) + (setq key (substring (symbol-name kw) 1)) + (case kw + ;; Phrase condition. + (:phrase + ;; It shouldn't happen in an attribute condition. + (if attr-cond + (error "Wrong keyword: %s" kw)) + (setq phrase-cond t val (pop elt)) + ;; Value is a string. + (if (stringp val) + (setq vec (vconcat vec (list key val))) + (error "Wrong %s: %s" key val))) + + ((:skip :max) + ;; It shouldn't happen in an attribute condition. + (if attr-cond + (error "Wrong keyword: %s" kw)) + (setq phrase-cond t val (pop elt)) + ;; Value is a number. + (if (numberp val) + (setq vec (vconcat vec (list key (number-to-string val)))) + (error "Wrong %s: %s" key val))) + + ;; Attribute condition. + ((:submitter :@author) + ;; It shouldn't happen in a phrase condition. + (if phrase-cond + (error "Wrong keyword: %s" kw)) + (if (not (stringp (car elt))) + (setq vec (vconcat vec (list key ""))) + ;; Value is an email address. + (while (and (stringp (car elt)) + (string-match "\\`\\S-+\\'" (car elt))) + (when (string-equal "me" (car elt)) + (setcar elt user-mail-address)) + (when (string-match "<\\(.+\\)>" (car elt)) + (setcar elt (match-string 1 (car elt)))) + (add-to-list 'val (pop elt) 'append)) + (setq vec + (vconcat vec (list key (mapconcat 'identity val " ")))))) + + (:status + ;; It shouldn't happen in a phrase condition. + (if phrase-cond + (error "Wrong keyword: %s" kw)) + (setq attr-cond t) + (if (not (stringp (car elt))) + (setq vec (vconcat vec (list key ""))) + ;; Possible values: "done", "forwarded" and "open" + (while (and (stringp (car elt)) + (string-match + "\\`\\(done\\|forwarded\\|open\\)\\'" (car elt))) + (add-to-list 'val (pop elt) 'append)) + (setq vec + (vconcat vec (list key (mapconcat 'identity val " ")))))) + + ((:subject :package :tags :severity :@title) + ;; It shouldn't happen in a phrase condition. + (if phrase-cond + (error "Wrong keyword: %s" kw)) + (setq attr-cond t) + (if (not (stringp (car elt))) + (setq vec (vconcat vec (list key ""))) + ;; Just a string. + (while (stringp (car elt)) + (add-to-list 'val (pop elt) 'append)) + (setq vec + (vconcat vec (list key (mapconcat 'identity val " ")))))) + + ((:date :@cdate) + ;; It shouldn't happen in a phrase condition. + (if phrase-cond + (error "Wrong keyword: %s" kw)) + (setq attr-cond t) + (if (not (numberp (car elt))) + (setq vec (vconcat vec (list key ""))) + ;; Just a number. + (while (numberp (car elt)) + (add-to-list 'val (pop elt) 'append)) + (setq vec + (vconcat + vec (list key (mapconcat 'number-to-string val " ")))))) + + ((:operator :order) + ;; It shouldn't happen in a phrase condition. + (if phrase-cond + (error "Wrong keyword: %s" kw)) + (setq attr-cond t val (pop elt)) + ;; Value is a number. + (if (stringp val) + (setq vec (vconcat vec (list key val))) + (error "Wrong %s: %s" key val))) + + (t (error "Unknown key: %s" kw)))) + + (setq args (vconcat args (list vec))))) + + (setq result + (car (soap-invoke debbugs-wsdl debbugs-port "search_est" args))) + ;; The result contains lists (key value). We transform it into + ;; cons cells (key . value). + (dolist (elt1 result result) + (dolist (elt2 elt1) + (setcdr elt2 (cadr elt2)))))) + (defun debbugs-get-attribute (bug-or-message attribute) "Return the value of key ATTRIBUTE. @@ -340,7 +702,7 @@ Example: Return the first message of last submitted bug. (defun debbugs-get-mbox (bug-number mbox-type &optional filename) "Download mbox with messages of bug BUG-NUMBER from Debbugs server. -BUG-NUMBER is a number of bug. It must be of integer type. +BUG-NUMBER is a number of bug. It must be of integer type. MBOX-TYPE specifies a type of mbox and can be one of the following symbols: @@ -349,14 +711,13 @@ following symbols: `mboxmaint': Download maintainer's mbox. - `mboxstat', `mboxstatus': Download status mbox. The use of - either symbol depends on actual Debbugs server - configuration. For gnu.org, use the former; for debian.org - - the latter. + `mboxstat', `mboxstatus': Download status mbox. The use of + either symbol depends on actual Debbugs server configuration. + For gnu.org, use the former; for debian.org - the latter. -FILENAME, if non-nil, is the name of file to store mbox. If -FILENAME is nil, the downloaded mbox is inserted into the current -buffer." +FILENAME, if non-`nil', is the name of file to store mbox. If +FILENAME is `nil', the downloaded mbox is inserted into the +current buffer." (let (url (mt "") bn) (unless (setq url (plist-get (cdr (assoc debbugs-port debbugs-servers)) @@ -373,199 +734,6 @@ buffer." (url-copy-file url filename t) (url-insert-file-contents url)))) -;; Interface for the Emacs bug tracker. - -(autoload 'gnus-read-ephemeral-emacs-bug-group "gnus-group") -(autoload 'mail-header-subject "nnheader") -(autoload 'gnus-summary-article-header "gnus-sum") -(autoload 'message-make-from "message") - -(defface debbugs-new '((t (:foreground "red"))) - "Face for new reports that nobody has answered.") - -(defface debbugs-handled '((t (:foreground "ForestGreen"))) - "Face for new reports that nobody has answered.") - -(defface debbugs-stale '((t (:foreground "orange"))) - "Face for new reports that nobody has answered.") - -(defface debbugs-done '((t (:foreground "DarkGrey"))) - "Face for closed bug reports.") - -(defun debbugs-emacs (severities &optional package list-done archivedp) - "List all outstanding Emacs bugs." - (interactive - (list - (completing-read "Severity: " - '("important" "normal" "minor" "wishlist") - nil t "normal"))) - (unless (consp severities) - (setq severities (list severities))) - (pop-to-buffer (get-buffer-create "*Emacs Bugs*")) - (debbugs-mode) - (let ((debbugs-port "gnu.org") - (buffer-read-only nil) - (ids nil) - (default 400)) - (dolist (severity severities) - (setq ids (nconc ids - (debbugs-get-bugs :package (or package "emacs") - :severity severity - :archive (if archivedp - "1" "0"))))) - (erase-buffer) - - (when (> (length ids) default) - (let* ((cursor-in-echo-area nil) - (input - (read-string - (format - "How many reports (available %d, default %d): " - (length ids) default) - nil - nil - (number-to-string default)))) - (setq ids (last (sort ids '<) (string-to-number input))))) - - (dolist (status (sort (apply 'debbugs-get-status ids) - (lambda (s1 s2) - (< (cdr (assq 'id s1)) - (cdr (assq 'id s2)))))) - (when (or list-done - (not (equal (cdr (assq 'pending status)) "done"))) - (let ((address (mail-header-parse-address - (decode-coding-string (cdr (assq 'originator status)) - 'utf-8)))) - (setq address - ;; Prefer the name over the address. - (or (cdr address) - (car address))) - (insert - (format "%5d %-20s [%-23s] %s\n" - (cdr (assq 'id status)) - (let ((words - (mapconcat - 'identity - (cons (cdr (assq 'severity status)) - (cdr (assq 'keywords status))) - ","))) - (unless (equal (cdr (assq 'pending status)) "pending") - (setq words (concat words "," (cdr (assq 'pending status))))) - (if (> (length words) 20) - (substring words 0 20) - words)) - (if (> (length address) 23) - (substring address 0 23) - address) - (decode-coding-string (cdr (assq 'subject status)) - 'utf-8))) - (forward-line -1) - (put-text-property - (+ (point) 5) (+ (point) 26) - 'face - (cond - ((equal (cdr (assq 'pending status)) "done") - 'debbugs-done) - ((= (cdr (assq 'date status)) - (cdr (assq 'log_modified status))) - 'debbugs-new) - ((< (- (float-time) - (cdr (assq 'log_modified status))) - (* 60 60 24 4)) - 'debbugs-handled) - (t - 'debbugs-stale))) - (forward-line 1))))) - (goto-char (point-min))) - -(defvar debbugs-mode-map nil) -(unless debbugs-mode-map - (setq debbugs-mode-map (make-sparse-keymap)) - (define-key debbugs-mode-map "\r" 'debbugs-select-report)) - -(defun debbugs-mode () - "Major mode for listing bug reports. - -All normal editing commands are switched off. -\\ - -The following commands are available: - -\\{debbugs-mode-map}" - (interactive) - (kill-all-local-variables) - (setq major-mode 'debbugs-mode) - (setq mode-name "Debbugs") - (use-local-map debbugs-mode-map) - (buffer-disable-undo) - (setq truncate-lines t) - (setq buffer-read-only t)) - -(defun debbugs-select-report () - "Select the report on the current line." - (interactive) - (let (id) - (save-excursion - (beginning-of-line) - (if (not (looking-at " *\\([0-9]+\\)")) - (error "No bug report on the current line") - (setq id (string-to-number (match-string 1))))) - (gnus-read-ephemeral-emacs-bug-group - id (cons (current-buffer) - (current-window-configuration))) - (with-current-buffer (window-buffer (selected-window)) - (debbugs-summary-mode 1)))) - -(defvar debbugs-summary-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "C" 'debbugs-send-control-message) - map)) - -(define-minor-mode debbugs-summary-mode - "Minor mode for providing a debbugs interface in Gnus summary buffers. - -\\{debbugs-summary-mode-map}" - :lighter " Debbugs" :keymap debbugs-summary-mode-map - nil) - -(defun debbugs-send-control-message (message) - "Send a control message for the current bug report. -You can set the severity or add a tag, or close the report. If -you use the special \"done\" MESSAGE, the report will be marked as -fixed, and then closed." - (interactive - (list (completing-read - "Control message: " - '("important" "normal" "minor" "wishlist" - "done" - "unarchive" "reopen" "close" - "merge" "forcemerge" - "patch" "wontfix" "moreinfo" "unreproducible" "fixed" "notabug") - nil t))) - (let* ((subject (mail-header-subject (gnus-summary-article-header))) - (id - (if (string-match "bug#\\([0-9]+\\)" subject) - (string-to-number (match-string 1 subject)) - (error "No bug number present")))) - (with-temp-buffer - (insert "To: control@debbugs.gnu.org\n" - "From: " (message-make-from) "\n" - (format "Subject: control message for bug #%d\n" id) - "\n" - (cond - ((member message '("unarchive" "reopen" "close")) - (format "%s %d\n" message id)) - ((member message '("merge" "forcemerge")) - (format "%s %d %s\n" message id - (read-string "Merge with bug #: "))) - ((equal message "done") - (format "tags %d fixed\nclose %d\n" id id)) - ((member message '("important" "normal" "minor" "wishlist")) - (format "severity %d %s\n" id message)) - (t - (format "tags %d %s\n" id message)))) - (funcall send-mail-function)))) - (provide 'debbugs) ;;; TODO: @@ -573,10 +741,6 @@ fixed, and then closed." ;; * SOAP interface extensions (wishlist). ;; - Server-side sorting. ;; - Regexp and/or wildcards search. -;; - Fulltext search. ;; - Returning message attachments. -;; * Widget-oriented bug overview like webDDTs. -;; * Actions on bugs. -;; * Integration into gnus (nnir). ;;; debbugs.el ends here