From 24c69eb2d660ea076f1533e6afaae3152460d0d2 Mon Sep 17 00:00:00 2001 From: Eshel Yaron Date: Tue, 28 May 2024 20:43:52 +0200 Subject: [PATCH] (gnus-summary-increase-score): Use 'read-multiple-choice' --- lisp/gnus/gnus-score.el | 213 +++++++++------------------------------- 1 file changed, 44 insertions(+), 169 deletions(-) diff --git a/lisp/gnus/gnus-score.el b/lisp/gnus/gnus-score.el index 479b7496cf1..682815a5f7c 100644 --- a/lisp/gnus/gnus-score.el +++ b/lisp/gnus/gnus-score.el @@ -519,33 +519,6 @@ of the last successful match.") -;; Touch screen ``character reading'' routines for -;; `gnus-summary-increase-score' and friends. - -(defun gnus-read-char (prompt options) - "Read a character from the keyboard. - -On Android, if `use-dialog-box-p' returns non-nil, display a -dialog box containing PROMPT, with buttons representing each of -item in the list of characters OPTIONS instead. - -Value is the character read, as with `read-char', or nil upon -failure." - (if (and (display-graphic-p) (featurep 'android) - (use-dialog-box-p)) - ;; Set up the dialog box. - (let ((dialog (cons prompt ; Message displayed in dialog box. - (mapcar (lambda (arg) - (cons (char-to-string arg) - arg)) - options)))) - ;; Display the dialog box. - (x-popup-dialog t dialog)) - ;; Fall back to read-char. - (read-char))) - - - ;; Summary score file commands ;; Much modification of the kill (ahem, score) code and lots of the @@ -578,7 +551,6 @@ current score file." (interactive (gnus-interactive "P\ny") gnus-article-mode gnus-summary-mode) (let* ((nscore (gnus-score-delta-default score)) - (prefix (if (< nscore 0) ?L ?I)) (increase (> nscore 0)) (char-to-header '((?a "from" nil nil string) @@ -619,104 +591,50 @@ current score file." (aref (symbol-name gnus-score-default-duration) 0))) entry temporary type match extra header-string) - (unwind-protect - (progn - (setq header-string - (format "%s header (%s?): " (if increase "Increase" "Lower") - (mapconcat (lambda (s) (char-to-string (car s))) - char-to-header ""))) - ;; First we read the header to score. - (while (not hchar) - (if mimic - (progn - (sit-for 1) - (message "%c-" prefix)) - (message header-string)) - (setq hchar (gnus-read-char header-string - (mapcar #'car char-to-header))) - (when (or (= hchar ??) (= hchar ?\C-h)) - (setq hchar nil) - (gnus-score-insert-help "Match on header" char-to-header 1))) - - (gnus-score-kill-help-buffer) - (unless (setq entry (assq (downcase hchar) char-to-header)) - (if mimic (error "%c %c" prefix hchar) - (error "Invalid header type"))) - - (when (/= (downcase hchar) hchar) - ;; This was a majuscule, so we end reading and set the defaults. - (if mimic (message "%c %c" prefix hchar) (message "")) - (setq tchar (or tchar ?s) - pchar (or pchar ?t))) - - (let ((legal-types - (delq nil - (mapcar (lambda (s) - (if (eq (nth 4 entry) - (nth 3 s)) - s nil)) - char-to-type)))) - (setq header-string - (format "%s header `%s' with match type (%s?): " - (if increase "Increase" "Lower") - (nth 1 entry) - (mapconcat (lambda (s) (char-to-string (car s))) - legal-types ""))) - ;; We continue reading - the type. - (while (not tchar) - (if mimic - (progn - (sit-for 1) (message "%c %c-" prefix hchar)) - (message header-string)) - (setq tchar (gnus-read-char header-string - (mapcar #'car legal-types))) - (when (or (= tchar ??) (= tchar ?\C-h)) - (setq tchar nil) - (gnus-score-insert-help "Match type" legal-types 2))) - - (gnus-score-kill-help-buffer) - (unless (setq type (nth 1 (assq (downcase tchar) legal-types))) - (if mimic (error "%c %c" prefix hchar) - (error "Invalid match type")))) - - (when (/= (downcase tchar) tchar) - ;; It was a majuscule, so we end reading and use the default. - (if mimic (message "%c %c %c" prefix hchar tchar) - (message "")) - (setq pchar (or pchar ?t))) - - (setq header-string - (format "%s permanence (%s?): " (if increase "Increase" "Lower") - (mapconcat (lambda (s) (char-to-string (car s))) - char-to-perm ""))) - - ;; We continue reading. - (while (not pchar) - (if mimic - (progn - (sit-for 1) (message "%c %c %c-" prefix hchar tchar)) - (message header-string)) - (setq pchar (gnus-read-char header-string - (mapcar #'car char-to-perm))) - (when (or (= pchar ??) (= pchar ?\C-h)) - (setq pchar nil) - (gnus-score-insert-help "Match permanence" char-to-perm 2))) - - (gnus-score-kill-help-buffer) - (if mimic (message "%c %c %c %c" prefix hchar tchar pchar) - (message "")) - (unless (setq temporary (cadr (assq pchar char-to-perm))) - ;; Deal with der(r)ided superannuated paradigms. - (when (and (eq (1+ prefix) 77) - (eq (+ hchar 12) 109) - (eq (1- tchar) 113) - (eq (- pchar 4) 111)) - (error "You rang?")) - (if mimic - (error "%c %c %c %c" prefix hchar tchar pchar) - (error "Invalid match duration")))) - ;; Always kill the score help buffer. - (gnus-score-kill-help-buffer)) + (unless hchar + (setq header-string + (format "%s header:" (if increase "Increase" "Lower"))) + ;; First we read the header to score. + (setq hchar (car (read-multiple-choice header-string char-to-header)) + entry (assq (downcase hchar) char-to-header))) + + (when (/= (downcase hchar) hchar) + ;; This was a majuscule, so we end reading and set the defaults. + (setq tchar (or tchar ?s) + pchar (or pchar ?t))) + + (unless tchar + (let ((legal-types + (seq-filter (lambda (s) + (eq (nth 4 entry) (nth 3 s))) + char-to-type))) + (setq header-string + (format "%s header `%s' with match type:" + (if increase "Increase" "Lower") + (nth 1 entry))) + ;; We continue reading - the type. + (setq tchar (car (read-multiple-choice + header-string + (mapcar (pcase-lambda (`(,c ,_ ,d . ,_)) + `(,c ,d)) + legal-types))) + type (nth 1 (assq (downcase tchar) legal-types))))) + + (when (/= (downcase tchar) tchar) + ;; It was a majuscule, so we end reading and use the default. + (setq pchar (or pchar ?t))) + + (unless pchar + (setq header-string + (format "%s permanence:" (if increase "Increase" "Lower"))) + + ;; We continue reading. + (setq pchar (read-multiple-choice header-string + (mapcar (pcase-lambda (`(,c ,_ ,d . ,_)) + `(,c ,d)) + char-to-perm)))) + + (setq temporary (cadr (assq pchar char-to-perm))) ;; If scoring an extra (non-standard overview) header, ;; we must find out which header is in question. @@ -783,49 +701,6 @@ current score file." (autoload 'appt-select-lowest-window "appt") -(defun gnus-score-insert-help (string alist idx) - (setq gnus-score-help-winconf (current-window-configuration)) - (with-current-buffer (gnus-get-buffer-create "*Score Help*") - (buffer-disable-undo) - (delete-windows-on (current-buffer)) - (erase-buffer) - (insert string ":\n\n") - (let ((max -1) - (list alist) - (i 0) - n width pad format) - ;; find the longest string to display - (while list - (setq n (length (nth idx (car list)))) - (unless (> max n) - (setq max n)) - (setq list (cdr list))) - (setq max (+ max 4)) ; %c, `:', SPACE, a SPACE at end - (setq n (/ (1- (window-width)) max)) ; items per line - (setq width (/ (1- (window-width)) n)) ; width of each item - ;; insert `n' items, each in a field of width `width' - (while alist - (if (< i n) - () - (setq i 0) - (delete-char -1) ; the `\n' takes a char - (insert "\n")) - (setq pad (- width 3)) - (setq format (concat "%c: %-" (int-to-string pad) "s")) - (insert (format format (caar alist) (nth idx (car alist)))) - (setq alist (cdr alist)) - (setq i (1+ i)))) - (goto-char (point-min)) - ;; display ourselves in a small window at the bottom - (appt-select-lowest-window) - (if (< (/ (window-height) 2) window-min-height) - (switch-to-buffer "*Score Help*") - (split-window) - (pop-to-buffer "*Score Help*")) - (let ((window-min-height 1)) - (shrink-window-if-larger-than-buffer)) - (select-window (gnus-get-buffer-window gnus-summary-buffer t)))) - (defun gnus-summary-header (header &optional no-err extra) ;; Return HEADER for current articles, or error. (let ((article (gnus-summary-article-number)) -- 2.39.5