X-Git-Url: https://code.delx.au/gnu-emacs-elpa/blobdiff_plain/567397fee86236c324eeeda22939b7992407b699..81b0ef76e85360e3f20e71195bf0db94183ecc04:/packages/debbugs/debbugs-gnu.el diff --git a/packages/debbugs/debbugs-gnu.el b/packages/debbugs/debbugs-gnu.el index 6d7180284..e2607a2b9 100644 --- a/packages/debbugs/debbugs-gnu.el +++ b/packages/debbugs/debbugs-gnu.el @@ -6,7 +6,8 @@ ;; Michael Albinus ;; Keywords: comm, hypermedia, maint ;; Package: debbugs -;; Version: 0.7 +;; Package-Requires: ((async)) +;; Version: 0.8 ;; This file is not part of GNU Emacs. @@ -89,7 +90,7 @@ ;; submitter, and the title of the bug. On every bug line you could ;; apply the following actions by the following keystrokes: -;; RET: Show corresponding messages in Gnus +;; RET: Show corresponding messages in Gnus/Rmail ;; "C": Send a control message ;; "t": Mark the bug locally as tagged ;; "b": Show bugs this bug is blocked by @@ -103,6 +104,7 @@ ;; "s": Toggle bug sorting for age or for state ;; "x": Toggle suppressing of bugs ;; "/": Display only bugs matching a string +;; "R": Display only bugs blocking the current release ;; "w": Display all the currently selected bug reports ;; When you visit the related bug messages in Gnus, you could also @@ -139,14 +141,15 @@ ;;; Code: (require 'debbugs) -(require 'widget) -(require 'wid-edit) (require 'tabulated-list) (require 'add-log) +(require 'subr-x) +(require 'async) (eval-when-compile (require 'cl)) (autoload 'article-decode-charset "gnus-art") (autoload 'diff-goto-source "diff-mode") +(autoload 'diff-hunk-file-names "diff-mode") (autoload 'gnus-article-mime-handles "gnus-art") (autoload 'gnus-read-ephemeral-emacs-bug-group "gnus-group") (autoload 'gnus-summary-article-header "gnus-sum") @@ -156,15 +159,31 @@ (autoload 'log-edit-insert-changelog "log-edit") (autoload 'mail-header-subject "nnheader") (autoload 'message-make-from "message") +(autoload 'rmail-get-new-mail "rmail") +(autoload 'rmail-show-message "rmail") +(autoload 'rmail-summary "rmailsum") (autoload 'vc-dir-hide-up-to-date "vc-dir") (autoload 'vc-dir-mark "vc-dir") + (defvar compilation-in-progress) +(defvar diff-file-header-re) +(defvar gnus-article-buffer) +(defvar gnus-posting-styles) +(defvar gnus-save-duplicate-list) +(defvar gnus-suppress-duplicates) +(defvar rmail-current-message) +(defvar rmail-mode-map) +(defvar rmail-summary-mode-map) +(defvar rmail-total-messages) (defgroup debbugs-gnu () "UI for the debbugs.gnu.org bug tracker." :group 'debbugs :version "24.1") +(defvar debbugs-gnu-blocking-report 19759 + "The ID of the current release report used to track blocking bug reports.") + (defcustom debbugs-gnu-default-severities '("serious" "important" "normal") "*The list severities bugs are searched for. \"tagged\" is not a severity but marks locally tagged bugs." @@ -211,17 +230,16 @@ (const "sed") (const "vc-dwim") (const "woodchuck")) - :version "24.4") + :version "25.1") (defconst debbugs-gnu-all-packages (mapcar 'cadr (cdr (get 'debbugs-gnu-default-packages 'custom-type))) "*List of all possible package names.") -(defcustom debbugs-gnu-default-hits-per-page 500 - "*The number of bugs shown per page." - :group 'debbugs-gnu - :type 'integer - :version "24.1") +;; Please do not increase this value, otherwise we would run into +;; performance problems on the server. +(defconst debbugs-gnu-default-hits-per-page 500 + "The number of bugs shown per page.") (defcustom debbugs-gnu-default-suppress-bugs '((pending . "done")) @@ -234,6 +252,18 @@ suppressed bugs is toggled by `debbugs-gnu-toggle-suppress'." :type '(alist :key-type symbol :value-type regexp) :version "24.1") +(defcustom debbugs-gnu-mail-backend 'gnus + "*The email backend to use for reading bug report email exchange. +If this is 'gnus, the default, use Gnus. +If this is 'rmail, use Rmail instead." + :group 'debbugs-gnu + :type '(choice (const :tag "Use Gnus" 'gnus) + (const :tag "Use Rmail" 'rmail)) + :version "25.1") + +(defface debbugs-gnu-archived '((t (:inverse-video t))) + "Face for archived bug reports.") + (defface debbugs-gnu-new '((t (:foreground "red"))) "Face for new reports that nobody has answered.") @@ -252,14 +282,6 @@ suppressed bugs is toggled by `debbugs-gnu-toggle-suppress'." (defface debbugs-gnu-tagged '((t (:foreground "red"))) "Face for reports that have been tagged locally.") -(defvar debbugs-gnu-widgets nil) - -(defvar debbugs-gnu-widget-map - (let ((map (make-sparse-keymap))) - (define-key map "\r" 'widget-button-press) - (define-key map [mouse-2] 'widget-button-press) - map)) - (defvar debbugs-gnu-local-tags nil "List of bug numbers tagged locally, and kept persistent.") @@ -441,6 +463,9 @@ marked as \"client-side filter\"." (setq debbugs-gnu-current-query nil debbugs-gnu-current-filter nil))) +(defvar debbugs-gnu-current-limit nil) +(defvar debbugs-gnu-current-suppress nil) + ;;;###autoload (defun debbugs-gnu (severities &optional packages archivedp suppress tags) "List all outstanding bugs." @@ -471,7 +496,6 @@ marked as \"client-side filter\"." (with-temp-buffer (insert-file-contents debbugs-gnu-persistency-file) (eval (read (current-buffer))))) - (setq debbugs-gnu-widgets nil) ;; Add queries. (dolist (severity (if (consp severities) severities (list severities))) @@ -484,65 +508,18 @@ marked as \"client-side filter\"." (add-to-list 'debbugs-gnu-current-query '(archive . "1"))) (when suppress (add-to-list 'debbugs-gnu-current-query '(status . "open")) - (add-to-list 'debbugs-gnu-current-query '(status . "forwarded"))) + (add-to-list 'debbugs-gnu-current-query '(status . "forwarded")) + (setq debbugs-gnu-current-suppress suppress)) (dolist (tag (if (consp tags) tags (list tags))) (when (not (zerop (length tag))) (add-to-list 'debbugs-gnu-current-query (cons 'tag tag)))) - (unwind-protect - (let ((hits debbugs-gnu-default-hits-per-page) - (ids (debbugs-gnu-get-bugs debbugs-gnu-current-query))) - - (if (> (length ids) hits) - (let ((cursor-in-echo-area nil)) - (setq hits - (string-to-number - (read-string - (format - "How many reports (available %d, default %d): " - (length ids) hits) - nil - nil - (number-to-string hits)))))) - - (if (> (length ids) hits) - (let ((i 0) - curr-ids) - (while ids - (setq i (1+ i) - curr-ids (butlast ids (- (length ids) hits))) - (add-to-list - 'debbugs-gnu-widgets - (widget-convert - 'push-button - :follow-link 'mouse-face - :notify (lambda (widget &rest ignore) - (debbugs-gnu-show-reports widget)) - :keymap debbugs-gnu-widget-map - :suppress suppress - :buffer-name (format "*Emacs Bugs*<%d>" i) - :bug-ids curr-ids - :query debbugs-gnu-current-query - :filter debbugs-gnu-current-filter - :help-echo (format "%d-%d" (car ids) (car (last curr-ids))) - :format " %[%v%]" - (number-to-string i)) - 'append) - (setq ids (last ids (- (length ids) hits)))) - (debbugs-gnu-show-reports (car debbugs-gnu-widgets))) - - (debbugs-gnu-show-reports - (widget-convert - 'const - :suppress suppress - :buffer-name "*Emacs Bugs*" - :bug-ids ids - :query debbugs-gnu-current-query - :filter debbugs-gnu-current-filter)))) + ;; Show result. + (debbugs-gnu-show-reports) - ;; Reset query and filter. - (setq debbugs-gnu-current-query nil - debbugs-gnu-current-filter nil))) + ;; Reset query and filter. + (setq debbugs-gnu-current-query nil + debbugs-gnu-current-filter nil)) (defun debbugs-gnu-get-bugs (query) "Retrieve bugs numbers from debbugs.gnu.org according search criteria." @@ -595,110 +572,127 @@ marked as \"client-side filter\"." ;; Sort function. '<))) -(defvar debbugs-gnu-current-widget nil) -(defvar debbugs-gnu-current-limit nil) - -(defun debbugs-gnu-show-reports (widget) - "Show bug reports as given in WIDGET property :bug-ids." - ;; The tabulated mode sets several local variables. We must get rid - ;; of them. - (when (get-buffer (widget-get widget :buffer-name)) - (kill-buffer (widget-get widget :buffer-name))) - (pop-to-buffer (get-buffer-create (widget-get widget :buffer-name))) - (debbugs-gnu-mode) +(defun debbugs-gnu-show-reports () + "Show bug reports." (let ((inhibit-read-only t) - (debbugs-port "gnu.org")) - (erase-buffer) - (set (make-local-variable 'debbugs-gnu-current-widget) widget) - - (dolist (status (apply 'debbugs-get-status (widget-get widget :bug-ids))) - (let* ((id (cdr (assq 'id status))) - (words - (mapconcat - 'identity - (cons (cdr (assq 'severity status)) - (cdr (assq 'keywords status))) - ",")) - (address (mail-header-parse-address - (decode-coding-string (cdr (assq 'originator status)) - 'utf-8))) - (owner (if (cdr (assq 'owner status)) - (car (mail-header-parse-address - (decode-coding-string (cdr (assq 'owner status)) - 'utf-8))))) - (subject (decode-coding-string (cdr (assq 'subject status)) - 'utf-8)) - merged) - (unless (equal (cdr (assq 'pending status)) "pending") - (setq words - (concat words "," (cdr (assq 'pending status))))) - (let ((packages (delete "emacs" (cdr (assq 'package status))))) - (when packages - (setq words (concat words "," (mapconcat 'identity packages ","))))) - (when (setq merged (cdr (assq 'mergedwith status))) - (setq words (format "%s,%s" - (if (numberp merged) - merged - (mapconcat 'number-to-string merged ",")) - words))) - (when (or (not merged) - (not (let ((found nil)) - (dolist (id (if (listp merged) - merged - (list merged))) - (dolist (entry tabulated-list-entries) - (when (equal id (cdr (assq 'id (car entry)))) - (setq found t)))) - found))) - (add-to-list - 'tabulated-list-entries - (list - status - (vector - (propertize - (format "%5d" id) - 'face - ;; Mark tagged bugs. - (if (memq id debbugs-gnu-local-tags) - 'debbugs-gnu-tagged - 'default)) - (propertize - ;; Mark status and age. - words - 'face - (cond - ((equal (cdr (assq 'pending status)) "done") - 'debbugs-gnu-done) - ((member "pending" (cdr (assq 'keywords status))) - 'debbugs-gnu-pending) - ((= (cdr (assq 'date status)) - (cdr (assq 'log_modified status))) - 'debbugs-gnu-new) - ((< (- (float-time) - (cdr (assq 'log_modified status))) - (* 60 60 24 7 2)) - 'debbugs-gnu-handled) - (t - 'debbugs-gnu-stale))) - (propertize - ;; Prefer the name over the address. - (or (cdr address) - (car address)) - 'face - ;; Mark own submitted bugs. - (if (and (stringp (car address)) - (string-equal (car address) user-mail-address)) - 'debbugs-gnu-tagged - 'default)) - (propertize - subject - 'face - ;; Mark owned bugs. - (if (and (stringp owner) - (string-equal owner user-mail-address)) - 'debbugs-gnu-tagged - 'default)))) - 'append)))) + (debbugs-port "gnu.org") + (buffer-name "*Emacs Bugs*") + all-proc) + ;; The tabulated mode sets several local variables. We must get + ;; rid of them. + (when (get-buffer buffer-name) + (kill-buffer buffer-name)) + (switch-to-buffer (get-buffer-create buffer-name)) + (debbugs-gnu-mode) + + ;; Retrieve all bugs in chunks of `debbugs-gnu-default-hits-per-page'. + (let ((bug-ids (debbugs-gnu-get-bugs debbugs-gnu-current-query)) + (hits debbugs-gnu-default-hits-per-page) + curr-ids) + (while bug-ids + (setq curr-ids (butlast bug-ids (- (length bug-ids) hits)) + bug-ids (last bug-ids (- (length bug-ids) hits)) + all-proc + (append all-proc + (list + (async-start + `(lambda () + (load ,(locate-library "debbugs")) + (apply 'debbugs-get-status ',curr-ids)))))))) + + ;; Print bug reports. + (dolist (proc all-proc) + (dolist (status (async-get proc)) + (let* ((id (cdr (assq 'id status))) + (words + (mapconcat + 'identity + (cons (cdr (assq 'severity status)) + (cdr (assq 'keywords status))) + ",")) + (address (mail-header-parse-address + (decode-coding-string (cdr (assq 'originator status)) + 'utf-8))) + (owner (if (cdr (assq 'owner status)) + (car (mail-header-parse-address + (decode-coding-string (cdr (assq 'owner status)) + 'utf-8))))) + (subject (decode-coding-string (cdr (assq 'subject status)) + 'utf-8)) + merged) + (unless (equal (cdr (assq 'pending status)) "pending") + (setq words (concat words "," (cdr (assq 'pending status))))) + (let ((packages (delete "emacs" (cdr (assq 'package status))))) + (when packages + (setq words + (concat words "," (mapconcat 'identity packages ","))))) + (when (setq merged (cdr (assq 'mergedwith status))) + (setq words (format "%s,%s" + (if (numberp merged) + merged + (mapconcat 'number-to-string merged ",")) + words))) + (when (or (not merged) + (not (let ((found nil)) + (dolist (id (if (listp merged) + merged + (list merged))) + (dolist (entry tabulated-list-entries) + (when (equal id (cdr (assq 'id (car entry)))) + (setq found t)))) + found))) + (add-to-list + 'tabulated-list-entries + (list + status + (vector + (propertize + (format "%5d" id) + 'face + ;; Mark tagged bugs. + (if (memq id debbugs-gnu-local-tags) + 'debbugs-gnu-tagged + 'default)) + (propertize + ;; Mark status and age. + words + 'face + (cond + ((cdr (assq 'archived status)) + 'debbugs-gnu-archived) + ((equal (cdr (assq 'pending status)) "done") + 'debbugs-gnu-done) + ((member "pending" (cdr (assq 'keywords status))) + 'debbugs-gnu-pending) + ((= (cdr (assq 'date status)) + (cdr (assq 'log_modified status))) + 'debbugs-gnu-new) + ((< (- (float-time) + (cdr (assq 'log_modified status))) + (* 60 60 24 7 2)) + 'debbugs-gnu-handled) + (t + 'debbugs-gnu-stale))) + (propertize + ;; Prefer the name over the address. + (or (cdr address) + (car address)) + 'face + ;; Mark own submitted bugs. + (if (and (stringp (car address)) + (string-equal (car address) user-mail-address)) + 'debbugs-gnu-tagged + 'default)) + (propertize + subject + 'face + ;; Mark owned bugs. + (if (and (stringp owner) + (string-equal owner user-mail-address)) + 'debbugs-gnu-tagged + 'default)))) + 'append))))) + (tabulated-list-init-header) (tabulated-list-print) @@ -708,24 +702,6 @@ marked as \"client-side filter\"." (defun debbugs-gnu-print-entry (list-id cols) "Insert a debbugs entry at point. Used instead of `tabulated-list-print-entry'." - ;; This shall be in `debbugs-gnu-show-reports'. But - ;; `tabulated-list-print' erases the buffer, therefore we do it - ;; here. (bug#9047) - (when (and debbugs-gnu-widgets (= (point) (point-min))) - (widget-insert "Page:") - (mapc - (lambda (obj) - (if (eq obj debbugs-gnu-current-widget) - (widget-put obj :button-face 'widget-button-pressed) - (widget-put obj :button-face 'widget-button-face)) - (widget-apply obj :create)) - debbugs-gnu-widgets) - (widget-insert "\n\n") - (save-excursion - (widget-insert "\nPage:") - (mapc (lambda (obj) (widget-apply obj :create)) debbugs-gnu-widgets) - (widget-setup))) - (let ((beg (point)) (pos 0) (case-fold-search t) @@ -742,7 +718,7 @@ Used instead of `tabulated-list-print-entry'." (or (not debbugs-gnu-current-limit) (memq (cdr (assq 'id list-id)) debbugs-gnu-current-limit)) ;; Filter suppressed bugs. - (or (not (widget-get debbugs-gnu-current-widget :suppress)) + (or (not debbugs-gnu-current-suppress) (and (not (memq (cdr (assq 'id list-id)) debbugs-gnu-local-tags)) (not (catch :suppress (dolist (check debbugs-gnu-default-suppress-bugs) @@ -753,8 +729,7 @@ Used instead of `tabulated-list-print-entry'." (throw :suppress t))))))) ;; Filter search list. (not (catch :suppress - (dolist (check - (widget-get debbugs-gnu-current-widget :filter)) + (dolist (check debbugs-gnu-current-filter) (let ((val (cdr (assq (car check) list-id)))) (if (stringp (cdr check)) ;; Regular expression. @@ -789,7 +764,8 @@ Used instead of `tabulated-list-print-entry'." (insert (propertize title 'help-echo title)) ;; Add properties. (add-text-properties - beg (point) `(tabulated-list-id ,list-id mouse-face ,widget-mouse-face)) + beg (point) + `(tabulated-list-id ,list-id mouse-face highlight)) (insert ?\n)))) (defvar debbugs-gnu-mode-map @@ -808,32 +784,16 @@ Used instead of `tabulated-list-print-entry'." (define-key map "b" 'debbugs-gnu-show-blocked-by-reports) (define-key map "B" 'debbugs-gnu-show-blocking-reports) (define-key map "C" 'debbugs-gnu-send-control-message) + (define-key map "R" 'debbugs-gnu-show-all-blocking-reports) map)) (defun debbugs-gnu-rescan () "Rescan the current set of bug reports." (interactive) - - ;; The last page will be provided with new bug ids. - ;; TODO: Do it also for the other pages. - (when (and debbugs-gnu-widgets - (eq debbugs-gnu-current-widget (car (last debbugs-gnu-widgets)))) - (let ((first-id (car (widget-get debbugs-gnu-current-widget :bug-ids))) - (last-id (car - (last (widget-get debbugs-gnu-current-widget :bug-ids)))) - (ids (debbugs-gnu-get-bugs - (widget-get debbugs-gnu-current-widget :query)))) - - (while (and (<= first-id last-id) (not (memq first-id ids))) - (setq first-id (1+ first-id))) - - (when (<= first-id last-id) - (widget-put debbugs-gnu-current-widget :bug-ids (memq first-id ids))))) - ;; Refresh the buffer. `save-excursion' does not work, so we ;; remember the position. (let ((pos (point))) - (debbugs-gnu-show-reports debbugs-gnu-current-widget) + (debbugs-gnu-show-reports) (goto-char pos))) (defvar debbugs-gnu-sort-state 'number) @@ -849,6 +809,7 @@ The following commands are available: \\{debbugs-gnu-mode-map}" (set (make-local-variable 'debbugs-gnu-sort-state) 'number) (set (make-local-variable 'debbugs-gnu-current-limit) nil) + (set (make-local-variable 'debbugs-gnu-current-suppress) nil) (setq tabulated-list-format [("Id" 5 debbugs-gnu-sort-id) ("State" 20 debbugs-gnu-sort-state) ("Submitter" 25 t) @@ -960,6 +921,26 @@ The following commands are available: (message "Bug %d is not blocking any other bug" id) (apply 'debbugs-gnu-bugs (cdr (assq 'blocks status)))))) +(defun debbugs-gnu-show-all-blocking-reports () + "Narrow the display to just the reports that are blocking a release." + (interactive) + (let ((blockers (cdr (assq 'blockedby + (car (debbugs-get-status + debbugs-gnu-blocking-report))))) + (id (debbugs-gnu-current-id t)) + (inhibit-read-only t) + status) + (setq debbugs-gnu-current-limit nil) + (goto-char (point-min)) + (while (not (eobp)) + (setq status (debbugs-gnu-current-status)) + (if (not (memq (cdr (assq 'id status)) blockers)) + (delete-region (point) (progn (forward-line 1) (point))) + (push (cdr (assq 'id status)) debbugs-gnu-current-limit) + (forward-line 1))) + (when id + (debbugs-gnu-goto id)))) + (defun debbugs-gnu-narrow-to-status (string &optional status-only) "Only display the bugs matching STRING. If STATUS-ONLY (the prefix), ignore matches in the From and @@ -975,9 +956,10 @@ Subject fields." (while (not (eobp)) (setq status (debbugs-gnu-current-status)) (if (and (not (member string (assq 'keywords status))) - (not (member string (assq 'severity status))) + (not (equal string (cdr (assq 'severity status)))) (or status-only - (not (string-match string (cdr (assq 'originator status))))) + (not (string-match + string (cdr (assq 'originator status))))) (or status-only (not (string-match string (cdr (assq 'subject status)))))) (delete-region (point) (progn (forward-line 1) (point))) @@ -1028,8 +1010,7 @@ interest to you." (defun debbugs-gnu-toggle-suppress () "Suppress bugs marked in `debbugs-gnu-suppress-bugs'." (interactive) - (widget-put debbugs-gnu-current-widget :suppress - (not (widget-get debbugs-gnu-current-widget :suppress))) + (setq debbugs-gnu-current-suppress (not debbugs-gnu-current-suppress)) (tabulated-list-init-header) (tabulated-list-print)) @@ -1045,13 +1026,13 @@ interest to you." (get-text-property (line-beginning-position) 'tabulated-list-id)) (defun debbugs-gnu-current-query () - (widget-get debbugs-gnu-current-widget :query)) + debbugs-gnu-current-query) (defun debbugs-gnu-display-status (query status) "Display the query and status of the report on the current line." (interactive (list (debbugs-gnu-current-query) (debbugs-gnu-current-status))) - (pop-to-buffer "*Bug Status*") + (switch-to-buffer "*Bug Status*") (let ((inhibit-read-only t)) (erase-buffer) (when query (pp query (current-buffer))) @@ -1060,6 +1041,55 @@ interest to you." (set-buffer-modified-p nil) (special-mode)) +(defun debbugs-read-emacs-bug-with-rmail (id status merged) + "Read email exchange for debbugs bug ID. +STATUS is the bug's status list. +MERGED is the list of bugs merged with this one." + (let* ((mbox-dir (make-temp-file "debbugs" t)) + (mbox-fname (format "%s/bug_%d.mbox" mbox-dir id))) + (debbugs-get-mbox id 'mboxmaint mbox-fname) + (rmail mbox-fname) + ;; Download messages of all the merged bug reports and append them + ;; to the mailbox of the requested bug. + (when merged + (dolist (bugno merged) + (let ((fn (make-temp-file "url"))) + (debbugs-get-mbox bugno 'mboxmaint fn) + (rmail-get-new-mail fn) + (delete-file fn) + ;; Remove the 'unseen' attribute from all the messages we've + ;; just read, so that all of them appear in the summary with + ;; the same face. + (while (< rmail-current-message rmail-total-messages) + (rmail-show-message (1+ rmail-current-message)))))) + (set (make-local-variable 'debbugs-gnu-bug-number) id) + (set (make-local-variable 'debbugs-gnu-subject) + (format "Re: bug#%d: %s" id (cdr (assq 'subject status)))) + (rmail-summary) + (define-key rmail-summary-mode-map "C" 'debbugs-gnu-send-control-message) + (set-window-text-height nil 10) + (other-window 1) + (define-key rmail-mode-map "C" 'debbugs-gnu-send-control-message) + (rmail-show-message 1))) + +(defun debbugs-read-emacs-bug-with-gnus (id status merged) + "Read email exchange for debbugs bug ID. +STATUS is the bug's status list. +MERGED is the list of bugs merged with this one." + (require 'gnus-dup) + (setq gnus-suppress-duplicates t + gnus-save-duplicate-list t) + ;; Use Gnus. + (gnus-read-ephemeral-emacs-bug-group + (cons id (if (listp merged) merged (list merged))) + (cons (current-buffer) + (current-window-configuration))) + (with-current-buffer (window-buffer (selected-window)) + (set (make-local-variable 'debbugs-gnu-bug-number) id) + (set (make-local-variable 'debbugs-gnu-subject) + (format "Re: bug#%d: %s" id (cdr (assq 'subject status)))) + (debbugs-gnu-summary-mode 1))) + (defun debbugs-gnu-select-report () "Select the report on the current line." (interactive) @@ -1067,17 +1097,15 @@ interest to you." (let* ((status (debbugs-gnu-current-status)) (id (cdr (assq 'id status))) (merged (cdr (assq 'mergedwith status)))) - (gnus-read-ephemeral-emacs-bug-group - (cons id (if (listp merged) - merged - (list merged))) - (cons (current-buffer) - (current-window-configuration))) - (with-current-buffer (window-buffer (selected-window)) - (set (make-local-variable 'debbugs-gnu-bug-number) id) - (set (make-local-variable 'debbugs-gnu-subject) - (format "Re: bug#%d: %s" id (cdr (assq 'subject status)))) - (debbugs-gnu-summary-mode 1)))) + (setq merged (if (listp merged) merged (list merged))) + (cond + ((not id) + (message "No bug report on the current line")) + ((eq debbugs-gnu-mail-backend 'rmail) + (debbugs-read-emacs-bug-with-rmail id status merged)) + ((eq debbugs-gnu-mail-backend 'gnus) + (debbugs-read-emacs-bug-with-gnus id status merged)) + (t (error "No valid mail backend specified"))))) (defvar debbugs-gnu-summary-mode-map (let ((map (make-sparse-keymap))) @@ -1085,8 +1113,6 @@ interest to you." (define-key map [(meta m)] 'debbugs-gnu-apply-patch) map)) -(defvar gnus-posting-styles) - (define-minor-mode debbugs-gnu-summary-mode "Minor mode for providing a debbugs interface in Gnus summary buffers. @@ -1274,13 +1300,12 @@ The following commands are available: ;; Create buffer. (when (get-buffer buffer-name) (kill-buffer buffer-name)) - (pop-to-buffer (get-buffer-create buffer-name)) + (switch-to-buffer (get-buffer-create buffer-name)) (debbugs-gnu-usertags-mode) (setq tabulated-list-format `[("User" ,user-tab-length t) ("Tag" 10 t)]) (setq tabulated-list-sort-key (cons "User" nil)) ;(setq tabulated-list-printer 'debbugs-gnu-print-entry) - (erase-buffer) ;; Retrieve user tags. (dolist (user users) @@ -1289,8 +1314,8 @@ The following commands are available: 'tabulated-list-entries ;; `tabulated-list-id' is the parameter list for `debbugs-gnu'. `((("tagged") (,user) nil nil (,tag)) - ,(vector (propertize user 'mouse-face widget-mouse-face) - (propertize tag 'mouse-face widget-mouse-face))) + ,(vector (propertize user 'mouse-face 'highlight) + (propertize tag 'mouse-face 'highlight))) 'append))) ;; Add local tags. @@ -1298,8 +1323,8 @@ The following commands are available: (add-to-list 'tabulated-list-entries `((("tagged")) - ,(vector "" (propertize "(local tags)" - 'mouse-face widget-mouse-face))))) + ,(vector + "" (propertize "(local tags)" 'mouse-face 'highlight))))) ;; Show them. (tabulated-list-init-header) @@ -1329,7 +1354,7 @@ The following commands are available: (defvar debbugs-gnu-trunk-directory "~/src/emacs/trunk/" "The directory where the main source tree lives.") -(defvar debbugs-gnu-branch-directory "~/src/emacs/emacs-24/" +(defvar debbugs-gnu-branch-directory "~/src/emacs/emacs-25/" "The directory where the previous source tree lives.") (defun debbugs-gnu-apply-patch (&optional branch) @@ -1355,13 +1380,21 @@ If given a prefix, patch in the branch directory instead." (gnus-with-article-buffer (dolist (handle (mapcar 'cdr (gnus-article-mime-handles))) (when (string-match "diff\\|patch" (mm-handle-media-type handle)) - (push (mm-handle-buffer handle) patch-buffers)))) + (push (cons (mm-handle-encoding handle) + (mm-handle-buffer handle)) + patch-buffers)))) (unless patch-buffers (gnus-summary-show-article 'raw) (article-decode-charset) - (push (current-buffer) patch-buffers)) - (dolist (buffer patch-buffers) - (with-current-buffer buffer + (push (cons nil gnus-article-buffer) patch-buffers)) + (dolist (elem patch-buffers) + (with-temp-buffer + (insert-buffer-substring (cdr elem)) + (cond ((eq (car elem) 'base64) + (base64-decode-region (point-min) (point-max))) + ((eq (car elem) 'qp) + (quoted-printable-decode-region (point-min) (point-max)))) + (debbugs-gnu-fix-patch dir) (call-process-region (point-min) (point-max) "patch" nil output-buffer nil "-r" rej "--no-backup-if-mismatch" @@ -1397,6 +1430,36 @@ If given a prefix, patch in the branch directory instead." (switch-to-buffer "*vc-diff*") (goto-char (point-min)))) +(defun debbugs-gnu-fix-patch (dir) + (setq dir (directory-file-name (expand-file-name dir))) + (goto-char (point-min)) + (while (re-search-forward diff-file-header-re nil t) + (goto-char (match-beginning 0)) + (let ((target-name (car (diff-hunk-file-names)))) + (when (and target-name + (or (not (string-match "/" target-name)) + (and (string-match "^[ab]/" target-name) + (not (file-exists-p + (expand-file-name (substring target-name 2) + dir)))) + (file-exists-p (expand-file-name target-name dir)))) + ;; We have a simple patch that refers to a file somewhere in the + ;; tree. Find it. + (when-let ((files (directory-files-recursively + dir + (concat "^" (regexp-quote + (file-name-nondirectory target-name)) + "$")))) + (when (re-search-forward (concat "^[+]+ " + (regexp-quote target-name) + "\\([ \t\n]\\)") + nil t) + (replace-match (concat "+++ a" + (substring (car files) (length dir)) + (match-string 1)) + nil t))))) + (forward-line 2))) + (defun debbugs-gnu-find-contributor (string) "Search through ChangeLogs to find contributors." (interactive "sContributor match: ") @@ -1439,7 +1502,7 @@ If given a prefix, patch in the branch directory instead." ;; Fall back on the email address. (t (cadr from)))))) - (goto-char (point-min)) + (goto-char (point-max)) (end-of-line) (insert " (tiny change")) (goto-char point))))) @@ -1486,7 +1549,11 @@ If given a prefix, patch in the branch directory instead." (save-some-buffers t) (when (get-buffer "*vc-dir*") (kill-buffer (get-buffer "*vc-dir*"))) - (vc-dir debbugs-gnu-trunk-directory) + (let ((trunk (expand-file-name debbugs-gnu-trunk-directory))) + (if (equal (cl-subseq default-directory 0 (length trunk)) + trunk) + (vc-dir debbugs-gnu-trunk-directory) + (vc-dir debbugs-gnu-branch-directory))) (goto-char (point-min)) (while (not (search-forward "edited" nil t)) (sit-for 0.01)) @@ -1507,6 +1574,4 @@ If given a prefix, patch in the branch directory instead." ;;; TODO: -;; * Reorganize pages after client-side filtering. - ;;; debbugs-gnu.el ends here