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