Function: gnus-score-string

gnus-score-string is a byte-compiled function defined in gnus-score.el.gz.

Signature

(gnus-score-string SCORE-LIST HEADER NOW EXPIRE &optional TRACE)

Source Code

;; Defined in /usr/src/emacs/lisp/gnus/gnus-score.el.gz
(defun gnus-score-string (score-list header now expire &optional trace)
  ;; Score ARTICLES according to HEADER in SCORE-LIST.
  ;; Update matching entries to NOW and remove unmatched entries older
  ;; than EXPIRE.

  ;; Insert the unique article headers in the buffer.
  (let ((gnus-score-index (nth 1 (assoc header gnus-header-index)))
	;; gnus-score-index is used as a free variable.
	(simplify (and gnus-score-thread-simplify
		       (string= "subject" header)))
	alike last this art entries alist articles
	fuzzies arts words kill)

    ;; Sorting the articles costs os O(N*log N) but will allow us to
    ;; only match with each unique header.  Thus the actual matching
    ;; will be O(M*U) where M is the number of strings to match with,
    ;; and U is the number of unique headers.  It is assumed (but
    ;; untested) this will be a net win because of the large constant
    ;; factor involved with string matching.
    (setq gnus-scores-articles
	  ;; We cannot string-sort the extra headers list.  *sigh*
	  (if (= gnus-score-index 9)
	      gnus-scores-articles
	    (sort gnus-scores-articles #'gnus-score-string<))
	  articles gnus-scores-articles)

    (erase-buffer)
    (while (setq art (pop articles))
      (setq this (aref (car art) gnus-score-index))

      ;; If we're working with non-standard headers, we are stuck
      ;; with working on them as a group.  What a hassle.
      ;; Just wait 'til you see what horrors we commit against `match'...
      (if (= gnus-score-index 9)
	  (setq this (gnus-prin1-to-string this))) ; ick.

      (if simplify
	  (setq this (gnus-map-function gnus-simplify-subject-functions this)))
      (if (equal last this)
	  ;; O(N*H) cons-cells used here, where H is the number of
	  ;; headers.
	  (push art alike)
	(when last
	  ;; Insert the line, with a text property on the
	  ;; terminating newline referring to the articles with
	  ;; this line.
	  (insert last ?\n)
	  (put-text-property (1- (point)) (point) 'articles alike))
	(setq alike (list art)
	      last this)))
    (when last				; Bwadr, duplicate code.
      (insert last ?\n)
      (put-text-property (1- (point)) (point) 'articles alike))

    ;; Go through all the score alists and pick out the entries
    ;; for this header.
    (while score-list
      (setq alist (pop score-list)
	    ;; There's only one instance of this header for
	    ;; each score alist.
	    entries (assoc header alist))
      (while (cdr entries)		;First entry is the header index.
	(let* ((kill (cadr entries))
	       (type (or (nth 3 kill) 's))
	       (score (or (nth 1 kill) gnus-score-interactive-default-score))
	       (date (nth 2 kill))
	       (extra (nth 4 kill))	; non-standard header; string.
	       (found nil)
	       (mt (aref (symbol-name type) 0))
	       (case-fold-search (not (memq mt '(?R ?S ?E ?F))))
	       (dmt (downcase mt))
	       ;; Assume user already simplified regexp and fuzzies
	       (match (if (and simplify (not (memq dmt '(?f ?r))))
			  (gnus-map-function
			   gnus-simplify-subject-functions
			   (nth 0 kill))
			(nth 0 kill)))
	       (search-func
		(cond ((= dmt ?r) 're-search-forward)
		      ((or (= dmt ?e) (= dmt ?s) (= dmt ?f)) 'search-forward)
		      ((= dmt ?w) nil)
		      (t (error "Invalid match type: %s" type)))))

	  ;; Evil hackery to make match usable in non-standard headers.
	  (when extra
	    (setq match (concat "[ (](" extra " \\. \"\\([^\"]*\\\\\"\\)*[^\"]*"
				(if (eq search-func 're-search-forward)
				    match
				  (regexp-quote match))
				"\\([^\"]*\\\\\"\\)*[^\"]*\")[ )]")
		  search-func 're-search-forward)) ; XXX danger?!?

	  (cond
	   ;; Fuzzy matches.  We save these for later.
	   ((= dmt ?f)
	    (push (cons entries alist) fuzzies)
	    (setq entries (cdr entries)))
	   ;; Word matches.  Save these for even later.
	   ((= dmt ?w)
	    (push (cons entries alist) words)
	    (setq entries (cdr entries)))
	   ;; Exact matches.
	   ((= dmt ?e)
	    ;; Do exact matching.
	    (goto-char (point-min))
	    (while (and (not (eobp))
			(funcall search-func match nil t))
	      ;; Is it really exact?
	      (and (eolp)
                   (= (line-beginning-position) (match-beginning 0))
		   ;; Yup.
		   (progn
		     (setq found (setq arts (get-text-property
					     (point) 'articles)))
		     ;; Found a match, update scores.
		     (if trace
			 (while (setq art (pop arts))
			   (setcdr art (+ score (cdr art)))
			   (push
			    (cons
			     (car-safe (rassq alist gnus-score-cache))
			     kill)
			    gnus-score-trace))
		       (while (setq art (pop arts))
			 (setcdr art (+ score (cdr art)))))))
	      (forward-line 1))
	    ;; Update expiry date
	    (if trace
		(setq entries (cdr entries))
	      (cond
	       ;; Permanent entry.
	       ((null date)
		(setq entries (cdr entries)))
	       ;; We have a match, so we update the date.
	       ((and found gnus-update-score-entry-dates)
		(gnus-score-set 'touched '(t) alist)
		(setcar (nthcdr 2 kill) now)
		(setq entries (cdr entries)))
	       ;; This entry has expired, so we remove it.
	       ((and expire (< date expire))
		(gnus-score-set 'touched '(t) alist)
		(setcdr entries (cddr entries)))
	       ;; No match; go to next entry.
	       (t
		(setq entries (cdr entries))))))
	   ;; Regexp and substring matching.
	   (t
	    (goto-char (point-min))
	    (when (string= match "")
	      (setq match "\n"))
	    (while (and (not (eobp))
			(funcall search-func match nil t))
	      (goto-char (match-beginning 0))
	      (end-of-line)
	      (setq found (setq arts (get-text-property (point) 'articles)))
	      ;; Found a match, update scores.
	      (if trace
		  (while (setq art (pop arts))
		    (setcdr art (+ score (cdr art)))
		    (push (cons (car-safe (rassq alist gnus-score-cache)) kill)
			  gnus-score-trace))
		(while (setq art (pop arts))
		  (setcdr art (+ score (cdr art)))))
	      (forward-line 1))
	    ;; Update expiry date
	    (if trace
		(setq entries (cdr entries))
	      (cond
	       ;; Permanent entry.
	       ((null date)
		(setq entries (cdr entries)))
	       ;; We have a match, so we update the date.
	       ((and found gnus-update-score-entry-dates)
		(gnus-score-set 'touched '(t) alist)
		(setcar (nthcdr 2 kill) now)
		(setq entries (cdr entries)))
	       ;; This entry has expired, so we remove it.
	       ((and expire (< date expire))
		(gnus-score-set 'touched '(t) alist)
		(setcdr entries (cddr entries)))
	       ;; No match; go to next entry.
	       (t
		(setq entries (cdr entries))))))))))

    ;; Find fuzzy matches.
    (when fuzzies
      ;; Simplify the entire buffer for easy matching.
      (gnus-simplify-buffer-fuzzy gnus-simplify-subject-fuzzy-regexp)
      (while (setq kill (cadaar fuzzies))
	(let* ((match (nth 0 kill))
	       (type (nth 3 kill))
	       (score (or (nth 1 kill) gnus-score-interactive-default-score))
	       (date (nth 2 kill))
	       (mt (aref (symbol-name type) 0))
	       (case-fold-search (not (= mt ?F)))
	       found)
	  (goto-char (point-min))
	  (while (and (not (eobp))
		      (search-forward match nil t))
            (when (and (= (line-beginning-position) (match-beginning 0))
		       (eolp))
	      (setq found (setq arts (get-text-property (point) 'articles)))
	      (if trace
		  (while (setq art (pop arts))
		    (setcdr art (+ score (cdr art)))
		    (push (cons
			   (car-safe (rassq (cdar fuzzies) gnus-score-cache))
			   kill)
			  gnus-score-trace))
		;; Found a match, update scores.
		(while (setq art (pop arts))
		  (setcdr art (+ score (cdr art))))))
	    (forward-line 1))
	  ;; Update expiry date
	  (if (not trace)
	      (cond
	       ;; Permanent.
	       ((null date)
		;; Do nothing.
		)
	       ;; Match, update date.
	       ((and found gnus-update-score-entry-dates)
		(gnus-score-set 'touched '(t) (cdar fuzzies))
		(setcar (nthcdr 2 kill) now))
	       ;; Old entry, remove.
	       ((and expire (< date expire))
		(gnus-score-set 'touched '(t) (cdar fuzzies))
		(setcdr (caar fuzzies) (cddaar fuzzies)))))
	  (setq fuzzies (cdr fuzzies)))))

    (when words
      ;; Enter all words into the hashtb.
      (let ((hashtb (gnus-make-hashtable
		     (* 10 (count-lines (point-min) (point-max))))))
	(gnus-enter-score-words-into-hashtb hashtb)
	(while (setq kill (cadaar words))
	  (let* ((score (or (nth 1 kill) gnus-score-interactive-default-score))
		 (date (nth 2 kill))
		 found)
	    (when (setq arts (gethash (nth 0 kill) hashtb))
	      (setq found t)
	      (if trace
		  (while (setq art (pop arts))
		    (setcdr art (+ score (cdr art)))
		    (push (cons
			   (car-safe (rassq (cdar words) gnus-score-cache))
			   kill)
			  gnus-score-trace))
		;; Found a match, update scores.
		(while (setq art (pop arts))
		  (setcdr art (+ score (cdr art))))))
	    ;; Update expiry date
	    (if (not trace)
		(cond
		 ;; Permanent.
		 ((null date)
		  ;; Do nothing.
		  )
		 ;; Match, update date.
		 ((and found gnus-update-score-entry-dates)
		  (gnus-score-set 'touched '(t) (cdar words))
		  (setcar (nthcdr 2 kill) now))
		 ;; Old entry, remove.
		 ((and expire (< date expire))
		  (gnus-score-set 'touched '(t) (cdar words))
		  (setcdr (caar words) (cddaar words)))))
	    (setq words (cdr words))))))
    nil))