X-Git-Url: https://code.delx.au/gnu-emacs-elpa/blobdiff_plain/f7726f90257c164c7396b79acf3b42c27944ebad..2ceefab3550759fd970c4210d64285dec263af81:/packages/debbugs/debbugs-gnu.el diff --git a/packages/debbugs/debbugs-gnu.el b/packages/debbugs/debbugs-gnu.el index 678131d32..e8496d003 100644 --- a/packages/debbugs/debbugs-gnu.el +++ b/packages/debbugs/debbugs-gnu.el @@ -47,6 +47,11 @@ (defface debbugs-done '((t (:foreground "DarkGrey"))) "Face for closed bug reports.") +(defvar debbugs-widget-map + (let ((map (make-sparse-keymap))) + (define-key map "\r" 'widget-button-press) + map)) + (defun debbugs-emacs (severities &optional package suppress-done archivedp) "List all outstanding Emacs bugs." (interactive @@ -93,158 +98,128 @@ :follow-link 'mouse-face :notify (lambda (widget &rest ignore) (debbugs-show-reports + (widget-get widget :suppress-done) widget - (widget-get widget :debbugs-widgets))) - :debbugs-suppress-done suppress-done - :debbugs-buffer-name (format "*Emacs Bugs*<%d>" i) - :debbugs-ids curr-ids - :help-echo (format - "%d-%d" - (car ids) (car (last curr-ids))) - :format " %[%v%]" - (number-to-string i)))) + (widget-get widget :widgets))) + :keymap debbugs-widget-map + :suppress-done suppress-done + :buffer-name (format "*Emacs Bugs*<%d>" i) + :bug-ids (butlast ids (- (length ids) default)) + (format " %d" i)))) ids (last ids (- (length ids) default)))) - (debbugs-show-reports (car widgets) widgets)) + (debbugs-show-reports suppress-done (car widgets) widgets)) - (debbugs-show-reports (widget-convert + (debbugs-show-reports suppress-done + (widget-convert 'const - :debbugs-suppress-done suppress-done - :debbugs-buffer-name "*Emacs Bugs*" - :debbugs-ids ids) + :buffer-name "*Emacs Bugs*" + :bug-ids ids) nil)))) -(defun debbugs-widget-format-handler (widget escape) - (cond - ;; That's the only format we support. - ((eq escape ?f) - (let ((size (widget-get widget :debbugs-size)) - (string (format (widget-get widget :debbugs-format) - (widget-value widget)))) - (insert - (cond - ((and (numberp size) (> (length string) size)) - (propertize (substring string 0 size) 'help-echo string)) - ((numberp size) string) - (t (propertize string 'help-echo string)))))) - ;; Error handling. - (t - (widget-default-format-handler widget escape)))) - -(defun debbugs-show-reports (widget widgets) - "Show bug reports as given in WIDGET property :debbugs-ids." - (pop-to-buffer (get-buffer-create (widget-get widget :debbugs-buffer-name))) +(defun debbugs-show-reports (suppress-done widget widgets) + "Show bug reports as given in WIDGET property :bug-ids." + (pop-to-buffer (get-buffer-create (widget-get widget :buffer-name))) (debbugs-mode) - (let ((suppress-done (widget-get widget :debbugs-suppress-done))) + (let ((inhibit-read-only t)) (erase-buffer) (when widgets (widget-insert "Page:") (mapc (lambda (obj) - (widget-put obj :debbugs-widgets widgets) - (widget-put obj :button-face - (if (eq obj widget) - 'widget-button-pressed - 'widget-button-face)) + (widget-insert " ") + (widget-put obj :widgets widgets) + (if (eq obj widget) + (widget-put obj :button-face 'widget-button-pressed) + (widget-put obj :button-face 'widget-button-face)) (widget-apply obj :create)) widgets) (widget-insert "\n\n")) (dolist (status (sort (apply 'debbugs-get-status - (widget-get widget :debbugs-ids)) + (widget-get widget :bug-ids)) (lambda (s1 s2) (< (cdr (assq 'id s1)) (cdr (assq 'id s2)))))) (when (or (not suppress-done) (not (equal (cdr (assq 'pending status)) "done"))) - (let ((id (cdr (assq 'id status))) - (face - (cond - ((equal (cdr (assq 'pending status)) "done") - 'debbugs-done) - ((= (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))) - (words - (mapconcat - 'identity - (cons (cdr (assq 'severity status)) - (cdr (assq 'keywords status))) - ",")) - (address (mail-header-parse-address + (let ((address (mail-header-parse-address (decode-coding-string (cdr (assq 'originator 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))))) - (when (setq merged (cdr (assq 'mergedwith status))) - (setq words (format "%s,%s" - (if (numberp merged) - merged - (mapconcat 'number-to-string merged ",")) - words))) (setq address ;; Prefer the name over the address. (or (cdr address) (car address))) - - (widget-create 'const - :format "%f" - :debbugs-format "%5d" - :debbugs-size 5 - :debbugs-status status - :format-handler 'debbugs-widget-format-handler - id) - - (widget-create 'const - :format " %{%f%}" - :debbugs-format "%-20s" - :debbugs-size 20 - :format-handler 'debbugs-widget-format-handler - :sample-face face - words) - - (widget-create 'const - :format " [%f]" - :debbugs-format "%-23s" - :debbugs-size 23 - :format-handler 'debbugs-widget-format-handler - address) - - (let ((widget-link-prefix "") - (widget-link-suffix "")) - (widget-create 'link - :format " %[%v%]\n" - :debbugs-id id - :follow-link 'mouse-face - :notify (lambda (widget &rest ignore) - (debbugs-select-report - (widget-get widget :debbugs-id))) - :help-echo subject - subject))))) + (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))))) + (when (setq merged (cdr (assq 'mergedwith status))) + (setq words (format "%s,%s" + (if (numberp merged) + merged + (mapconcat 'number-to-string merged + ",")) + words))) + (if (> (length words) 20) + (propertize (substring words 0 20) 'help-echo words) + words)) + (if (> (length address) 23) + (propertize (substring address 0 23) 'help-echo address) + address) + (propertize subject 'help-echo subject))) + (forward-line -1) + (put-text-property (point) (1+ (point)) + 'debbugs-status status) + (put-text-property + (+ (point) 5) (+ (point) 26) + 'face + (cond + ((equal (cdr (assq 'pending status)) "done") + 'debbugs-done) + ((= (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)))) (when widgets (widget-insert "\nPage:") - (mapc (lambda (obj) (widget-apply obj :create)) widgets)) + (mapc + (lambda (obj) + (widget-insert " ") + (widget-put obj :widgets widgets) + (if (eq obj widget) + (widget-put obj :button-face 'widget-button-pressed) + (widget-put obj :button-face 'widget-button-face)) + (widget-apply obj :create)) + widgets) + (widget-setup)) - (widget-setup) - (set-buffer-modified-p nil) (goto-char (point-min)))) (defvar debbugs-mode-map - (let ((map (copy-keymap special-mode-map))) + (let ((map (make-sparse-keymap))) + (define-key map "\r" 'debbugs-select-report) (define-key map "q" 'kill-buffer) (define-key map "s" 'debbugs-toggle-sort) - (set-keymap-parent map widget-keymap) + (define-key map "d" 'debbugs-display-status) map)) (defvar debbugs-sort-state 'number) @@ -280,31 +255,63 @@ The following commands are available: (interactive) (beginning-of-line) (let ((buffer-read-only nil) - (current-bug (and (not (eobp)) - (buffer-substring (point) (+ (point) 5))))) - (goto-char (point-min)) + (before-change-functions nil) + (current-bug (debbugs-current-id t))) (setq debbugs-sort-state (if (eq debbugs-sort-state 'number) 'state 'number)) - (sort-subr - nil (lambda () (forward-line 1)) 'end-of-line - (lambda () - (if (eq debbugs-sort-state 'number) - (string-to-number (buffer-substring (point) (+ (point) 5))) - (or (cdr (assq (get-text-property (+ (point) 7) 'face) - debbugs-state-preference)) - 10)))) + (goto-char (point-min)) + (while (and (not (eobp)) + (not (get-text-property (point) 'debbugs-status))) + (forward-line 1)) + (save-restriction + (narrow-to-region + (point) + (progn + (goto-char (point-max)) + (beginning-of-line) + (while (and (not (bobp)) + (not (get-text-property (point) 'debbugs-status))) + (forward-line -1)) + (forward-line 1) + (point))) + (goto-char (point-min)) + (sort-subr + nil (lambda () (forward-line 1)) 'end-of-line + (lambda () + (if (eq debbugs-sort-state 'number) + (debbugs-current-id) + (or (cdr (assq (get-text-property (+ (point) 7) 'face) + debbugs-state-preference)) + 10))))) (if (not current-bug) (goto-char (point-max)) (goto-char (point-min)) - (re-search-forward (concat "^" current-bug) nil t)))) + (re-search-forward (format "^%d" current-bug) nil t)))) (defvar debbugs-bug-number nil) +(defun debbugs-current-id (&optional noerror) + (or (cdr (assq 'id (get-text-property (line-beginning-position) + 'debbugs-status))) + (and (not noerror) + (error "No bug on the current line")))) + +(defun debbugs-display-status (id) + "Display the status of the report on the current line." + (interactive (list (debbugs-current-id))) + (let ((status (get-text-property (line-beginning-position) + 'debbugs-status))) + (pop-to-buffer "*Bug Status*") + (erase-buffer) + (pp status (current-buffer)) + (goto-char (point-min)))) + (defun debbugs-select-report (id) - "Select the report for ID." - (interactive) + "Select the report on the current line." + (interactive (list (debbugs-current-id))) + ;; We open the report messages. (gnus-read-ephemeral-emacs-bug-group id (cons (current-buffer) (current-window-configuration)))