;;; gnus-score.el --- scoring code for Gnus
-;; Copyright (C) 1995-2012 Free Software Foundation, Inc.
+;; Copyright (C) 1995-2016 Free Software Foundation, Inc.
;; Author: Per Abrahamsen <amanda@iesd.auc.dk>
;; Lars Magne Ingebrigtsen <larsi@gnus.org>
(require 'gnus)
(require 'gnus-sum)
+(require 'gnus-art)
(require 'gnus-range)
(require 'gnus-win)
(require 'message)
(require 'score-mode)
+(require 'gmm-utils)
(defcustom gnus-global-score-files nil
"List of global score files and directories.
(if mimic
(progn
(sit-for 1) (message "%c %c-" prefix hchar))
- (message "%s header '%s' with match type (%s?): "
+ (message "%s header `%s' with match type (%s?): "
(if increase "Increase" "Lower")
(nth 1 entry)
(mapconcat (lambda (s) (char-to-string (car s)))
(with-current-buffer gnus-summary-buffer
(gnus-score-load-file 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*")
(setq i (1+ i))))
(goto-char (point-min))
;; display ourselves in a small window at the bottom
- (gnus-select-lowest-window)
+ (appt-select-lowest-window)
(if (< (/ (window-height) 2) window-min-height)
(switch-to-buffer "*Score Help*")
(split-window)
(push (cons article n) gnus-newsgroup-scored)))
(gnus-summary-update-line)))
-(defun gnus-summary-current-score ()
- "Return the score of the current article."
- (interactive)
- (gnus-message 1 "%s" (gnus-summary-article-score)))
+(defun gnus-summary-current-score (arg)
+ "Return the score of the current article.
+ With prefix ARG, return the total score of the current (sub)thread."
+ (interactive "P")
+ (gnus-message 1 "%s" (if arg
+ (gnus-thread-total-score
+ (gnus-id-to-thread
+ (mail-header-id (gnus-summary-article-header))))
+ (gnus-summary-article-score))))
(defun gnus-score-change-score-file (file)
"Change current score alist."
(and (file-exists-p file)
(not (file-writable-p file))))
()
- (setq score (setcdr entry (gnus-delete-alist 'touched score)))
+ (setq score (setcdr entry (assq-delete-all 'touched score)))
(erase-buffer)
(let (emacs-lisp-mode-hook)
(if (and (not gnus-adaptive-pretty-print)
nil)
(defun gnus-score-decode-text-parts ()
- (labels ((mm-text-parts (handle)
- (cond ((stringp (car handle))
- (let ((parts (mapcan #'mm-text-parts (cdr handle))))
- (if (equal "multipart/alternative" (car handle))
- ;; pick the first supported alternative
- (list (car parts))
- parts)))
-
- ((bufferp (car handle))
- (when (string-match "^text/" (mm-handle-media-type handle))
- (list handle)))
-
- (t (mapcan #'mm-text-parts handle))))
- (my-mm-display-part (handle)
- (when handle
- (save-restriction
- (narrow-to-region (point) (point))
- (mm-display-inline handle)
- (goto-char (point-max))))))
-
- (let (;(mm-text-html-renderer 'w3m-standalone)
- (handles (mm-dissect-buffer t)))
+ (cl-labels
+ ((mm-text-parts
+ (handle)
+ (cond ((stringp (car handle))
+ (let ((parts (apply #'append
+ (mapcar #'mm-text-parts (cdr handle)))))
+ (if (equal "multipart/alternative" (car handle))
+ ;; pick the first supported alternative
+ (list (car parts))
+ parts)))
+
+ ((bufferp (car handle))
+ (when (string-match "^text/" (mm-handle-media-type handle))
+ (list handle)))
+
+ (t (apply #'append (mapcar #'mm-text-parts handle)))))
+ (my-mm-display-part
+ (handle)
+ (when handle
+ (save-restriction
+ (narrow-to-region (point) (point))
+ (mm-display-inline handle)
+ (goto-char (point-max))))))
+
+ (let ( ;(mm-text-html-renderer 'w3m-standalone)
+ (handles (mm-dissect-buffer t)))
(save-excursion
- (article-goto-body)
- (delete-region (point) (point-max))
- (mapc #'my-mm-display-part (mm-text-parts handles))
- handles))))
+ (article-goto-body)
+ (delete-region (point) (point-max))
+ (mapc #'my-mm-display-part (mm-text-parts handles))
+ handles))))
(defun gnus-score-body (scores header now expire &optional trace)
(if gnus-agent-fetching
(all-scores scores)
(request-func (cond ((string= "head" header)
'gnus-request-head)
- ;; We need to peek at the headers to detect
- ;; the content encoding
((string= "body" header)
- 'gnus-request-article)
+ 'gnus-request-body)
(t 'gnus-request-article)))
entries alist ofunc article last)
(when articles
(setq last (mail-header-number (caar (last articles))))
;; Not all backends support partial fetching. In that case,
;; we just fetch the entire article.
- (unless (gnus-check-backend-function
- (and (string-match "^gnus-" (symbol-name request-func))
- (intern (substring (symbol-name request-func)
- (match-end 0))))
- gnus-newsgroup-name)
+ ;; When scoring by body, we need to peek at the headers to detect
+ ;; the content encoding
+ (unless (or (gnus-check-backend-function
+ (and (string-match "^gnus-" (symbol-name request-func))
+ (intern (substring (symbol-name request-func)
+ (match-end 0))))
+ gnus-newsgroup-name)
+ (string= "body" header))
(setq ofunc request-func)
(setq request-func 'gnus-request-article))
(while articles
(defun gnus-decay-score (score)
"Decay SCORE according to `gnus-score-decay-constant' and `gnus-score-decay-scale'."
- (let ((n (- score
- (* (if (< score 0) -1 1)
- (min (abs score)
- (max gnus-score-decay-constant
- (* (abs score)
- gnus-score-decay-scale)))))))
- (if (and (featurep 'xemacs)
- ;; XEmacs's floor can handle only the floating point
- ;; number below the half of the maximum integer.
- (> (abs n) (lsh -1 -2)))
- (string-to-number
- (car (split-string (number-to-string n) "\\.")))
- (floor n))))
+ (floor (- score
+ (* (if (< score 0) -1 1)
+ (min (abs score)
+ (max gnus-score-decay-constant
+ (* (abs score)
+ gnus-score-decay-scale)))))))
(defun gnus-decay-scores (alist day)
"Decay non-permanent scores in ALIST."