X-Git-Url: https://code.delx.au/gnu-emacs-elpa/blobdiff_plain/48dbf5000a8eaf6c0b521d69f5bef4b30080ecdc..84c0e7b34684cbf4162f80f167a1178657779d87:/packages/debbugs/debbugs-gnu.el diff --git a/packages/debbugs/debbugs-gnu.el b/packages/debbugs/debbugs-gnu.el index cc9599183..3fe88ca0a 100644 --- a/packages/debbugs/debbugs-gnu.el +++ b/packages/debbugs/debbugs-gnu.el @@ -1,20 +1,21 @@ ;;; debbugs-gnu.el --- interface for the GNU bug tracker -;; Copyright (C) 2011 Free Software Foundation, Inc. +;; Copyright (C) 2011-2014 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen +;; Michael Albinus ;; Keywords: comm, hypermedia, maint ;; Package: debbugs -;; Version: 0.3 +;; Version: 0.6 -;; This file is part of GNU Emacs. +;; This file is not part of GNU Emacs. -;; GNU Emacs is free software: you can redistribute it and/or modify +;; This program is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. -;; GNU Emacs is distributed in the hope that it will be useful, +;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. @@ -30,10 +31,12 @@ ;; also for other GNU projects which use the same bug tracker. ;; If you have `debbugs-gnu.el' in your load-path, you could enable -;; the bug tracker command by the following lines in your ~/.emacs +;; the bug tracker commands by the following lines in your ~/.emacs ;; ;; (autoload 'debbugs-gnu "debbugs-gnu" "" 'interactive) ;; (autoload 'debbugs-gnu-search "debbugs-gnu" "" 'interactive) +;; (autoload 'debbugs-gnu-usertags "debbugs-gnu" "" 'interactive) +;; (autoload 'debbugs-gnu-bugs "debbugs-gnu" "" 'interactive) ;; The bug tracker is called interactively by ;; @@ -46,8 +49,12 @@ ;; used, although configured on the GNU bug tracker. If no severity ;; is given, all bugs are selected. -;; There is also the pseudo severity "tagged", which selects locally -;; tagged bugs. +;; There is also the pseudo severity "tagged". When it is used, the +;; function will ask for user tags (a comma separated list), and shows +;; just the bugs which are tagged with them. In general, user tags +;; shall be strings denoting to subprojects of the package, like +;; "cedet" or "tramp" of the package "emacs". If no user tag is +;; given, locally tagged bugs are shown. ;; If a prefix is given to the command, more search parameters are ;; asked for, like packages (also a comma separated list, "emacs" is @@ -76,7 +83,7 @@ ;; `debbugs-gnu-default-severities', `debbugs-gnu-default-packages', ;; `debbugs-gnu-default-hits-per-page' and `debbugs-gnu-default-suppress-bugs'. -;; The command creates one or more pages of bug lists. Every bug is +;; The commands create one or more pages of bug lists. Every bug is ;; shown in one line, including the bug number, the status (combining ;; merged bug numbers, keywords and severities), the name of the ;; submitter, and the title of the bug. On every bug line you could @@ -93,6 +100,8 @@ ;; "q": Quit the buffer ;; "s": Toggle bug sorting for age or for state ;; "x": Toggle suppressing of bugs +;; "/": Display only bugs matching a string +;; "w": Display all the currently selected bug reports ;; When you visit the related bug messages in Gnus, you could also ;; send control messages by keystroke "C". @@ -102,14 +111,38 @@ ;; happens as expected for the respective column; sorting in the Title ;; column is depending on whether you are the owner of a bug. +;; Another approach for listing bugs is calling the command +;; +;; M-x debbugs-gnu-usertags + +;; This command shows you all existing user tags for the packages +;; defined in `debbugs-gnu-default-packages'. A prefix for the +;; command allows you to use other packe names, or an arbitrary string +;; for a user who has tagged bugs. The command returns the list of +;; existing user tags for the given user(s) or package name(s), +;; respectively. Applying RET on a user tag, all bugs tagged with +;; this user tag are shown. + +;; Unfortunately, it is not possible with the SOAP interface to show +;; all users who have tagged bugs. This list can be retrieved via +;; . + +;; Finally, if you simply want to list some bugs with known bug +;; numbers, call the command +;; +;; M-x debbugs-gnu-bugs + +;; The bug numbers to be shown shall be entered as comma separated list. + ;;; Code: (require 'debbugs) (require 'widget) +(require 'wid-edit) (require 'tabulated-list) +(require 'add-log) (eval-when-compile (require 'cl)) -(autoload 'widget-convert "wid-edit.el") (autoload 'gnus-read-ephemeral-emacs-bug-group "gnus-group") (autoload 'mail-header-subject "nnheader") (autoload 'gnus-summary-article-header "gnus-sum") @@ -123,6 +156,7 @@ (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." + ;; :group 'debbugs-gnu :type '(set (const "serious") (const "important") @@ -132,19 +166,42 @@ (const "tagged")) :version "24.1") +(defconst debbugs-gnu-all-severities + (mapcar 'cadr (cdr (get 'debbugs-gnu-default-severities 'custom-type))) + "*List of all possible severities.") + (defcustom debbugs-gnu-default-packages '("emacs") "*The list of packages to be searched for." + ;; + ;; :group 'debbugs-gnu - :type '(set (const "automake") + :type '(set (const "auctex") + (const "automake") + (const "cc-mode") (const "coreutils") + (const "cppi") (const "debbugs.gnu.org") + (const "diffutils") (const "emacs") (const "emacs-xwidgets") + (const "fm") (const "gnus") + (const "grep") (const "guile") + (const "guix") + (const "gzip") + (const "idutils") (const "libtool") + (const "mh-e") + (const "org-mode") + (const "parted") + (const "vc-dwim") (const "woodchuck")) - :version "24.1") + :version "24.4") + +(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." @@ -186,7 +243,6 @@ suppressed bugs is toggled by `debbugs-gnu-toggle-suppress'." (defvar debbugs-gnu-widget-map (let ((map (make-sparse-keymap))) (define-key map "\r" 'widget-button-press) - (define-key map [mouse-1] 'widget-button-press) (define-key map [mouse-2] 'widget-button-press) map)) @@ -276,20 +332,15 @@ marked as \"client-side filter\"." (setq severities (completing-read-multiple - "Enter severities: " - (mapcar - 'cadr (cdr (get 'debbugs-gnu-default-severities 'custom-type))) - nil t + "Enter severities: " debbugs-gnu-all-severities nil t (mapconcat 'identity debbugs-gnu-default-severities ",")))) ((equal key "package") (setq packages (completing-read-multiple - "Enter packages: " - (mapcar - 'cadr (cdr (get 'debbugs-gnu-default-packages 'custom-type))) - nil t (mapconcat 'identity debbugs-gnu-default-packages ",")))) + "Enter packages: " debbugs-gnu-all-packages nil t + (mapconcat 'identity debbugs-gnu-default-packages ",")))) ((equal key "archive") ;; We simplify, by assuming just archived bugs are requested. @@ -312,8 +363,8 @@ marked as \"client-side filter\"." val1 (completing-read "Enter status: " '("done" "forwarded" "open"))) (when (not (zerop (length val1))) - (add-to-list - 'debbugs-gnu-current-query (cons (intern key) val1)))) + (add-to-list + 'debbugs-gnu-current-query (cons (intern key) val1)))) ;; Client-side filters. ((member key '("date" "log_modified" "last_modified" @@ -377,26 +428,28 @@ marked as \"client-side filter\"." debbugs-gnu-current-filter nil))) ;;;###autoload -(defun debbugs-gnu (severities &optional packages archivedp suppress) - "List all outstanding Emacs bugs." +(defun debbugs-gnu (severities &optional packages archivedp suppress tags) + "List all outstanding bugs." (interactive - (let (archivedp) + (let (severities archivedp) (list - (completing-read-multiple - "Severities: " - (mapcar 'cadr (cdr (get 'debbugs-gnu-default-severities 'custom-type))) - nil t (mapconcat 'identity debbugs-gnu-default-severities ",")) - ;; The optional parameters are asked only when there is a prefix. + (setq severities + (completing-read-multiple + "Severities: " debbugs-gnu-all-severities nil t + (mapconcat 'identity debbugs-gnu-default-severities ","))) + ;; The next parameters are asked only when there is a prefix. (if current-prefix-arg (completing-read-multiple - "Packages: " - (mapcar 'cadr (cdr (get 'debbugs-gnu-default-packages 'custom-type))) - nil t (mapconcat 'identity debbugs-gnu-default-packages ",")) + "Packages: " debbugs-gnu-all-packages nil t + (mapconcat 'identity debbugs-gnu-default-packages ",")) debbugs-gnu-default-packages) (when current-prefix-arg (setq archivedp (y-or-n-p "Show archived bugs?"))) (when (and current-prefix-arg (not archivedp)) - (y-or-n-p "Suppress unwanted bugs?"))))) + (y-or-n-p "Suppress unwanted bugs?")) + ;; This one must be asked for severity "tagged". + (when (member "tagged" severities) + (split-string (read-string "User tag(s): ") "," t))))) ;; Initialize variables. (when (and (file-exists-p debbugs-gnu-persistency-file) @@ -415,6 +468,12 @@ marked as \"client-side filter\"." (add-to-list 'debbugs-gnu-current-query (cons 'package package)))) (when archivedp (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"))) + (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) @@ -473,13 +532,14 @@ marked as \"client-side filter\"." (defun debbugs-gnu-get-bugs (query) "Retrieve bugs numbers from debbugs.gnu.org according search criteria." - (let ((debbugs-port "gnu.org") - (tagged (when (member '(severity . "tagged") query) - (copy-sequence debbugs-gnu-local-tags))) - (phrase (assoc 'phrase query)) - args) + (let* ((debbugs-port "gnu.org") + (bugs (assoc 'bugs query)) + (tags (assoc 'tag query)) + (local-tags (and (member '(severity . "tagged") query) (not tags))) + (phrase (assoc 'phrase query)) + args) ;; Compile query arguments. - (unless query + (unless (or query tags) (dolist (elt debbugs-gnu-default-packages) (setq args (append args (list :package elt))))) (dolist (elt query) @@ -500,34 +560,42 @@ marked as \"client-side filter\"." (list (intern (concat ":" (symbol-name (car elt)))) (cdr elt))))))) - (cond - ;; If the query contains only the pseudo-severity "tagged", we - ;; return just the local tagged bugs. - ((and tagged (not (memq :severity args))) - (sort tagged '<)) - ;; A full text query. - (phrase - (append + (sort + (cond + ;; If the query is just a list of bug numbers, we return them. + (bugs (cdr bugs)) + ;; If the query contains the pseudo-severity "tagged", we return + ;; just the local tagged bugs. + (local-tags (copy-sequence debbugs-gnu-local-tags)) + ;; A full text query. + (phrase (mapcar (lambda (x) (cdr (assoc "id" x))) - (apply 'debbugs-search-est args)) - tagged)) - ;; Otherwise, we retrieve the bugs from the server. - (t (sort (append (apply 'debbugs-get-bugs args) tagged) '<))))) + (apply 'debbugs-search-est args))) + ;; User tags. + (tags + (setq args (mapcar (lambda (x) (if (eq x :package) :user x)) args)) + (apply 'debbugs-get-usertag args)) + ;; Otherwise, we retrieve the bugs from the server. + (t (apply 'debbugs-get-bugs args))) + ;; Sort function. + '<))) (defvar debbugs-gnu-current-widget nil) - -(defvar widget-mouse-face) +(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) (let ((inhibit-read-only t) (debbugs-port "gnu.org")) (erase-buffer) - (set (make-local-variable 'debbugs-gnu-current-widget) - widget) + (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))) @@ -661,13 +729,14 @@ Used instead of `tabulated-list-print-entry'." (memq (cdr (assq 'id list-id)) debbugs-gnu-current-limit)) ;; Filter suppressed bugs. (or (not (widget-get debbugs-gnu-current-widget :suppress)) - (not (catch :suppress - (dolist (check debbugs-gnu-default-suppress-bugs) - (when - (string-match - (cdr check) - (or (cdr (assq (car check) list-id)) "")) - (throw :suppress t)))))) + (and (not (memq (cdr (assq 'id list-id)) debbugs-gnu-local-tags)) + (not (catch :suppress + (dolist (check debbugs-gnu-default-suppress-bugs) + (when + (string-match + (cdr check) + (or (cdr (assq (car check) list-id)) "")) + (throw :suppress t))))))) ;; Filter search list. (not (catch :suppress (dolist (check @@ -752,7 +821,6 @@ Used instead of `tabulated-list-print-entry'." (goto-char pos))) (defvar debbugs-gnu-sort-state 'number) -(defvar debbugs-gnu-current-limit nil) (define-derived-mode debbugs-gnu-mode tabulated-list-mode "Debbugs" "Major mode for listing bug reports. @@ -862,25 +930,27 @@ The following commands are available: "Only display the bugs matching STRING. If STATUS-ONLY (the prefix), ignore matches in the From and Subject fields." - (interactive "sNarrow to: \np") + (interactive "sNarrow to: \nP") (let ((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 (and (not (member string (assq 'keywords status))) - (not (member string (assq 'severity status))) - (or status-only - (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))) - (push (cdr (assq 'id status)) debbugs-gnu-current-limit) - (forward-line 1))) - (when id - (debbugs-gnu-goto id)))) + (if (equal string "") + (debbugs-gnu-toggle-suppress) + (goto-char (point-min)) + (while (not (eobp)) + (setq status (debbugs-gnu-current-status)) + (if (and (not (member string (assq 'keywords status))) + (not (member string (assq 'severity status))) + (or status-only + (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))) + (push (cdr (assq 'id status)) debbugs-gnu-current-limit) + (forward-line 1))) + (when id + (debbugs-gnu-goto id))))) (defun debbugs-gnu-goto (id) "Go to the line displaying bug ID." @@ -890,7 +960,9 @@ Subject fields." (forward-line 1))) (defun debbugs-gnu-toggle-tag () - "Toggle tag of the report in the current line." + "Toggle the local tag of the report in the current line. +If a report is tagged locally, it is presumed to be of little +interest to you." (interactive) (save-excursion (beginning-of-line) @@ -903,9 +975,22 @@ Subject fields." (add-to-list 'debbugs-gnu-local-tags id) (put-text-property (+ (point) (- 5 (length (number-to-string id)))) (+ (point) 5) - 'face 'debbugs-gnu-tagged)))) + 'face 'debbugs-gnu-tagged)) + (debbugs-gnu--update-tag-face id))) (debbugs-gnu-dump-persistency-file)) +(defun debbugs-gnu--update-tag-face (id) + (dolist (entry tabulated-list-entries) + (when (equal (cdr (assq 'id (car entry))) id) + (aset (cadr entry) 0 + (propertize + (format "%5d" id) + 'face + ;; Mark tagged bugs. + (if (memq id debbugs-gnu-local-tags) + 'debbugs-gnu-tagged + 'default)))))) + (defun debbugs-gnu-toggle-suppress () "Suppress bugs marked in `debbugs-gnu-suppress-bugs'." (interactive) @@ -925,13 +1010,21 @@ Subject fields." (defun debbugs-gnu-current-status () (get-text-property (line-beginning-position) 'tabulated-list-id)) -(defun debbugs-gnu-display-status (status) - "Display the status of the report on the current line." - (interactive (list (debbugs-gnu-current-status))) +(defun debbugs-gnu-current-query () + (widget-get debbugs-gnu-current-widget :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*") - (erase-buffer) - (pp status (current-buffer)) - (goto-char (point-min))) + (let ((inhibit-read-only t)) + (erase-buffer) + (when query (pp query (current-buffer))) + (when status (pp status (current-buffer))) + (goto-char (point-min))) + (set-buffer-modified-p nil) + (special-mode)) (defun debbugs-gnu-select-report () "Select the report on the current line." @@ -955,6 +1048,7 @@ Subject fields." (defvar debbugs-gnu-summary-mode-map (let ((map (make-sparse-keymap))) (define-key map "C" 'debbugs-gnu-send-control-message) + (define-key map [(meta m)] 'debbugs-gnu-apply-patch) map)) (defvar gnus-posting-styles) @@ -1016,7 +1110,8 @@ removed instead." "invalid" "reassign" "patch" "wontfix" "moreinfo" "unreproducible" "fixed" "notabug" - "pending" "help" "security" "confirmed") + "pending" "help" "security" "confirmed" + "usertag") nil t) current-prefix-arg)) (let* ((id (or debbugs-gnu-bug-number ; Set on group entry. @@ -1054,7 +1149,7 @@ removed instead." ((equal message "owner") (format "owner %d !\n" id)) ((equal message "reassign") - (format "reassign %d %s\n" id (read-string "Package: "))) + (format "reassign %d %s\n" id (read-string "Package(s): "))) ((equal message "close") (format "close %d %s\n" id version)) ((equal message "done") @@ -1068,12 +1163,298 @@ removed instead." ((equal message "invalid") (format "tags %d notabug\ntags %d wontfix\nclose %d\n" id id id)) + ((equal message "usertag") + (format "user %s\nusertag %d %s\n" + (completing-read + "Package name or email address: " + (append + debbugs-gnu-all-packages (list user-mail-address)) + nil nil (car debbugs-gnu-default-packages)) + id (read-string "User tag: "))) (t (format "tags %d%s %s\n" id (if reverse " -" "") message)))) (funcall send-mail-function)))) +(defvar debbugs-gnu-usertags-mode-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map tabulated-list-mode-map) + (define-key map "\r" 'debbugs-gnu-select-usertag) + (define-key map [mouse-1] 'debbugs-gnu-select-usertag) + (define-key map [mouse-2] 'debbugs-gnu-select-usertag) + map)) + +(define-derived-mode debbugs-gnu-usertags-mode tabulated-list-mode "Usertags" + "Major mode for listing user tags. + +All normal editing commands are switched off. +\\ + +The following commands are available: + +\\{debbugs-gnu-usertags-mode-map}" + (buffer-disable-undo) + (setq truncate-lines t) + (setq buffer-read-only t)) + +;;;###autoload +(defun debbugs-gnu-usertags (&rest users) + "List all user tags for USERS, which is \(\"emacs\"\) by default." + (interactive + (if current-prefix-arg + (completing-read-multiple + "Package name(s) or email address: " + (append debbugs-gnu-all-packages (list user-mail-address)) nil nil + (mapconcat 'identity debbugs-gnu-default-packages ",")) + debbugs-gnu-default-packages)) + + (unwind-protect + (let ((inhibit-read-only t) + (debbugs-port "gnu.org") + (buffer-name "*Emacs User Tags*") + (user-tab-length + (1+ (apply 'max (length "User") (mapcar 'length users))))) + + ;; Initialize variables. + (when (and (file-exists-p debbugs-gnu-persistency-file) + (not debbugs-gnu-local-tags)) + (with-temp-buffer + (insert-file-contents debbugs-gnu-persistency-file) + (eval (read (current-buffer))))) + + ;; Create buffer. + (when (get-buffer buffer-name) + (kill-buffer buffer-name)) + (pop-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) + (dolist (tag (sort (debbugs-get-usertag :user user) 'string<)) + (add-to-list + '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))) + 'append))) + + ;; Add local tags. + (when debbugs-gnu-local-tags + (add-to-list + 'tabulated-list-entries + `((("tagged")) + ,(vector "" (propertize "(local tags)" + 'mouse-face widget-mouse-face))))) + + ;; Show them. + (tabulated-list-init-header) + (tabulated-list-print) + + (set-buffer-modified-p nil) + (goto-char (point-min))))) + +(defun debbugs-gnu-select-usertag () + "Select the user tag on the current line." + (interactive) + ;; We open the bug reports. + (let ((args (get-text-property (line-beginning-position) 'tabulated-list-id))) + (when args (apply 'debbugs-gnu args)))) + +;;;###autoload +(defun debbugs-gnu-bugs (&rest bugs) + "List all BUGS, a list of bug numbers." + (interactive + (mapcar 'string-to-number + (completing-read-multiple "Bug numbers: " nil 'natnump))) + (dolist (elt bugs) + (unless (natnump elt) (signal 'wrong-type-argument (list 'natnump elt)))) + (add-to-list 'debbugs-gnu-current-query (cons 'bugs bugs)) + (debbugs-gnu nil)) + +(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/" + "The directory where the previous source tree lives.") + +(defun debbugs-gnu-apply-patch (&optional branch) + "Apply the patch from the current message. +If given a prefix, patch in the branch directory instead." + (interactive "P") + (add-hook 'emacs-lisp-mode-hook 'debbugs-gnu-lisp-mode) + (add-hook 'diff-mode-hook 'debbugs-gnu-diff-mode) + (add-hook 'change-log-mode-hook 'debbugs-gnu-change-mode) + (let ((rej "/tmp/debbugs-gnu.rej") + (output-buffer (get-buffer-create "*debbugs patch*")) + (dir (if branch + debbugs-gnu-branch-directory + debbugs-gnu-trunk-directory)) + (patch-buffers nil)) + (when (file-exists-p rej) + (delete-file rej)) + (with-current-buffer output-buffer + (erase-buffer)) + (gnus-summary-select-article nil t) + ;; The patches are either in MIME attachements or the main article + ;; buffer. Determine which. + (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)))) + (unless patch-buffers + (gnus-summary-show-article 'raw) + (article-decode-charset) + (push (current-buffer) patch-buffers)) + (dolist (buffer patch-buffers) + (with-current-buffer buffer + (call-process-region (point-min) (point-max) + "patch" nil output-buffer nil + "-r" rej "--no-backup-if-mismatch" + "-l" "-f" + "-d" (expand-file-name dir) + "-p1"))) + (set-buffer output-buffer) + (when (file-exists-p rej) + (goto-char (point-max)) + (insert-file-contents-literally rej)) + (goto-char (point-max)) + (save-some-buffers t) + (require 'compile) + (mapcar 'kill-process compilation-in-progress) + (compile (format "cd %s; make -k" (expand-file-name "lisp" dir))) + (vc-dir dir) + (vc-dir-hide-up-to-date) + (goto-char (point-min)) + (sit-for 1) + (vc-diff) + ;; All these commands are asynchronous, so just wait a bit. This + ;; should be done properly a different way. + (sit-for 2) + ;; We've now done everything, so arrange the windows we need to see. + (delete-other-windows) + (switch-to-buffer output-buffer) + (split-window) + (split-window) + (other-window 1) + (switch-to-buffer "*compilation*") + (goto-char (point-max)) + (other-window 1) + (switch-to-buffer "*vc-diff*") + (goto-char (point-min)))) + +(defun debbugs-gnu-find-contributor (string) + "Search through ChangeLogs to find contributors." + (interactive "sContributor match: ") + (let ((found 0) + (match (concat "^[0-9].*" string))) + (dolist (file (directory-files-recursively + debbugs-gnu-trunk-directory "ChangeLog\\(.[0-9]+\\)?$")) + (with-temp-buffer + (when (file-exists-p file) + (insert-file-contents file)) + (goto-char (point-min)) + (while (and (re-search-forward match nil t) + (not (looking-at ".*tiny change"))) + (cl-incf found)))) + (message "%s is a contributor %d times" string found) + found)) + +(defun debbugs-gnu-insert-changelog () + "Add a ChangeLog from a recently applied patch from a third party." + (interactive) + (let (from subject) + (gnus-with-article-buffer + (widen) + (goto-char (point-min)) + (setq from (mail-extract-address-components (gnus-fetch-field "from")) + subject (gnus-fetch-field "subject"))) + (let ((add-log-full-name (car from)) + (add-log-mailing-address (cadr from))) + (add-change-log-entry-other-window) + (let ((point (point))) + (when (string-match "\\(bug#[0-9]+\\)" subject) + (insert " (" (match-string 1 subject) ").")) + (when (zerop (debbugs-gnu-find-contributor + (let ((bits (split-string (car from)))) + (cond + ((>= (length bits) 2) + (format "%s.*%s" (car bits) (car (last bits)))) + ((= (length bits) 1) + (car bits)) + ;; Fall back on the email address. + (t + (cadr from)))))) + (goto-char (point-min)) + (end-of-line) + (insert " (tiny change")) + (goto-char point))))) + +(defvar debbugs-gnu-lisp-mode-map + (let ((map (make-sparse-keymap))) + (define-key map [(meta m)] 'debbugs-gnu-insert-changelog) + map)) + +(define-minor-mode debbugs-gnu-lisp-mode + "Minor mode for providing a debbugs interface in Lisp buffers. +\\{debbugs-gnu-lisp-mode-map}" + :lighter " Debbugs" :keymap debbugs-gnu-lisp-mode-map) + +(defvar debbugs-gnu-diff-mode-map + (let ((map (make-sparse-keymap))) + (define-key map [(meta m)] 'debbugs-gnu-diff-select) + map)) + +(define-minor-mode debbugs-gnu-diff-mode + "Minor mode for providing a debbugs interface in diff buffers. +\\{debbugs-gnu-diff-mode-map}" + :lighter " Debbugs" :keymap debbugs-gnu-diff-mode-map) + +(defun debbugs-gnu-diff-select () + "Select the diff under point." + (interactive) + (delete-other-windows) + (diff-goto-source)) + +(defvar debbugs-gnu-change-mode-map + (let ((map (make-sparse-keymap))) + (define-key map [(meta m)] 'debbugs-gnu-change-checkin) + map)) + +(define-minor-mode debbugs-gnu-change-mode + "Minor mode for providing a debbugs interface in ChangeLog buffers. +\\{debbugs-gnu-change-mode-map}" + :lighter " Debbugs" :keymap debbugs-gnu-change-mode-map) + +(defun debbugs-gnu-change-checkin () + "Prepare checking in the current changes." + (interactive) + (save-some-buffers t) + (when (get-buffer "*vc-dir*") + (kill-buffer (get-buffer "*vc-dir*"))) + (vc-dir debbugs-gnu-trunk-directory) + (goto-char (point-min)) + (while (not (search-forward "edited" nil t)) + (sit-for 0.01)) + (beginning-of-line) + (while (search-forward "edited" nil t) + (vc-dir-mark) + (beginning-of-line)) + (vc-diff nil) + (vc-next-action nil) + (log-edit-insert-changelog t) + (delete-other-windows) + (split-window) + (other-window 1) + (switch-to-buffer "*vc-diff*") + (other-window 1)) + (provide 'debbugs-gnu) ;;; TODO: