rs-gnus-summary.el

   1 ;; rs-gnus-summary.el -- Auxiliary summary mode commands for Gnus
   2 ;; $Id: rs-gnus-summary.el,v 1.27 2006/05/18 17:22:07 ste Exp $
   3
   4 ;; Author: Reiner Steib <Reiner.Steib@gmx.de>
   5 ;; Keywords: news
   6 ;; X-URL: http://theotp1.physik.uni-ulm.de/~ste/comp/emacs/gnus/rs-gnus-summary.el
   7
   8 ;;; This program is free software; you can redistribute it and/or modify
   9 ;;; it under the terms of the GNU General Public License as published by
  10 ;;; the Free Software Foundation; either version 2 of the License, or
  11 ;;; (at your option) any later version.
  12 ;;;
  13 ;;; This program is distributed in the hope that it will be useful,
  14 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;;; GNU General Public License for more details.
  17 ;;;
  18 ;;; You should have received a copy of the GNU General Public License
  19 ;;; along with this program; if not, write to the Free Software
  20 ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  21
  22 ;;; Commentary:
  23
  24 ;; Some additional summary mode commands for Gnus
  25
  26 ;;; Installation:
  27
  28 ;; Put this file in a directory that's in your `load-path',
  29 ;; e.g. ~/lisp:
  30 ;;   (add-to-list 'load-path "~/lisp")
  31 ;; and load it with
  32 ;;   (require 'rs-gnus-summary)
  33
  34 ;; Usage:
  35
  36 ;; Setup all:
  37 ;; (rs-gnus-summary-line-initialize)
  38
  39 ;; Usage for the format functions:
  40
  41 ;; ;; Alias for the content-type function:
  42 ;; (defalias 'gnus-user-format-function-ct 'rs-gnus-summary-line-content-type)
  43 ;; ;; Alias for the size function:
  44 ;; (defalias 'gnus-user-format-function-size 'rs-gnus-summary-line-message-size)
  45 ;; Usage for the summary tree functions:
  46
  47 ;; (rs-gnus-summary-tree-arrows-rs)
  48
  49 ;; Usage for the balloon face:
  50
  51 ;; (setq gnus-balloon-face-0 'rs-gnus-balloon-0)
  52 ;; (setq gnus-balloon-face-1 'rs-gnus-balloon-1)
  53
  54 ;;; Code:
  55
  56 ;; FIXME: i have to copy mail-header-extra here?
  57 ;; (require 'nnheader)
  58
  59 ;; (defmacro mail-header-extra (header)
  60 ;;   "Return the extra headers in HEADER."
  61 ;;   `(aref ,header 9))
  62
  63 ;;;###autoload
  64 (defun rs-gnus-summary-tree-arrows-ascii-default ()
  65   "Use default tree layout with ascii arrows."
  66   ;; See `gnus-sum.el'.  Useful for restoring defaults.
  67   (interactive)
  68   (setq
  69    ;; Defaults from `gnus-sum.el'
  70    gnus-sum-thread-tree-false-root      "> "
  71    gnus-sum-thread-tree-single-indent   ""
  72    gnus-sum-thread-tree-root            "> "
  73    gnus-sum-thread-tree-vertical        "| "
  74    gnus-sum-thread-tree-leaf-with-other "+-> "
  75    gnus-sum-thread-tree-single-leaf "  \\-> "
  76    gnus-sum-thread-tree-indent          "  ")
  77   (gnus-message 5 "Using default ascii tree layout."))
  78
  79 ;;;###autoload
  80 (defun rs-gnus-summary-tree-arrows-ascii ()
  81   "Use tree layout with ascii arrows."
  82   ;; Slighlty modified from default values.
  83   (interactive)
  84   (setq
  85    gnus-sum-thread-tree-false-root      "+ "
  86    gnus-sum-thread-tree-single-indent   ""
  87    gnus-sum-thread-tree-root            "> "
  88    gnus-sum-thread-tree-vertical        "| "
  89    gnus-sum-thread-tree-leaf-with-other "+-> "
  90    gnus-sum-thread-tree-single-leaf    "\\-> " ;; "\\" is _one_ char
  91    gnus-sum-thread-tree-indent          "  ")
  92   (gnus-message 5 "Using ascii tree layout."))
  93
  94 ;;;###autoload
  95 (defun rs-gnus-summary-tree-arrows-latin ()
  96   "Use default tree layout with ascii arrows (RS)."
  97   (interactive)
  98   (setq ;; ×
  99    gnus-sum-thread-tree-false-root      "÷» "
 100    gnus-sum-thread-tree-single-indent   "== "
 101    gnus-sum-thread-tree-root            "×» "
 102    gnus-sum-thread-tree-vertical        "|"
 103    gnus-sum-thread-tree-leaf-with-other "+-> "
 104    gnus-sum-thread-tree-single-leaf    "\\-> " ;; "\\" is _one_ char
 105    gnus-sum-thread-tree-indent          " ")
 106   (gnus-message 5 "Using tree layout with latin chars."))
 107
 108 ;;;###autoload
 109 (defalias 'rs-gnus-summary-tree-arrows 'rs-gnus-summary-tree-arrows-wide)
 110
 111 ;;;###autoload
 112 (defun rs-gnus-summary-tree-arrows-wide ()
 113   "Use tree layout with wide unicode arrows."
 114   (interactive)
 115   (setq
 116    gnus-sum-thread-tree-false-root      "┈┬──▷ "
 117    gnus-sum-thread-tree-single-indent   " ●  "
 118    gnus-sum-thread-tree-root            "┌─▶ "
 119    gnus-sum-thread-tree-vertical        "│"
 120    gnus-sum-thread-tree-leaf-with-other "├┬─► "
 121    gnus-sum-thread-tree-single-leaf     "╰┬─► "
 122    gnus-sum-thread-tree-indent          " ")
 123   (gnus-message 5 "Using tree layout with wide unicode arrows."))
 124
 125 ;;;###autoload
 126 (defun rs-gnus-summary-tree-arrows-test ()
 127   "Use tree layout with unicode arrows."
 128   (interactive)
 129   (setq
 130    gnus-sum-thread-tree-false-root      " ╤═▷ "
 131    gnus-sum-thread-tree-single-indent   "●  " ;; " ▷ "
 132    gnus-sum-thread-tree-root            "┌▶ "
 133    gnus-sum-thread-tree-vertical        "│"
 134    gnus-sum-thread-tree-leaf-with-other "├┬► "
 135    gnus-sum-thread-tree-single-leaf     "╰─► "
 136    gnus-sum-thread-tree-indent          " ")
 137   (gnus-message 5 "Using tree layout with unicode arrows."))
 138
 139 ;;;###autoload
 140 (defun rs-gnus-summary-tree-arrows-01 ()
 141   "Use tree layout with unicode arrows."
 142   ;; Suggested by Reiner Steib
 143   ;;  <v91xsxfbht.fsf@marauder.physik.uni-ulm.de>
 144   (interactive)
 145   (setq
 146    gnus-sum-thread-tree-false-root      "┌▷ "
 147    gnus-sum-thread-tree-single-indent   " ▷ "
 148    gnus-sum-thread-tree-root            "┌┬▶ "
 149    gnus-sum-thread-tree-vertical        "│"
 150    gnus-sum-thread-tree-leaf-with-other "├┬► "
 151    gnus-sum-thread-tree-single-leaf     "╰┬► "
 152    gnus-sum-thread-tree-indent          " ")
 153   (gnus-message 5 "Using tree layout with arrows."))
 154
 155 ;;;###autoload
 156 (defun rs-gnus-summary-tree-lines-rs ()
 157   "Use tree layout with unicode lines."
 158   ;; Suggested by Reiner Steib
 159   (interactive)
 160   (setq
 161    ;; gnus-summary-line-format "%«%U%R%z%u&ct; %4k: %B%»%(%-20,20f%) %s\n"
 162    ;; gnus-sum-thread-tree-false-root      "  "
 163    gnus-sum-thread-tree-single-indent   " "
 164    gnus-sum-thread-tree-root            "┌"
 165    gnus-sum-thread-tree-vertical        "│"
 166    gnus-sum-thread-tree-leaf-with-other "├╮ "
 167    gnus-sum-thread-tree-single-leaf     "╰─╮")
 168   (gnus-message 5 "Using tree layout with unicode arrows."))
 169
 170 ;;;###autoload
 171 (defun rs-gnus-summary-tree-arrows-mt ()
 172   "Use tree layout with unicode arrows."
 173   ;; Suggested by Mark Trettin in
 174   ;; <news:dcsg.m3isqr7ppc.fsf@beldin.mt743742.dialup.rwth-aachen.de>
 175    ;; gnus-summary-line-format "%U%R%z %B%-23,23n %s\n"
 176   (interactive)
 177   (setq
 178    gnus-sum-thread-tree-false-root      "  "
 179    gnus-sum-thread-tree-single-indent   " ▷"
 180    gnus-sum-thread-tree-root            "┌▶"
 181    gnus-sum-thread-tree-vertical        "│"
 182    gnus-sum-thread-tree-leaf-with-other "├┬►"
 183    gnus-sum-thread-tree-single-leaf     "╰─►"
 184    gnus-sum-thread-tree-indent          "  ")
 185   (gnus-message 5 "Using tree layout with unicode arrows."))
 186
 187 ;;;###autoload
 188 (defun rs-gnus-summary-tree-lines ()
 189   "Use tree layout with unicode lines."
 190   ;; Suggested by Jesper Harder in <news:m3ptvieklv.fsf@defun.localdomain>"
 191   (interactive)
 192   (setq
 193    ;; gnus-sum-thread-tree-false-root      "> "
 194    gnus-sum-thread-tree-single-indent   ""
 195    gnus-sum-thread-tree-root            ""
 196    gnus-sum-thread-tree-vertical        "│"
 197    gnus-sum-thread-tree-leaf-with-other "├╮ "
 198    gnus-sum-thread-tree-single-leaf     "╰─╮ ")
 199   (gnus-message 5 "Using tree layout with unicode lines."))
 200
 201 ;;;###autoload
 202 (defcustom rs-gnus-summary-line-content-type-alist
 203   '(("^text/plain"             " ")
 204     ("^text/html"              "h")
 205     ("^multipart/mixed"        "m")
 206     ("^multipart/alternative"  "a")
 207     ("^multipart/related"      "r")
 208     ("^multipart/signed"       "s")
 209     ("^multipart/encrypted"    "e")
 210     ("^multipart/report"       "t"))
 211   "Alist of regular expressions and summary line indicators."
 212   :group 'gnus-summary-format
 213   :type '(repeat (list (regexp :tag "Regexp")
 214                        (string :tag "Indicator"))))
 215
 216 ;;;###autoload
 217 (defun rs-gnus-summary-line-content-type (header)
 218   "Display content type of message in summary line.
 219
 220 This function is intended to be used in `gnus-summary-line-format-alist', with
 221 \(defalias 'gnus-user-format-function-X 'rs-gnus-summary-line-content-type).
 222 See (info \"(gnus)Group Line Specification\").
 223
 224 You need to add `Content-Type' to `nnmail-extra-headers' and
 225 `gnus-extra-headers', see Info node `(gnus)To From Newsgroups'."
 226   (let ((case-fold-search t)
 227         (ctype (or (cdr (assq 'Content-Type (mail-header-extra header)))
 228                    "text/plain"))
 229         indicator)
 230     (mapc (lambda (el)
 231             (when (string-match (car el) ctype)
 232               (setq indicator (cadr el))))
 233           rs-gnus-summary-line-content-type-alist)
 234     (if indicator
 235         indicator
 236       "o")))
 237
 238 ;;;###autoload
 239 (defun rs-gnus-summary-line-message-size (head)
 240   "Return pretty-printed version of message size.
 241
 242 Like `gnus-summary-line-message-size' but more verbose.  This function is
 243 intended to be used in `gnus-summary-line-format-alist', with
 244 \(defalias 'gnus-user-format-function-X 'rs-gnus-summary-line-message-size).
 245
 246 See (info \"(gnus)Group Line Specification\")."
 247   (let ((c (or (mail-header-chars head) -1)))
 248     (gnus-message 9 "c=%s chars in article %s" c (mail-header-number head))
 249     (cond ((< c 0) "n/a") ;; chars not available
 250           ((< c (* 1000))       (format "%db"  c))
 251           ((< c (* 1000 10))    (format "%1.1fk" (/ c 1024.0)))
 252           ((< c (* 1000 1000))  (format "%dk" (/ c 1024.0)))
 253           ((< c (* 1000 10000)) (format "%1.1fM" (/ c (* 1024.0 1024))))
 254           (t (format "%dM" (/ c (* 1024.0 1024)))))))
 255
 256 ;;;###autoload
 257 (defun rs-gnus-summary-line-score (head)
 258   "Return pretty-printed version of article score.
 259
 260 See (info \"(gnus)Group Line Specification\")."
 261   (let ((c (gnus-summary-article-score (mail-header-number head))))
 262     ;; (gnus-message 9 "c=%s chars in article %s" c (mail-header-number head))
 263     (cond ((< c -1000)     "vv")
 264           ((< c  -100)     " v")
 265           ((< c   -10)     "--")
 266           ((< c     0)     " -")
 267           ((= c     0)     "  ")
 268           ((< c    10)     " +")
 269           ((< c   100)     "++")
 270           ((< c  1000)     " ^")
 271           (t               "^^"))))
 272
 273 (defcustom rs-gnus-summary-line-label-alist
 274   '(("Important" "Im")
 275     ("Work" "Wo")
 276     ("Personal" "Pe")
 277     ("To do" "TD")
 278     ("Later" "La")
 279     ("Need reply" "NR"))
 280   "Alist of regular expressions and summary line indicators."
 281   :group 'gnus-summary-format
 282   :type '(repeat (list (regexp :tag "Regexp")
 283                        (string :tag "Indicator"))))
 284
 285 ;; http://www.fas.harvard.edu/computing/kb/kb1059.html
 286 ;; http://ilias.ca/blog/2005/09/gmail-labels-in-thunderbird.html
 287 ;; http://thread.gmane.org/m2n05mr2iv.fsf%40catbert.dok.org
 288
 289 ;;;###autoload
 290 (defun rs-gnus-summary-line-label (header)
 291   "Display label of message in summary line.
 292
 293 This function is intended to be used in `gnus-summary-line-format-alist', with
 294 \(defalias 'gnus-user-format-function-X 'rs-gnus-summary-line-label).
 295 See (info \"(gnus)Group Line Specification\").
 296
 297 You need to add `X-Gnus-Label' to `nnmail-extra-headers' and
 298 `gnus-extra-headers', see Info node `(gnus)To From Newsgroups'."
 299   (let ((case-fold-search t)
 300         (label (or (cdr (assq 'X-Gnus-Label (mail-header-extra header)))
 301                    ""))
 302         indicator)
 303     (mapc (lambda (el)
 304             (when (string-match (car el) label)
 305               (setq indicator (cadr el))))
 306           rs-gnus-summary-line-label-alist)
 307     (if indicator
 308         indicator
 309       label)))
 310
 311 ;;;###autoload
 312 (defun rs-gnus-summary-limit-to-label (regexp &optional not-matching)
 313   "Limit the summary buffer to articles that match a label."
 314   (interactive
 315    (list (read-string
 316           (format "%s label (regexp): "
 317                   (if current-prefix-arg "Exclude" "Limit to")))
 318          current-prefix-arg))
 319   (gnus-summary-limit-to-extra 'X-Gnus-Label regexp not-matching))
 320
 321 ;;;###autoload
 322 (defun rs-gnus-summary-line-list-subject (head)
 323   "Return modified subject for mailing lists.
 324
 325 This function is intended to be used in `gnus-summary-line-format-alist', with
 326 \(defalias 'gnus-user-format-function-X 'rs-gnus-summary-line-list-subject).
 327
 328 See (info \"(gnus)Group Line Specification\")."
 329   (let ((subj (or (mail-header-subject head) ""))
 330         type title id)
 331     (when (string-match
 332            (concat ".* SUSE Security \\(Announcement\\|Summary Report\\)"
 333                    "[ :]*"
 334                    "\\(.*\\) ?(\\(SUSE-[-:SASR0-9:]*\\))")
 335            subj)
 336       (setq type (match-string 1 subj)
 337             title (match-string 2 subj)
 338             id (match-string 3 subj)))
 339     (if (and id type title)
 340         (format "[%s] %s" id (if (>= (length title) 1)
 341                                  title
 342                                (format "*%s*" type)))
 343       subj)))
 344
 345
 346 (defalias 'gnus-user-format-function-list-subject
 347   'rs-gnus-summary-line-list-subject)
 348
 349 ;; An example for noffle:
 350 ;; (defun gnus-user-format-function-noffle (header)
 351 ;;   "Display noffle status in summary line.
 352 ;; You need to add `X-NOFFLE-Status' to `nnmail-extra-headers' and
 353 ;; `gnus-extra-headers', see Info node `(gnus)To From Newsgroups'."
 354 ;;   (let ((case-fold-search t)
 355 ;;      (val (or (cdr (assq 'X-NOFFLE-Status (mail-header-extra header)))
 356 ;;               "unknown")))
 357 ;;     (gnus-replace-in-string val "^\\(\\w\\).*$" "\\1")))
 358
 359 ;;;###autoload
 360 (defun rs-gnus-balloon-0 (window object position)
 361   "Show some informations about the current article.
 362 Informations include size, score, content type and number.
 363 Used as help echo for the summary buffer."
 364   ;; (gnus-message 10 "rs-gnus-balloon-0")
 365   (with-current-buffer object
 366     (let* ((article (get-text-property position 'gnus-number))
 367            (head (gnus-data-header (gnus-data-find article)))
 368            (chars (mail-header-chars head))
 369            (size (if (fboundp 'rs-gnus-summary-line-message-size)
 370                      (rs-gnus-summary-line-message-size head)
 371                    (gnus-summary-line-message-size head)))
 372            (score (gnus-summary-article-score article))
 373            (ct (gnus-replace-in-string
 374                 (or (cdr (assq 'Content-Type (mail-header-extra head)))
 375                     "n/a")
 376                 "[; ].*$" ""))
 377            (no (mail-header-number head)))
 378       (format "%-10s%s\n%-10s%s\n%-10s%s\n%-10s%s\n%-10s%s\n"
 379               "Size:" size
 380               "Chars:" chars
 381               "Score:" score
 382               "C-Type:" ct
 383               "Number:" no))))
 384
 385 ;;;###autoload
 386 (defun rs-gnus-balloon-1 (window object position)
 387   "Show full \"From\", \"Subject\", \"To\", and \"Date\" of the current article.
 388 Used as help echo for the summary buffer."
 389   ;; (gnus-message 10 "rs-gnus-balloon-1")
 390   (with-current-buffer object
 391     (let* ((article (get-text-property position 'gnus-number))
 392            (head (gnus-data-header (gnus-data-find article)))
 393            (from (mail-header-from head))
 394            (subject (mail-header-subject head))
 395            (to (cdr (or (assq 'To (mail-header-extra head)))))
 396            (ng (cdr (or (assq 'Newsgroups (mail-header-extra head)))))
 397            (date (mail-header-date head)))
 398       (format "%-11s%s\n%-11s%s\n%-11s%s\n%-11s%s\n"
 399               "From:" from
 400               "Subject:" subject
 401               "Date:" date
 402               (cond (to "To:")
 403                     (ng "Newsgroup:")
 404                     (t "To/Ngrp:"))
 405               (or to ng "n/a")))))
 406
 407 ;;;###autoload
 408 (defun rs-gnus-summary-line-initialize ()
 409   "Setup my summary line."
 410   (interactive)
 411   ;; Alias for the content-type function:
 412   (defalias 'gnus-user-format-function-ct 'rs-gnus-summary-line-content-type)
 413   ;; Alias for the size function:
 414   (defalias 'gnus-user-format-function-size 'rs-gnus-summary-line-message-size)
 415   ;; Alias for the score function:
 416   (defalias 'gnus-user-format-function-score 'rs-gnus-summary-line-score)
 417   ;;
 418   (defalias 'gnus-user-format-function-label 'rs-gnus-summary-line-label)
 419   ;;
 420   ;; Use them:
 421   (setq gnus-balloon-face-0 'rs-gnus-balloon-0)
 422   (setq gnus-balloon-face-1 'rs-gnus-balloon-1)
 423   ;; Unbold face for UTF arrows: (FIXME: Doesn't work on marauder.)
 424   (copy-face 'default 'rs-gnus-face-1)
 425   (setq gnus-face-1 'rs-gnus-face-1)
 426   ;; (set-face-italic-p 'rs-gnus-face-1 nil)
 427   ;; (dolist (el '(gnus-summary-low-ancient-face
 428   ;;            gnus-summary-low-read-face
 429   ;;            gnus-summary-low-ticked-face
 430   ;;            gnus-summary-low-undownloaded-face
 431   ;;            gnus-summary-low-unread-face))
 432   ;;   (message "%s" el)
 433   ;;   (set-face-italic-p el nil)
 434   ;;   (set-face-bold-p el nil)
 435   ;;   (sit-for 1))
 436   (if (or (not window-system)
 437           (string-match "marauder\\|siogo" system-name))
 438       (rs-gnus-summary-tree-arrows-latin)
 439     (rs-gnus-summary-tree-arrows))
 440   ;; Set line format:
 441   (setq gnus-summary-line-format
 442         "%«%U%R%u&score;%u&ct; %4u&size;%» %1«%1{%B%}%* %(%-20,20f%) %s%»\n"))
 443
 444 (defcustom rs-gnus-expirable-authors nil
 445   "List of authors that are used in `rs-gnus-summary-mark-lists-expirable'."
 446   :group 'gnus-summary
 447   :type '(repeat (string :tag "Author")))
 448
 449 (defcustom rs-gnus-expirable-subjects nil
 450   "List of subjects that are used in `rs-gnus-summary-mark-lists-expirable'."
 451   :group 'gnus-summary
 452   :type '(repeat (string :tag "Subject")))
 453
 454 ;;;###autoload
 455 (defun rs-gnus-summary-mark-lists-expirable ()
 456   "Mark some articles (lists, ...) as expirable."
 457   (interactive)
 458   (let ((gnus-summary-generate-hook nil)
 459         (subj (regexp-opt rs-gnus-expirable-subjects t))
 460         (from (regexp-opt rs-gnus-expirable-authors t)))
 461     (gnus-uu-mark-by-regexp subj)
 462     (autoload 'ignore-errors "cl")
 463     (when (ignore-errors
 464             (progn
 465               (gnus-summary-limit-to-author from)
 466               t))
 467       (gnus-uu-mark-buffer)
 468       (gnus-summary-pop-limit t))
 469     (let ((articles (gnus-summary-work-articles nil))
 470           article)
 471       (save-excursion
 472         (while articles
 473           (gnus-summary-goto-subject (setq article (pop articles)))
 474           (let (gnus-newsgroup-processable)
 475             (gnus-summary-mark-as-expirable 1))
 476           (gnus-summary-remove-process-mark article)))))
 477   (when (y-or-n-p "Expire articles now? ")
 478     (gnus-summary-expire-articles 'now)))
 479
 480 ;;;###autoload
 481 (defun rs-gnus-summary-more-headers ()
 482   "Force redisplaying of the current article with ..."
 483   (interactive)
 484   (let ((gnus-visible-headers
 485          (concat gnus-visible-headers "\\|^X-\\|^NNTP")))
 486     (gnus-summary-show-article)))
 487
 488 ;;;###autoload
 489 (defun rs-gnus-summary-non-boring-headers ()
 490   "Force redisplaying of the current article with ..."
 491   (interactive)
 492   (let ((gnus-visible-headers nil))
 493     (gnus-summary-show-article)))
 494
 495 ;;;###autoload
 496 (defun rs-gnus-summary-mark-as-expirable-and-next-line(n)
 497   "Mark N articles forward as expirable and go to next line.
 498 Useful in a summary buffer with read articles."
 499   (interactive "p")
 500   (gnus-summary-mark-as-expirable n)
 501   (next-line 1))
 502
 503 ;;;###autoload
 504 (defun rs-gnus-summary-mark-as-expirable-dont-move ()
 505   "Mark this article expirable.  Don't move point."
 506   (interactive)
 507   (gnus-summary-mark-article nil ?E nil))
 508
 509 ;;;###autoload
 510 (defun rs-gnus-summary-mark-as-expirable-next-article ()
 511   "Mark this article expirable.  Move to next article."
 512   (interactive)
 513   (gnus-summary-mark-article nil ?E nil)
 514   (gnus-summary-next-article))
 515
 516 ;; Suggested by David Mazieres in <news:6czn0zqcc5.fsf@orchard.scs.cs.nyu.edu>
 517 ;; in analogy to `rmail-summary-by-recipients'.  Unlike
 518 ;; `rmail-summary-by-recipients', doesn't include From.
 519
 520 ;;;###autoload
 521 (defun rs-gnus-summary-limit-to-recipient (recipient &optional not-matching)
 522   "Limit the summary buffer to articles with the given RECIPIENT.
 523
 524 If NOT-MATCHING, exclude RECIPIENT.
 525
 526 To and Cc headers are checked.  You need to include them in
 527 `nnmail-extra-headers'."
 528   ;; Unlike `rmail-summary-by-recipients', doesn't include From.
 529   (interactive
 530    (list (read-string (format "%s recipient (regexp): "
 531                               (if current-prefix-arg "Exclude" "Limit to")))
 532          current-prefix-arg))
 533   (when (not (equal "" recipient))
 534     (prog1 (let* ((to
 535                    (if (memq 'To nnmail-extra-headers)
 536                        (gnus-summary-find-matching
 537                         (cons 'extra 'To) recipient 'all nil nil
 538                         not-matching)
 539                      (gnus-message
 540                       1 "`To' isn't present in `nnmail-extra-headers'")
 541                      (sit-for 1)
 542                      nil))
 543                   (cc
 544                    (if (memq 'Cc nnmail-extra-headers)
 545                        (gnus-summary-find-matching
 546                         (cons 'extra 'Cc) recipient 'all nil nil
 547                         not-matching)
 548                      (gnus-message
 549                       1 "`Cc' isn't present in `nnmail-extra-headers'")
 550                      (sit-for 1)
 551                      nil))
 552                   (articles
 553                    (if not-matching
 554                        ;; We need the numbers that are in both lists:
 555                        (mapcar (lambda (a)
 556                                  (and (memq a to) a))
 557                                cc)
 558                      (nconc to cc))))
 559              (unless articles
 560                (error "Found no matches for \"%s\"" recipient))
 561              (gnus-summary-limit articles))
 562       (gnus-summary-position-point))))
 563
 564 ;;;###autoload
 565 (defun rs-gnus-summary-sort-by-recipient (&optional reverse)
 566   "Sort the summary buffer by recipient name alphabetically.
 567 If `case-fold-search' is non-nil, case of letters is ignored.
 568 Argument REVERSE means reverse order."
 569   (interactive "P")
 570   (gnus-summary-sort 'recipient reverse))
 571
 572 (defsubst rs-gnus-article-sort-by-recipient (h1 h2)
 573   "Sort articles by recipient."
 574   (string-lessp
 575    (let ((extract (funcall
 576                    gnus-extract-address-components
 577                    (or (cdr (assq 'To (mail-header-extra h1))) ""))))
 578      (or (car extract) (cadr extract)))
 579    (let ((extract (funcall
 580                    gnus-extract-address-components
 581                    (or (cdr (assq 'To (mail-header-extra h2))) ""))))
 582      (or (car extract) (cadr extract)))))
 583
 584 (defun rs-gnus-thread-sort-by-recipient (h1 h2)
 585   "Sort threads by root recipient."
 586   (gnus-article-sort-by-recipient
 587    (gnus-thread-header h1)
 588    (gnus-thread-header h2)))
 589
 590 ;; Not using my own namespace prefix because `gnus-summary-sort' wants
 591 ;; gnus-thread-sort-by-%s" and "gnus-article-sort-by-%s":
 592 (require 'gnus-sum)
 593 (unless (fboundp 'gnus-article-sort-by-recipient)
 594   (defalias 'gnus-article-sort-by-recipient
 595     'rs-gnus-article-sort-by-recipient))
 596 (unless (fboundp 'gnus-thread-sort-by-recipient)
 597   (defalias 'gnus-thread-sort-by-recipient
 598     'rs-gnus-thread-sort-by-recipient))
 599
 600 ;;;###autoload
 601 (defun rs-gnus-summary-score-statistics (&optional ancient quiet)
 602   "Display score statistics for current summary buffer.
 603
 604 If ANCIENT, also count ancient articles.  Returns a list: (high
 605 default low)."
 606   (interactive)
 607   (let ((high 0) (dflt 0) (low 0))
 608     (dolist (i gnus-newsgroup-scored)
 609       (cond
 610        ;; Ignore ancient articles
 611        ;; ((memq (car i) gnus-newsgroup-ancient) 'ancient)
 612        ;; ((not (memq (car i) gnus-newsgroup-unreads)) 'not-unread)
 613        ((and (not ancient)
 614              (not (memq (car i) gnus-newsgroup-articles)))
 615         'not-art)
 616        ;;
 617        ((< (cdr i) gnus-summary-default-score) (setq low  (1+ low)))
 618        ((> (cdr i) gnus-summary-default-score) (setq high (1+ high)))))
 619     (setq dflt (- (+ (length gnus-newsgroup-articles)
 620                      (if ancient
 621                          (length gnus-newsgroup-ancient)
 622                        0))
 623                   low high))
 624     (unless quiet
 625       (gnus-message 1 "Score statistics: %s high, %s default, %s low."
 626                     high dflt low))
 627     (list high dflt low)))
 628 ;; (add-hook 'gnus-summary-prepared-hook 'rs-gnus-summary-score-statistics)
 629
 630 (defcustom rs-gnus-leafnode-filter-file "/usr/local/etc/leafnode/filters"
 631   "Filter file for leafnode."
 632   ;; May be a tramp file name ("/su:/etc/leafnode/filters") if file is not
 633   ;; writable for the user.
 634   :group 'gnus-summary
 635   :type '(choice (const "/usr/local/etc/leafnode/filters")
 636                  (const "/su:/usr/local/etc/leafnode/filters")
 637                  (const "/su:/etc/leafnode/filters")
 638                  (const "/root@localhost:/etc/leafnode/filters")
 639                  file))
 640
 641 ;;;###autoload
 642 (defun rs-gnus-leafnode-kill-thread ()
 643   "Kill thread from here using leafnode."
 644   (interactive)
 645   (let ((mid (gnus-with-article-buffer (gnus-fetch-field "Message-Id")))
 646         (file rs-gnus-leafnode-filter-file)
 647         rule)
 648     (gnus-message 9 "Writing kill rule for MID `%s' to file `%s'" mid file)
 649     (with-temp-buffer
 650       (insert "\nnewsgroups = "
 651               (regexp-quote gnus-newsgroup-name)
 652               "\npattern = ^References:.*"
 653               (regexp-quote mid)
 654               "\naction = kill\n")
 655        (append-to-file (point-min) (point-max) file))))
 656 ;; (define-key gnus-summary-mode-map (kbd "C-c k") 'rs-gnus-leafnode-kill-thread)
 657
 658 ;; /var/spool/news$ find `ls -d|grep -v '\.'` -name '.overview' |xargs grep 'Postal Lottery:'|awk -F'   ' '{print $5}'|xargs -n 1 /usr/local/sbin/applyfilter -n -C
 659
 660 ;; FIXME: Only half finished!
 661 (defun rs-gnus-summary-applyfilter (subject &optional spoolbase overview)
 662   "Find articles with subject matching SUBJECT and delete them from the spool."
 663   (unless spoolbase
 664     (setq spoolbase "/var/spool/news/"))
 665   (unless overview
 666     (setq overview ".overview"))
 667   (dolist (ent gnus-newsrc-alist)
 668     (let ((full (car ent))
 669           (level (nth 1 ent))
 670           overfile)
 671       (unless (string-match "nn.*:" full)
 672         (setq overfile (concat spoolbase
 673                                (subst-char-in-string ?. ?/ full)
 674                                "/" overview))
 675         (message overfile)))))
 676
 677 ;;; provide ourself
 678
 679 (provide 'rs-gnus-summary)
 680
 681 ;;; rs-gnus-summary.el ends here
 682
 683 ;; Local Variables:
 684 ;; coding: utf-8
 685 ;; End: