\f
-;; 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)))
-
-\f
-
;; Summary score file commands
;; Much modification of the kill (ahem, score) code and lots of the
(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)
(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.
(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))
projects / emacs.git / commitdiff