code.delx.au - gnu-emacs-elpa/blob - packages/debbugs/debbugs-gnu.el

   1 ;;; debbugs-gnu.el --- interface for the GNU bug tracker
   2
   3 ;; Copyright (C) 2011 Free Software Foundation, Inc.
   4
   5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   6 ;; Keywords: comm, hypermedia, maint
   7 ;; Package: debbugs
   8 ;; Version: 0.3
   9
  10 ;; This file is part of GNU Emacs.
  11
  12 ;; GNU Emacs is free software: you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation, either version 3 of the License, or
  15 ;; (at your option) any later version.
  16
  17 ;; GNU Emacs is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  24
  25 ;;; Commentary:
  26
  27 ;; This package provides an interface to bug reports which are located
  28 ;; on the GNU bug tracker debbugs.gnu.org.  Its main purpose is to
  29 ;; show and manipulate bug reports from Emacs, but it could be used
  30 ;; also for other GNU projects which use the same bug tracker.
  31
  32 ;; If you have `debbugs-gnu.el' in your load-path, you could enable
  33 ;; the bug tracker command by the following lines in your ~/.emacs
  34 ;;
  35 ;;   (autoload 'debbugs-gnu "debbugs-gnu" "" 'interactive)
  36 ;;   (autoload 'debbugs-gnu-search "debbugs-gnu" "" 'interactive)
  37
  38 ;; The bug tracker is called interactively by
  39 ;;
  40 ;;   M-x debbugs-gnu
  41
  42 ;; It asks for the severities, for which bugs shall be shown. This can
  43 ;; be either just one severity, or a list of severities, separated by
  44 ;; comma.  Valid severities are "serious", "important", "normal",
  45 ;; "minor" or "wishlist".  Severities "critical" and "grave" are not
  46 ;; used, although configured on the GNU bug tracker.  If no severity
  47 ;; is given, all bugs are selected.
  48
  49 ;; There is also the pseudo severity "tagged", which selects locally
  50 ;; tagged bugs.
  51
  52 ;; If a prefix is given to the command, more search parameters are
  53 ;; asked for, like packages (also a comma separated list, "emacs" is
  54 ;; the default), whether archived bugs shall be shown, and whether
  55 ;; closed bugs shall be shown.
  56
  57 ;; Another command is
  58 ;;
  59 ;;   M-x debbugs-gnu-search
  60
  61 ;; It behaves like `debbugs-gnu', but asks at the beginning for a
  62 ;; search phrase to be used for full text search.  Additionally, it
  63 ;; asks for key-value pairs to filter bugs.  Keys are as described in
  64 ;; `debbugs-get-status', the corresponding value must be a regular
  65 ;; expression to match for.  The other parameters are as described in
  66 ;; `debbugs-gnu'.  Usually, there is just one value except for the
  67 ;; attribute "date", which needs two arguments specifying a period in
  68 ;; which the bug has been submitted or modified.
  69
  70 ;; The bug reports are downloaded from the bug tracker.  In order to
  71 ;; not generate too much load of the server, up to 500 bugs will be
  72 ;; downloaded at once.  If there are more hits, you will be asked to
  73 ;; change this limit, but please don't increase this number too much.
  74
  75 ;; These default values could be changed also by customer options
  76 ;; `debbugs-gnu-default-severities', `debbugs-gnu-default-packages',
  77 ;; `debbugs-gnu-default-hits-per-page' and `debbugs-gnu-default-suppress-bugs'.
  78
  79 ;; The command creates one or more pages of bug lists.  Every bug is
  80 ;; shown in one line, including the bug number, the status (combining
  81 ;; merged bug numbers, keywords and severities), the name of the
  82 ;; submitter, and the title of the bug.  On every bug line you could
  83 ;; apply the following actions by the following keystrokes:
  84
  85 ;;   RET: Show corresponding messages in Gnus
  86 ;;   "C": Send a control message
  87 ;;   "t": Mark the bug locally as tagged
  88 ;;   "d": Show bug attributes
  89
  90 ;; Furthermore, you could apply the global actions
  91
  92 ;;   "g": Rescan bugs
  93 ;;   "q": Quit the buffer
  94 ;;   "s": Toggle bug sorting for age or for state
  95 ;;   "x": Toggle suppressing of bugs
  96
  97 ;; When you visit the related bug messages in Gnus, you could also
  98 ;; send control messages by keystroke "C".
  99
 100 ;; In the header line of every bug list page, you can toggle sorting
 101 ;; per column by selecting a column with the mouse.  The sorting
 102 ;; happens as expected for the respective column; sorting in the Title
 103 ;; column is depending on whether you are the owner of a bug.
 104
 105 ;;; Code:
 106
 107 (require 'debbugs)
 108 (require 'widget)
 109 (require 'tabulated-list)
 110 (eval-when-compile (require 'cl))
 111
 112 (autoload 'widget-convert "wid-edit.el")
 113 (autoload 'gnus-read-ephemeral-emacs-bug-group "gnus-group")
 114 (autoload 'mail-header-subject "nnheader")
 115 (autoload 'gnus-summary-article-header "gnus-sum")
 116 (autoload 'message-make-from "message")
 117
 118 (defgroup debbugs-gnu ()
 119   "UI for the debbugs.gnu.org bug tracker."
 120   :group 'debbugs
 121   :version "24.1")
 122
 123 (defcustom debbugs-gnu-default-severities '("important" "normal")
 124   "*The list severities bugs are searched for.
 125 \"tagged\" is not a severity but marks locally tagged bugs."
 126   :group 'debbugs-gnu
 127   :type '(set (const "serious")
 128               (const "important")
 129               (const "normal")
 130               (const "minor")
 131               (const "wishlist")
 132               (const "tagged"))
 133   :version "24.1")
 134
 135 (defcustom debbugs-gnu-default-packages '("emacs")
 136   "*The list of packages to be searched for."
 137   :group 'debbugs-gnu
 138   :type '(set (const "automake")
 139               (const "coreutils")
 140               (const "emacs")
 141               (const "gnus")
 142               (const "libtool"))
 143   :version "24.1")
 144
 145 (defcustom debbugs-gnu-default-hits-per-page 500
 146   "*The number of bugs shown per page."
 147   :group 'debbugs-gnu
 148   :type 'integer
 149   :version "24.1")
 150
 151 (defcustom debbugs-gnu-default-suppress-bugs
 152   '((pending . "done"))
 153   "*A list of specs for bugs to be suppressed.
 154 An element of this list is a cons cell \(KEY . REGEXP\), with key
 155 being returned by `debbugs-get-status', and VAL a regular
 156 expression matching the corresponding value, a string.  Showing
 157 suppressed bugs is toggled by `debbugs-gnu-toggle-suppress'."
 158   :group 'debbugs-gnu
 159   :type '(alist :key-type symbol :value-type regexp)
 160   :version "24.1")
 161
 162 (defface debbugs-gnu-new '((t (:foreground "red")))
 163   "Face for new reports that nobody has answered.")
 164
 165 (defface debbugs-gnu-handled '((t (:foreground "ForestGreen")))
 166   "Face for reports that have been modified recently.")
 167
 168 (defface debbugs-gnu-pending '((t (:foreground "MidnightBlue")))
 169   "Face for reports that are pending.")
 170
 171 (defface debbugs-gnu-stale '((t (:foreground "orange")))
 172   "Face for reports that have not been touched for a week.")
 173
 174 (defface debbugs-gnu-done '((t (:foreground "DarkGrey")))
 175   "Face for closed bug reports.")
 176
 177 (defface debbugs-gnu-tagged '((t (:foreground "red")))
 178   "Face for reports that have been tagged locally.")
 179
 180 (defvar debbugs-gnu-widgets nil)
 181
 182 (defvar debbugs-gnu-widget-map
 183   (let ((map (make-sparse-keymap)))
 184     (define-key map "\r" 'widget-button-press)
 185     (define-key map [mouse-1] 'widget-button-press)
 186     (define-key map [mouse-2] 'widget-button-press)
 187     map))
 188
 189 (defvar debbugs-gnu-local-tags nil
 190   "List of bug numbers tagged locally, and kept persistent.")
 191
 192 (defvar debbugs-gnu-persistency-file
 193   (expand-file-name (locate-user-emacs-file "debbugs"))
 194   "File name of a persistency store for debbugs variables")
 195
 196 (defun debbugs-gnu-dump-persistency-file ()
 197   "Function to store debbugs variables persistently."
 198   (with-temp-file debbugs-gnu-persistency-file
 199     (insert
 200      ";; -*- emacs-lisp -*-\n"
 201      ";; Debbugs tags connection history.  Don't change this file.\n\n"
 202      (format "(setq debbugs-gnu-local-tags '%S)"
 203              (sort (copy-sequence debbugs-gnu-local-tags) '<)))))
 204
 205 (defvar debbugs-gnu-current-query nil
 206   "The query object of the current search.
 207 It will be applied server-side, when calling `debbugs-get-bugs'.
 208 It has the same format as `debbugs-gnu-default-suppress-bugs'.")
 209
 210 (defvar debbugs-gnu-current-filter nil
 211   "The filter object for the current search.
 212 It will be applied client-side, when parsing the results of
 213 `debbugs-get-status'.  It has a similar format as
 214 `debbugs-gnu-default-suppress-bugs'.  In case of keys representing
 215 a date, value is the cons cell \(BEFORE . AFTER\).")
 216
 217 (defun debbugs-gnu-calendar-read (prompt acceptable &optional initial-contents)
 218   "Return a string read from the minibuffer.
 219 Derived from `calendar-read'."
 220   (let ((value (read-string prompt initial-contents)))
 221     (while (not (funcall acceptable value))
 222       (setq value (read-string prompt initial-contents)))
 223     value))
 224
 225 (defconst debbugs-gnu-phrase-prompt
 226   (propertize
 227    "Enter search phrase: "
 228    'help-echo "\
 229 The search phrase contains words to be searched for, combined by
 230 operators like AND, ANDNOT and OR.  If there is no operator
 231 between the words, AND is used by default.  The phrase can also
 232 be empty, in this case only the following attributes are used for
 233 search."))
 234
 235 ;;;###autoload
 236 (defun debbugs-gnu-search ()
 237   "Search for Emacs bugs interactively.
 238 Search arguments are requested interactively.  The \"search
 239 phrase\" is used for full text search in the bugs database.
 240 Further key-value pairs are requested until an empty key is
 241 returned.  If a key cannot be queried by a SOAP request, it is
 242 marked as \"client-side filter\"."
 243   (interactive)
 244
 245   (unwind-protect
 246       (let ((date-format "\\([[:digit:]]\\{4\\}\\)-\\([[:digit:]]\\{1,2\\}\\)-\\([[:digit:]]\\{1,2\\}\\)")
 247             key val1 val2 phrase severities packages archivedp)
 248
 249         ;; Check for the phrase.
 250         (setq phrase (read-string debbugs-gnu-phrase-prompt))
 251         (if (zerop (length phrase))
 252             (setq phrase nil)
 253           (add-to-list 'debbugs-gnu-current-query (cons 'phrase phrase)))
 254
 255         ;; The other queries.
 256         (catch :finished
 257           (while t
 258             (setq key (completing-read
 259                        "Enter attribute: "
 260                        (if phrase
 261                            '("severity" "package" "tags" "submitter" "date"
 262                              "subject" "status")
 263                          '("severity" "package" "archive" "src" "tag"
 264                            "owner" "submitter" "maint" "correspondent"
 265                            "date" "log_modified" "last_modified"
 266                            "found_date" "fixed_date" "unarchived"
 267                            "subject" "done" "forwarded" "msgid" "summary"))
 268                        nil t))
 269             (cond
 270              ;; Server-side queries.
 271              ((equal key "severity")
 272               (setq
 273                severities
 274                (completing-read-multiple
 275                 "Enter severities: "
 276                 (mapcar
 277                  'cadr (cdr (get 'debbugs-gnu-default-severities 'custom-type)))
 278                 nil t
 279                 (mapconcat 'identity debbugs-gnu-default-severities ","))))
 280
 281              ((equal key "package")
 282               (setq
 283                packages
 284                (completing-read-multiple
 285                 "Enter packages: "
 286                 (mapcar
 287                  'cadr (cdr (get 'debbugs-gnu-default-packages 'custom-type)))
 288                 nil t (mapconcat 'identity debbugs-gnu-default-packages ","))))
 289
 290              ((equal key "archive")
 291               ;; We simplify, by assuming just archived bugs are requested.
 292               (setq archivedp t))
 293
 294              ((member key '("src" "tag" "tags"))
 295               (setq val1 (read-string (format "Enter %s: " key)))
 296               (when (not (zerop (length val1)))
 297                 (add-to-list
 298                  'debbugs-gnu-current-query (cons (intern key) val1))))
 299
 300              ((member key '("owner" "submitter" "maint" "correspondent"))
 301               (setq val1 (read-string "Enter email address: "))
 302               (when (not (zerop (length val1)))
 303                 (add-to-list
 304                  'debbugs-gnu-current-query (cons (intern key) val1))))
 305
 306              ((equal key "status")
 307               (setq
 308                val1
 309                (completing-read "Enter status: " '("done" "forwarded" "open")))
 310               (when (not (zerop (length val1)))
 311             (add-to-list
 312              'debbugs-gnu-current-query (cons (intern key) val1))))
 313
 314              ;; Client-side filters.
 315              ((member key '("date" "log_modified" "last_modified"
 316                             "found_date" "fixed_date" "unarchived"))
 317               (setq val1
 318                     (debbugs-gnu-calendar-read
 319                      (format "Enter %s before YYYY-MM-DD%s: "
 320                              key (if phrase "" " (client-side filter)"))
 321                      (lambda (x)
 322                        (string-match (concat "^\\(" date-format "\\|\\)$") x))))
 323               (if (string-match date-format val1)
 324                   (setq val1 (floor
 325                               (float-time
 326                                (encode-time
 327                                 0 0 0
 328                                 (string-to-number (match-string 3 val1))
 329                                 (string-to-number (match-string 2 val1))
 330                                 (string-to-number (match-string 1 val1))))))
 331                 (setq val1 nil))
 332               (setq val2
 333                     (debbugs-gnu-calendar-read
 334                      (format "Enter %s after YYYY-MM-DD%s: "
 335                              key (if phrase "" " (client-side filter)"))
 336                      (lambda (x)
 337                        (string-match (concat "^\\(" date-format "\\|\\)$") x))))
 338               (if (string-match date-format val2)
 339                   (setq val2 (floor
 340                               (float-time
 341                                (encode-time
 342                                 0 0 0
 343                                 (string-to-number (match-string 3 val2))
 344                                 (string-to-number (match-string 2 val2))
 345                                 (string-to-number (match-string 1 val2))))))
 346                 (setq val2 nil))
 347               (when (or val1 val2)
 348                 (add-to-list
 349                  (if phrase
 350                      'debbugs-gnu-current-query 'debbugs-gnu-current-filter)
 351                  (cons (intern key) (cons val1 val2)))))
 352
 353              ((not (zerop (length key)))
 354               (setq val1
 355                     (funcall
 356                      (if phrase 'read-string 'read-regexp)
 357                      (format "Enter %s%s"
 358                              key (if phrase ": " " (client-side filter)"))))
 359               (when (not (zerop (length val1)))
 360                 (add-to-list
 361                  (if phrase
 362                      'debbugs-gnu-current-query 'debbugs-gnu-current-filter)
 363                  (cons (intern key) val1))))
 364
 365              ;; The End.
 366              (t (throw :finished nil)))))
 367
 368         ;; Do the search.
 369         (debbugs-gnu severities packages archivedp))
 370
 371     ;; Reset query and filter.
 372     (setq debbugs-gnu-current-query nil
 373           debbugs-gnu-current-filter nil)))
 374
 375 ;;;###autoload
 376 (defun debbugs-gnu (severities &optional packages archivedp suppress)
 377   "List all outstanding Emacs bugs."
 378   (interactive
 379    (let (archivedp)
 380      (list
 381       (completing-read-multiple
 382        "Severities: "
 383        (mapcar 'cadr (cdr (get 'debbugs-gnu-default-severities 'custom-type)))
 384        nil t (mapconcat 'identity debbugs-gnu-default-severities ","))
 385       ;; The optional parameters are asked only when there is a prefix.
 386       (if current-prefix-arg
 387           (completing-read-multiple
 388            "Packages: "
 389            (mapcar 'cadr (cdr (get 'debbugs-gnu-default-packages 'custom-type)))
 390            nil t (mapconcat 'identity debbugs-gnu-default-packages ","))
 391         debbugs-gnu-default-packages)
 392       (when current-prefix-arg
 393         (setq archivedp (y-or-n-p "Show archived bugs?")))
 394       (when (and current-prefix-arg (not archivedp))
 395         (y-or-n-p "Suppress unwanted bugs?")))))
 396
 397   ;; Initialize variables.
 398   (when (and (file-exists-p debbugs-gnu-persistency-file)
 399              (not debbugs-gnu-local-tags))
 400     (with-temp-buffer
 401       (insert-file-contents debbugs-gnu-persistency-file)
 402       (eval (read (current-buffer)))))
 403   (setq debbugs-gnu-widgets nil)
 404
 405   ;; Add queries.
 406   (dolist (severity (if (consp severities) severities (list severities)))
 407     (when (not (zerop (length severity)))
 408       (add-to-list 'debbugs-gnu-current-query (cons 'severity severity))))
 409   (dolist (package (if (consp packages) packages (list packages)))
 410     (when (not (zerop (length package)))
 411       (add-to-list 'debbugs-gnu-current-query (cons 'package package))))
 412   (when archivedp
 413     (add-to-list 'debbugs-gnu-current-query '(archive . "1")))
 414
 415   (unwind-protect
 416       (let ((hits debbugs-gnu-default-hits-per-page)
 417             (ids (debbugs-gnu-get-bugs debbugs-gnu-current-query)))
 418
 419         (if (> (length ids) hits)
 420             (let ((cursor-in-echo-area nil))
 421               (setq hits
 422                     (string-to-number
 423                      (read-string
 424                       (format
 425                        "How many reports (available %d, default %d): "
 426                        (length ids) hits)
 427                       nil
 428                       nil
 429                       (number-to-string hits))))))
 430
 431         (if (> (length ids) hits)
 432             (let ((i 0)
 433                   curr-ids)
 434               (while ids
 435                 (setq i (1+ i)
 436                       curr-ids (butlast ids (- (length ids) hits)))
 437                 (add-to-list
 438                  'debbugs-gnu-widgets
 439                  (widget-convert
 440                   'push-button
 441                   :follow-link 'mouse-face
 442                   :notify (lambda (widget &rest ignore)
 443                             (debbugs-gnu-show-reports widget))
 444                   :keymap debbugs-gnu-widget-map
 445                   :suppress suppress
 446                   :buffer-name (format "*Emacs Bugs*<%d>" i)
 447                   :bug-ids curr-ids
 448                   :query debbugs-gnu-current-query
 449                   :filter debbugs-gnu-current-filter
 450                   :help-echo (format "%d-%d" (car ids) (car (last curr-ids)))
 451                   :format " %[%v%]"
 452                   (number-to-string i))
 453                  'append)
 454                 (setq ids (last ids (- (length ids) hits))))
 455               (debbugs-gnu-show-reports (car debbugs-gnu-widgets)))
 456
 457           (debbugs-gnu-show-reports
 458            (widget-convert
 459             'const
 460             :suppress suppress
 461             :buffer-name "*Emacs Bugs*"
 462             :bug-ids ids
 463             :query debbugs-gnu-current-query
 464             :filter debbugs-gnu-current-filter))))
 465
 466     ;; Reset query and filter.
 467     (setq debbugs-gnu-current-query nil
 468           debbugs-gnu-current-filter nil)))
 469
 470 (defun debbugs-gnu-get-bugs (query)
 471   "Retrieve bugs numbers from debbugs.gnu.org according search criteria."
 472   (let ((debbugs-port "gnu.org")
 473         (tagged (when (member '(severity . "tagged") query)
 474                   (copy-sequence debbugs-gnu-local-tags)))
 475         (phrase (assoc 'phrase query))
 476         args)
 477     ;; Compile query arguments.
 478     (unless query
 479       (dolist (elt debbugs-gnu-default-packages)
 480         (setq args (append args (list :package elt)))))
 481     (dolist (elt query)
 482       (unless (equal elt '(severity . "tagged"))
 483         (setq args
 484               (append
 485                args
 486                (if phrase
 487                    (cond
 488                     ((eq (car elt) 'phrase)
 489                      (list (list :phrase (cdr elt) :max 500)))
 490                     ((eq (car elt) 'date)
 491                      (list (list :date (cddr elt) (cadr elt)
 492                                  :operator "NUMBT")))
 493                     (t
 494                      (list (list (intern (concat ":" (symbol-name (car elt))))
 495                                  (cdr elt) :operator "ISTRINC"))))
 496                  (list (intern (concat ":" (symbol-name (car elt))))
 497                        (cdr elt)))))))
 498
 499     (cond
 500      ;; If the query contains only the pseudo-severity "tagged", we
 501      ;; return just the local tagged bugs.
 502      ((and tagged (not (memq :severity args)))
 503       (sort tagged '<))
 504      ;; A full text query.
 505      (phrase
 506       (append
 507        (mapcar
 508         (lambda (x) (cdr (assoc "id" x)))
 509         (apply 'debbugs-search-est args))
 510        tagged))
 511      ;; Otherwise, we retrieve the bugs from the server.
 512      (t (sort (append (apply 'debbugs-get-bugs args) tagged) '<)))))
 513
 514 (defvar debbugs-gnu-current-widget nil)
 515
 516 (defvar widget-mouse-face)
 517
 518 (defun debbugs-gnu-show-reports (widget)
 519   "Show bug reports as given in WIDGET property :bug-ids."
 520   (pop-to-buffer (get-buffer-create (widget-get widget :buffer-name)))
 521   (debbugs-gnu-mode)
 522   (let ((inhibit-read-only t)
 523         (debbugs-port "gnu.org"))
 524     (erase-buffer)
 525     (set (make-local-variable 'debbugs-gnu-current-widget)
 526          widget)
 527
 528     (dolist (status (apply 'debbugs-get-status (widget-get widget :bug-ids)))
 529       (let* ((id (cdr (assq 'id status)))
 530              (words
 531               (mapconcat
 532                'identity
 533                (cons (cdr (assq 'severity status))
 534                      (cdr (assq 'keywords status)))
 535                ","))
 536              (address (mail-header-parse-address
 537                        (decode-coding-string (cdr (assq 'originator status))
 538                                              'utf-8)))
 539              (owner (if (cdr (assq 'owner status))
 540                         (car (mail-header-parse-address
 541                               (decode-coding-string (cdr (assq 'owner status))
 542                                                     'utf-8)))))
 543              (subject (decode-coding-string (cdr (assq 'subject status))
 544                                             'utf-8))
 545              merged)
 546         (unless (equal (cdr (assq 'pending status)) "pending")
 547           (setq words
 548                 (concat words "," (cdr (assq 'pending status)))))
 549         (let ((packages (delete "emacs" (cdr (assq 'package status)))))
 550           (when packages
 551             (setq words (concat words "," (mapconcat 'identity packages ",")))))
 552         (when (setq merged (cdr (assq 'mergedwith status)))
 553           (setq words (format "%s,%s"
 554                               (if (numberp merged)
 555                                   merged
 556                                 (mapconcat 'number-to-string merged ","))
 557                               words)))
 558         (when (or (not merged)
 559                   (not (let ((found nil))
 560                          (dolist (id (if (listp merged)
 561                                          merged
 562                                        (list merged)))
 563                            (dolist (entry tabulated-list-entries)
 564                              (when (equal id (cdr (assq 'id (car entry))))
 565                                (setq found t))))
 566                          found)))
 567           (add-to-list
 568            'tabulated-list-entries
 569            (list
 570             status
 571             (vector
 572              (propertize
 573               (format "%5d" id)
 574               'face
 575               ;; Mark tagged bugs.
 576               (if (memq id debbugs-gnu-local-tags)
 577                   'debbugs-gnu-tagged
 578                 'default))
 579              (propertize
 580               ;; Mark status and age.
 581               words
 582               'face
 583               (cond
 584                ((equal (cdr (assq 'pending status)) "done")
 585                 'debbugs-gnu-done)
 586                ((member "pending" (cdr (assq 'keywords status)))
 587                 'debbugs-gnu-pending)
 588                ((= (cdr (assq 'date status))
 589                    (cdr (assq 'log_modified status)))
 590                 'debbugs-gnu-new)
 591                ((< (- (float-time)
 592                       (cdr (assq 'log_modified status)))
 593                    (* 60 60 24 7 2))
 594                 'debbugs-gnu-handled)
 595                (t
 596                 'debbugs-gnu-stale)))
 597              (propertize
 598               ;; Prefer the name over the address.
 599               (or (cdr address)
 600                   (car address))
 601               'face
 602               ;; Mark own submitted bugs.
 603               (if (and (stringp (car address))
 604                        (string-equal (car address) user-mail-address))
 605                   'debbugs-gnu-tagged
 606                 'default))
 607              (propertize
 608               subject
 609               'face
 610               ;; Mark owned bugs.
 611               (if (and (stringp owner)
 612                        (string-equal owner user-mail-address))
 613                   'debbugs-gnu-tagged
 614                 'default))))
 615            'append))))
 616     (tabulated-list-init-header)
 617     (tabulated-list-print)
 618
 619     (set-buffer-modified-p nil)
 620     (goto-char (point-min))))
 621
 622 (defun debbugs-gnu-print-entry (list-id cols)
 623   "Insert a debbugs entry at point.
 624 Used instead of `tabulated-list-print-entry'."
 625   ;; This shall be in `debbugs-gnu-show-reports'.  But
 626   ;; `tabulated-list-print' erases the buffer, therefore we do it
 627   ;; here.  (bug#9047)
 628   (when (and debbugs-gnu-widgets (= (point) (point-min)))
 629     (widget-insert "Page:")
 630     (mapc
 631      (lambda (obj)
 632        (if (eq obj debbugs-gnu-current-widget)
 633            (widget-put obj :button-face 'widget-button-pressed)
 634          (widget-put obj :button-face 'widget-button-face))
 635        (widget-apply obj :create))
 636      debbugs-gnu-widgets)
 637     (widget-insert "\n\n")
 638     (save-excursion
 639       (widget-insert "\nPage:")
 640       (mapc (lambda (obj) (widget-apply obj :create)) debbugs-gnu-widgets)
 641       (widget-setup)))
 642
 643   (let ((beg (point))
 644         (pos 0)
 645         (case-fold-search t)
 646         (id               (aref cols 0))
 647         (id-length        (nth 1 (aref tabulated-list-format 0)))
 648         (state            (aref cols 1))
 649         (state-length     (nth 1 (aref tabulated-list-format 1)))
 650         (submitter        (aref cols 2))
 651         (submitter-length (nth 1 (aref tabulated-list-format 2)))
 652         (title            (aref cols 3))
 653         (title-length     (nth 1 (aref tabulated-list-format 3))))
 654     (when (and
 655            ;; Filter suppressed bugs.
 656            (or (not (widget-get debbugs-gnu-current-widget :suppress))
 657                (not (catch :suppress
 658                       (dolist (check debbugs-gnu-default-suppress-bugs)
 659                         (when
 660                             (string-match
 661                              (cdr check)
 662                              (or (cdr (assq (car check) list-id)) ""))
 663                           (throw :suppress t))))))
 664            ;; Filter search list.
 665            (not (catch :suppress
 666                   (dolist (check
 667                            (widget-get debbugs-gnu-current-widget :filter))
 668                     (let ((val (cdr (assq (car check) list-id))))
 669                       (if (stringp (cdr check))
 670                           ;; Regular expression.
 671                           (when (not (string-match (cdr check) (or val "")))
 672                             (throw :suppress t))
 673                         ;; Time value.
 674                         (when (or (and (numberp (cadr check))
 675                                        (< (cadr check) val))
 676                                   (and (numberp (cddr check))
 677                                        (> (cddr check) val)))
 678                           (throw :suppress t))))))))
 679
 680       ;; Insert id.
 681       (indent-to (- id-length (length id)))
 682       (insert id)
 683       ;; Insert state.
 684       (indent-to (setq pos (+ pos id-length 1)) 1)
 685       (insert (if (> (length state) state-length)
 686                   (propertize (substring state 0 state-length)
 687                               'help-echo state)
 688                 state))
 689       ;; Insert submitter.
 690       (indent-to (setq pos (+ pos state-length 1)) 1)
 691       (insert "[" (if (> (length submitter) (- submitter-length 2))
 692                       (propertize (substring submitter 0 (- submitter-length 2))
 693                                   'help-echo submitter)
 694                     submitter))
 695       (indent-to (+ pos (1- submitter-length)))
 696       (insert "]")
 697       ;; Insert title.
 698       (indent-to (setq pos (+ pos submitter-length 1)) 1)
 699       (insert (propertize title 'help-echo title))
 700       ;; Add properties.
 701       (add-text-properties
 702        beg (point) `(tabulated-list-id ,list-id mouse-face ,widget-mouse-face))
 703       (insert ?\n))))
 704
 705 (defvar debbugs-gnu-mode-map
 706   (let ((map (make-sparse-keymap)))
 707     (set-keymap-parent map tabulated-list-mode-map)
 708     (define-key map "\r" 'debbugs-gnu-select-report)
 709     (define-key map [mouse-1] 'debbugs-gnu-select-report)
 710     (define-key map [mouse-2] 'debbugs-gnu-select-report)
 711     (define-key map "s" 'debbugs-gnu-toggle-sort)
 712     (define-key map "t" 'debbugs-gnu-toggle-tag)
 713     (define-key map "d" 'debbugs-gnu-display-status)
 714     (define-key map "g" 'debbugs-gnu-rescan)
 715     (define-key map "x" 'debbugs-gnu-toggle-suppress)
 716     (define-key map "C" 'debbugs-gnu-send-control-message)
 717     map))
 718
 719 (defun debbugs-gnu-rescan ()
 720   "Rescan the current set of bug reports."
 721   (interactive)
 722
 723   ;; The last page will be provided with new bug ids.
 724   ;; TODO: Do it also for the other pages.
 725   (when (and debbugs-gnu-widgets
 726              (eq debbugs-gnu-current-widget (car (last debbugs-gnu-widgets))))
 727     (let ((first-id (car (widget-get debbugs-gnu-current-widget :bug-ids)))
 728           (last-id  (car
 729                      (last (widget-get debbugs-gnu-current-widget :bug-ids))))
 730           (ids (debbugs-gnu-get-bugs
 731                 (widget-get debbugs-gnu-current-widget :query))))
 732
 733       (while (and (<= first-id last-id) (not (memq first-id ids)))
 734         (setq first-id (1+ first-id)))
 735
 736       (when (<= first-id last-id)
 737         (widget-put debbugs-gnu-current-widget :bug-ids (memq first-id ids)))))
 738
 739   ;; Refresh the buffer.  `save-excursion' does not work, so we
 740   ;; remember the position.
 741   (let ((pos (point)))
 742     (debbugs-gnu-show-reports debbugs-gnu-current-widget)
 743     (goto-char pos)))
 744
 745 (defvar debbugs-gnu-sort-state 'number)
 746
 747 (define-derived-mode debbugs-gnu-mode tabulated-list-mode "Debbugs"
 748   "Major mode for listing bug reports.
 749
 750 All normal editing commands are switched off.
 751 \\<debbugs-gnu-mode-map>
 752
 753 The following commands are available:
 754
 755 \\{debbugs-gnu-mode-map}"
 756   (set (make-local-variable 'debbugs-gnu-sort-state)
 757        'number)
 758   (setq tabulated-list-format [("Id"         5 debbugs-gnu-sort-id)
 759                                ("State"     20 debbugs-gnu-sort-state)
 760                                ("Submitter" 25 t)
 761                                ("Title"     10 debbugs-gnu-sort-title)])
 762   (setq tabulated-list-sort-key (cons "Id" nil))
 763   (setq tabulated-list-printer 'debbugs-gnu-print-entry)
 764   (buffer-disable-undo)
 765   (setq truncate-lines t)
 766   (setq buffer-read-only t))
 767
 768 (defun debbugs-gnu-sort-id (s1 s2)
 769   (< (cdr (assq 'id (car s1)))
 770      (cdr (assq 'id (car s2)))))
 771
 772 (defconst debbugs-gnu-state-preference
 773   '((debbugs-gnu-new . 1)
 774     (debbugs-gnu-stale . 2)
 775     (debbugs-gnu-handled . 3)
 776     (debbugs-gnu-done . 4)
 777     (debbugs-gnu-pending . 5)))
 778
 779 (defun debbugs-gnu-get-state-preference (face-string)
 780   (or (cdr (assq (get-text-property 0 'face face-string)
 781                  debbugs-gnu-state-preference))
 782       10))
 783
 784 (defconst debbugs-gnu-severity-preference
 785   '(("serious" . 1)
 786     ("important" . 2)
 787     ("normal" . 3)
 788     ("minor" . 4)
 789     ("wishlist" . 5)))
 790
 791 (defun debbugs-gnu-get-severity-preference (state)
 792   (or (cdr (assoc (cdr (assq 'severity state))
 793                   debbugs-gnu-severity-preference))
 794       10))
 795
 796 (defun debbugs-gnu-sort-state (s1 s2)
 797   (let ((id1 (cdr (assq 'id (car s1))))
 798         (age1 (debbugs-gnu-get-state-preference (aref (nth 1 s1) 1)))
 799         (id2 (cdr (assq 'id (car s2))))
 800         (age2 (debbugs-gnu-get-state-preference (aref (nth 1 s2) 1))))
 801     (cond
 802      ;; Tagged bugs go to the end.
 803      ((and (not (memq id1 debbugs-gnu-local-tags))
 804            (memq id2 debbugs-gnu-local-tags))
 805       t)
 806      ((and (memq id1 debbugs-gnu-local-tags)
 807            (not (memq id2 debbugs-gnu-local-tags)))
 808       nil)
 809      ;; Then, we check the age of the bugs.
 810      ((< age1 age2)
 811       t)
 812      ((> age1 age2)
 813       nil)
 814      ;; If they have the same age, we check for severity.
 815      ((< (debbugs-gnu-get-severity-preference (car s1))
 816          (debbugs-gnu-get-severity-preference (car s2)))
 817       t)
 818      (t nil))))
 819
 820 (defun debbugs-gnu-sort-title (s1 s2)
 821   (let ((owner (if (cdr (assq 'owner (car s1)))
 822                    (car (mail-header-parse-address
 823                          (decode-coding-string (cdr (assq 'owner (car s1)))
 824                                                'utf-8))))))
 825     (and (stringp owner)
 826          (string-equal owner user-mail-address))))
 827
 828 (defun debbugs-gnu-toggle-sort ()
 829   "Toggle sorting by age and by state."
 830   (interactive)
 831   (if (eq debbugs-gnu-sort-state 'number)
 832       (progn
 833         (setq debbugs-gnu-sort-state 'state)
 834         (setq tabulated-list-sort-key (cons "Id" nil)))
 835     (setq debbugs-gnu-sort-state 'number)
 836     (setq tabulated-list-sort-key (cons "State" nil)))
 837   (tabulated-list-init-header)
 838   (tabulated-list-print))
 839
 840 (defun debbugs-gnu-toggle-tag ()
 841   "Toggle tag of the report in the current line."
 842   (interactive)
 843   (save-excursion
 844     (beginning-of-line)
 845     (let ((inhibit-read-only t)
 846           (id (debbugs-gnu-current-id)))
 847       (if (memq id debbugs-gnu-local-tags)
 848           (progn
 849             (setq debbugs-gnu-local-tags (delq id debbugs-gnu-local-tags))
 850             (put-text-property (point) (+ (point) 5) 'face 'default))
 851         (add-to-list 'debbugs-gnu-local-tags id)
 852         (put-text-property
 853          (+ (point) (- 5 (length (number-to-string id)))) (+ (point) 5)
 854          'face 'debbugs-gnu-tagged))))
 855   (debbugs-gnu-dump-persistency-file))
 856
 857 (defun debbugs-gnu-toggle-suppress ()
 858   "Suppress bugs marked in `debbugs-gnu-suppress-bugs'."
 859   (interactive)
 860   (widget-put debbugs-gnu-current-widget :suppress
 861               (not (widget-get debbugs-gnu-current-widget :suppress)))
 862   (tabulated-list-init-header)
 863   (tabulated-list-print))
 864
 865 (defvar debbugs-gnu-bug-number nil)
 866 (defvar debbugs-gnu-subject nil)
 867
 868 (defun debbugs-gnu-current-id (&optional noerror)
 869   (or (cdr (assq 'id (debbugs-gnu-current-status)))
 870       (and (not noerror)
 871            (error "No bug on the current line"))))
 872
 873 (defun debbugs-gnu-current-status ()
 874   (get-text-property (line-beginning-position) 'tabulated-list-id))
 875
 876 (defun debbugs-gnu-display-status (status)
 877   "Display the status of the report on the current line."
 878   (interactive (list (debbugs-gnu-current-status)))
 879   (pop-to-buffer "*Bug Status*")
 880   (erase-buffer)
 881   (pp status (current-buffer))
 882   (goto-char (point-min)))
 883
 884 (defun debbugs-gnu-select-report ()
 885   "Select the report on the current line."
 886   (interactive)
 887   ;; We open the report messages.
 888   (let* ((status (debbugs-gnu-current-status))
 889          (id (cdr (assq 'id status)))
 890          (merged (cdr (assq 'mergedwith status))))
 891     (gnus-read-ephemeral-emacs-bug-group
 892      (cons id (if (listp merged)
 893                   merged
 894                 (list merged)))
 895      (cons (current-buffer)
 896            (current-window-configuration)))
 897     (with-current-buffer (window-buffer (selected-window))
 898       (set (make-local-variable 'debbugs-gnu-bug-number) id)
 899       (set (make-local-variable 'debbugs-gnu-subject)
 900            (format "Re: bug#%d: %s" id (cdr (assq 'subject status))))
 901       (debbugs-gnu-summary-mode 1))))
 902
 903 (defvar debbugs-gnu-summary-mode-map
 904   (let ((map (make-sparse-keymap)))
 905     (define-key map "C" 'debbugs-gnu-send-control-message)
 906     map))
 907
 908 (defvar gnus-posting-styles)
 909
 910 (define-minor-mode debbugs-gnu-summary-mode
 911   "Minor mode for providing a debbugs interface in Gnus summary buffers.
 912
 913 \\{debbugs-gnu-summary-mode-map}"
 914   :lighter " Debbugs" :keymap debbugs-gnu-summary-mode-map
 915   (set (make-local-variable 'gnus-posting-styles)
 916        `((".*"
 917           (eval
 918            (when (buffer-live-p gnus-article-copy)
 919              (with-current-buffer gnus-article-copy
 920                (set (make-local-variable 'message-prune-recipient-rules)
 921                     '((".*@debbugs.*" "emacs-pretest-bug")
 922                       (".*@debbugs.*" "bug-gnu-emacs")
 923                       ("[0-9]+@debbugs.*" "submit@debbugs.gnu.org")
 924                       ("[0-9]+@debbugs.*" "quiet@debbugs.gnu.org")))
 925                (set (make-local-variable 'message-alter-recipients-function)
 926                     (lambda (address)
 927                       (if (string-match "\\([0-9]+\\)@donarmstrong"
 928                                         (car address))
 929                           (let ((new (format "%s@debbugs.gnu.org"
 930                                              (match-string 1 (car address)))))
 931                             (cons new new))
 932                         address)))
 933                ;; `gnus-posting-styles' is eval'ed after
 934                ;; `message-simplify-subject'.  So we cannot use m-s-s.
 935                (setq subject ,debbugs-gnu-subject))))))))
 936
 937 (defun debbugs-gnu-guess-current-id ()
 938   "Guess the ID based on \"#23\"."
 939   (save-excursion
 940     (beginning-of-line)
 941     (and
 942      (or (re-search-forward "#\\([0-9]+\\)" (line-end-position) t)
 943          (progn
 944            (goto-char (point-min))
 945            (re-search-forward "#\\([0-9]+\\)" nil t)))
 946      (string-to-number (match-string 1)))))
 947
 948 (defun debbugs-gnu-send-control-message (message &optional reverse)
 949   "Send a control message for the current bug report.
 950 You can set the severity or add a tag, or close the report.  If
 951 you use the special \"done\" MESSAGE, the report will be marked as
 952 fixed, and then closed.
 953
 954 If given a prefix, and given a tag to set, the tag will be
 955 removed instead."
 956   (interactive
 957    (list (completing-read
 958           "Control message: "
 959           '("serious" "important" "normal" "minor" "wishlist"
 960             "done" "donenotabug" "donewontfix" "doneunreproducible"
 961             "unarchive" "reopen" "close"
 962             "merge" "forcemerge"
 963             "owner" "noowner"
 964             "invalid"
 965             "reassign"
 966             "patch" "wontfix" "moreinfo" "unreproducible" "fixed" "notabug"
 967             "pending" "help" "security" "confirmed")
 968           nil t)
 969          current-prefix-arg))
 970   (let* ((id (or debbugs-gnu-bug-number ; Set on group entry.
 971                  (debbugs-gnu-guess-current-id)
 972                  (debbugs-gnu-current-id)))
 973          (version
 974           (when (member message '("close" "done"))
 975             (read-string
 976              "Version: "
 977              (cond
 978               ;; Emacs development versions.
 979               ((string-match
 980                 "^\\([0-9]+\\)\\.\\([0-9]+\\)\\.\\([0-9]+\\)\\." emacs-version)
 981                (format "%s.%d"
 982                        (match-string 1 emacs-version)
 983                        (1+ (string-to-number (match-string 2 emacs-version)))))
 984               ;; Emacs release versions.
 985               ((string-match
 986                 "^\\([0-9]+\\)\\.\\([0-9]+\\)\\.\\([0-9]+\\)$" emacs-version)
 987                (format "%s.%s"
 988                        (match-string 1 emacs-version)
 989                        (match-string 2 emacs-version)))
 990               (t emacs-version))))))
 991     (with-temp-buffer
 992       (insert "To: control@debbugs.gnu.org\n"
 993               "From: " (message-make-from) "\n"
 994               (format "Subject: control message for bug #%d\n" id)
 995               "\n"
 996               (cond
 997                ((member message '("unarchive" "reopen" "noowner"))
 998                 (format "%s %d\n" message id))
 999                ((member message '("merge" "forcemerge"))
1000                 (format "%s %d %s\n" message id
1001                         (read-string "Merge with bug #: ")))
1002                ((equal message "owner")
1003                 (format "owner %d !\n" id))
1004                ((equal message "reassign")
1005                 (format "reassign %d %s\n" id (read-string "Package: ")))
1006                ((equal message "close")
1007                 (format "close %d %s\n" id version))
1008                ((equal message "done")
1009                 (format "tags %d fixed\nclose %d %s\n" id id version))
1010                ((member message '("donenotabug" "donewontfix"
1011                                   "doneunreproducible"))
1012                 (format "tags %d %s\nclose %d\n" id (substring message 4) id))
1013                ((member message '("serious" "important" "normal"
1014                                   "minor" "wishlist"))
1015                 (format "severity %d %s\n" id message))
1016                ((equal message "invalid")
1017                 (format "tags %d notabug\ntags %d wontfix\nclose %d\n"
1018                         id id id))
1019                (t
1020                 (format "tags %d%s %s\n"
1021                         id (if reverse " -" "")
1022                         message))))
1023       (funcall send-mail-function))))
1024
1025 (provide 'debbugs-gnu)
1026
1027 ;;; TODO:
1028
1029 ;; * Reorganize pages after client-side filtering.
1030
1031 ;;; debbugs-gnu.el ends here