(require 'soap-client)
(eval-when-compile (require 'cl))
+(defgroup debbugs nil
+ "Debbugs library"
+ :group 'hypermedia)
+
+(defcustom debbugs-servers
+ '(("gnu.org"
+ :wsdl "http://debbugs.gnu.org/cgi/soap.cgi?WSDL"
+ :bugreport-url "http://debbugs.gnu.org/cgi/bugreport.cgi")
+ ("debian.org"
+ :wsdl "http://bugs.debian.org/cgi-bin/soap.cgi?WSDL"
+ :bugreport-url "http://bugs.debian.org/cgi-bin/bugreport.cgi"))
+ "*List of Debbugs server specifiers.
+Each entry is a list that contains a string identifying the port
+name and the server parameters in keyword-value form. Allowed
+keywords are:
+
+`:wsdl' -- Location of WSDL. The value is a string with URL that
+should return the WSDL specification of Debbugs/SOAP service.
+
+`:bugreport-url' -- URL of the server script that returns mboxes
+with bug logs.
+
+The list initially contains two predefined and configured Debbugs
+servers: \"gnu.org\" and \"debian.org\"."
+ :group 'debbugs
+ :link '(custom-manual "(debbugs)Debbugs server specifiers")
+ :type '(choice
+ (const nil)
+ (repeat
+ (cons :tag "Server"
+ (string :tag "Port name")
+ (checklist :tag "Options" :greedy t
+ (group :inline t
+ (const :format "" :value :wsdl)
+ (string :tag "WSDL"))
+ (group :inline t
+ (const :format "" :value :bugreport-url)
+ (string :tag "Bugreport URL")))))))
+
(defcustom debbugs-port "gnu.org"
"The port instance to be applied from `debbugs-wsdl'.
This corresponds to the Debbugs server to be accessed, either
-\"gnu.org\", or \"debian.org\"."
+\"gnu.org\", or \"debian.org\", or user defined port name."
;; Maybe we should create an own group?
- :group 'emacsbug
- :type '(choice :tag "Debbugs server" (const "gnu.org") (const "debian.org")))
+ :group 'debbugs
+ :type '(choice :tag "Debbugs server" (const "gnu.org") (const "debian.org")
+ (string :tag "user defined port name")))
;; It would be nice if we could retrieve it from the debbugs server.
;; Not supported yet.
val (pop query)
vec (vconcat vec (list (substring (symbol-name key) 1))))
(unless (and (keywordp key) (stringp val))
- (error "Wrong query: %s %s" key val))
+ (error "Wrong query: %s %s" key val))
(case key
((:package :severity :tag)
;; Value shall be one word.
(debbugs-get-attribute (car messages) 'body))
(debbugs-get-attribute (car messages) 'attachments))))
+(defun debbugs-get-mbox (bug-number mbox-type &optional filename)
+ "Download mbox with messages of bug BUG-NUMBER from Debbugs server.
+BUG-NUMBER is a number of bug. It must be of integer type.
+
+MBOX-TYPE specifies a type of mbox and can be one of the
+following symbols:
+
+ `mboxfolder': Download mbox folder.
+
+ `mboxmaint': Download maintainer's mbox.
+
+ `mboxstat', `mboxstatus': Download status mbox. The use of
+ either symbol depends on actual Debbugs server
+ configuration. For gnu.org, use the former; for debian.org -
+ the latter.
+
+FILENAME, if non-nil, is the name of file to store mbox. If
+FILENAME is nil, the downloaded mbox is inserted into the current
+buffer."
+ (let (url (mt "") bn)
+ (unless (setq url (plist-get
+ (cdr (assoc debbugs-port debbugs-servers))
+ :bugreport-url))
+ (error "URL of bugreport script for port %s is not specified"
+ debbugs-port))
+ (setq bn (format "bug=%s;" (number-to-string bug-number)))
+ (unless (eq mbox-type 'mboxfolder)
+ (if (memq mbox-type '(mboxmaint mboxstat mboxstatus))
+ (setq mt (concat (symbol-name mbox-type) "=yes;"))
+ (error "Unknown mbox type: %s" mbox-type)))
+ (setq url (concat url (format "?%s%smbox=yes" bn mt)))
+ (if filename
+ (url-copy-file url filename t)
+ (url-insert-file-contents url))))
+
+;; Interface for the Emacs bug tracker.
+
+(autoload 'gnus-read-ephemeral-emacs-bug-group "gnus-group")
+(autoload 'mail-header-subject "nnheader")
+(autoload 'gnus-summary-article-header "gnus-sum")
+(autoload 'message-make-from "message")
+
+(defface debbugs-new '((t (:foreground "red")))
+ "Face for new reports that nobody has answered.")
+
+(defface debbugs-handled '((t (:foreground "ForestGreen")))
+ "Face for new reports that nobody has answered.")
+
+(defface debbugs-stale '((t (:foreground "orange")))
+ "Face for new reports that nobody has answered.")
+
+(defun debbugs-emacs (severities &optional package list-done)
+ "List all outstanding Emacs bugs."
+ (interactive
+ (list
+ (completing-read "Severity: "
+ '("important" "normal" "minor" "wishlist")
+ nil t "normal")))
+ (unless (consp severities)
+ (setq severities (list severities)))
+ (pop-to-buffer (get-buffer-create "*Emacs Bugs*"))
+ (debbugs-mode)
+ (let ((buffer-read-only nil)
+ (ids nil))
+ (dolist (severity severities)
+ (setq ids (nconc ids
+ (debbugs-get-bugs :package (or package "emacs")
+ :severity severity))))
+ (erase-buffer)
+ (dolist (status (sort (apply 'debbugs-get-status ids)
+ (lambda (s1 s2)
+ (< (cdr (assq 'id s1))
+ (cdr (assq 'id s2))))))
+ (when (or list-done
+ (not (equal (cdr (assq 'pending status)) "done")))
+ (let ((address (mail-header-parse-address
+ (decode-coding-string (cdr (assq 'originator status))
+ 'utf-8))))
+ (setq address
+ ;; Prefer the name over the address.
+ (or (cdr address)
+ (car address)))
+ (insert
+ (format "%5d %-20s [%-23s] %s\n"
+ (cdr (assq 'id status))
+ (let ((words
+ (mapconcat
+ 'identity
+ (cons (cdr (assq 'severity status))
+ (cdr (assq 'keywords status)))
+ ",")))
+ (unless (equal (cdr (assq 'pending status)) "pending")
+ (setq words (concat words "," (cdr (assq 'pending status)))))
+ (if (> (length words) 20)
+ (substring words 0 20)
+ words))
+ (if (> (length address) 23)
+ (substring address 0 23)
+ address)
+ (decode-coding-string (cdr (assq 'subject status))
+ 'utf-8)))
+ (forward-line -1)
+ (put-text-property
+ (+ (point) 5) (+ (point) 26)
+ 'face
+ (cond
+ ((= (cdr (assq 'date status))
+ (cdr (assq 'log_modified status)))
+ 'debbugs-new)
+ ((< (- (float-time)
+ (cdr (assq 'log_modified status)))
+ (* 60 60 24 4))
+ 'debbugs-handled)
+ (t
+ 'debbugs-stale)))
+ (forward-line 1)))))
+ (goto-char (point-min)))
+
+(defvar debbugs-mode-map nil)
+(unless debbugs-mode-map
+ (setq debbugs-mode-map (make-sparse-keymap))
+ (define-key debbugs-mode-map "\r" 'debbugs-select-report))
+
+(defun debbugs-mode ()
+ "Major mode for listing bug reports.
+
+All normal editing commands are switched off.
+\\<debbugs-mode-map>
+
+The following commands are available:
+
+\\{debbugs-mode-map}"
+ (interactive)
+ (kill-all-local-variables)
+ (setq major-mode 'debbugs-mode)
+ (setq mode-name "Debbugs")
+ (use-local-map debbugs-mode-map)
+ (buffer-disable-undo)
+ (setq truncate-lines t)
+ (setq buffer-read-only t))
+
+(defun debbugs-select-report ()
+ "Select the report on the current line."
+ (interactive)
+ (let (id)
+ (save-excursion
+ (beginning-of-line)
+ (if (not (looking-at " *\\([0-9]+\\)"))
+ (error "No bug report on the current line")
+ (setq id (string-to-number (match-string 1)))))
+ (gnus-read-ephemeral-emacs-bug-group
+ id (cons (current-buffer)
+ (current-window-configuration)))
+ (debbugs-summary-mode 1)))
+
+(defvar debbugs-summary-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map "C" 'debbugs-send-control-message)
+ map))
+
+(define-minor-mode debbugs-summary-mode
+ "Minor mode for providing a debbugs interface in Gnus summary buffers.
+
+\\{debbugs-summary-mode-map}"
+ :lighter " Debbugs" :keymap debbugs-summary-mode-map
+ nil)
+
+(defun debbugs-send-control-message (message)
+ "Send a control message for the current bug report."
+ (interactive
+ (list (completing-read "Control message: "
+ '("important" "normal" "minor" "wishlist"
+ "wontfix" "close"))))
+ (let* ((subject (mail-header-subject (gnus-summary-article-header)))
+ (id
+ (if (string-match "bug#\\([0-9]+\\)" subject)
+ (string-to-number (match-string 1 subject))
+ (error "No bug number present"))))
+ (with-temp-buffer
+ (insert "To: control@debbugs.gnu.org\n"
+ "From: " (message-make-from) "\n"
+ (format "Subject: control message for bug #%d\n" id)
+ "\n"
+ (cond
+ ((equal message "close")
+ (format "close %d\n" id))
+ (t
+ (format "tags %d %s\n" id message)))
+ "thanks\n")
+ (funcall send-mail-function))))
(provide 'debbugs)