Mercurial > emacs

comparison lisp/gnus/gnus-kill.el @ 88155:d7ddb3e565de

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
sync with trunk
author Henrik Enberg <henrik.enberg@telia.com>
date Mon, 16 Jan 2006 00:03:54 +0000
parents 56f0edca838c
children
comparison
equal deleted inserted replaced
88154:8ce476d3ba36 88155:d7ddb3e565de
1 ;;; gnus-kill.el --- kill commands for Gnus 1 ;;; gnus-kill.el --- kill commands for Gnus
2 ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000 2
3 ;; Free Software Foundation, Inc. 3 ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2003, 2004,
4 ;; 2005 Free Software Foundation, Inc.
4 5
5 ;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> 6 ;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
6 ;; Lars Magne Ingebrigtsen <larsi@gnus.org> 7 ;; Lars Magne Ingebrigtsen <larsi@gnus.org>
7 ;; Keywords: news 8 ;; Keywords: news
8 9
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;; GNU General Public License for more details. 20 ;; GNU General Public License for more details.
20 21
21 ;; You should have received a copy of the GNU General Public License 22 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs; see the file COPYING. If not, write to the 23 ;; along with GNU Emacs; see the file COPYING. If not, write to the
23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, 24 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
24 ;; Boston, MA 02111-1307, USA. 25 ;; Boston, MA 02110-1301, USA.
25 26
26 ;;; Commentary: 27 ;;; Commentary:
27 28
28 ;;; Code: 29 ;;; Code:
29 30
159 (use-local-map gnus-kill-file-mode-map) 160 (use-local-map gnus-kill-file-mode-map)
160 (set-syntax-table emacs-lisp-mode-syntax-table) 161 (set-syntax-table emacs-lisp-mode-syntax-table)
161 (setq major-mode 'gnus-kill-file-mode) 162 (setq major-mode 'gnus-kill-file-mode)
162 (setq mode-name "Kill") 163 (setq mode-name "Kill")
163 (lisp-mode-variables nil) 164 (lisp-mode-variables nil)
164 (gnus-run-hooks 'emacs-lisp-mode-hook 'gnus-kill-file-mode-hook)) 165 (gnus-run-mode-hooks 'emacs-lisp-mode-hook 'gnus-kill-file-mode-hook))
165 166
166 (defun gnus-kill-file-edit-file (newsgroup) 167 (defun gnus-kill-file-edit-file (newsgroup)
167 "Begin editing a kill file for NEWSGROUP. 168 "Begin editing a kill file for NEWSGROUP.
168 If NEWSGROUP is nil, the global kill file is selected." 169 If NEWSGROUP is nil, the global kill file is selected."
169 (interactive "sNewsgroup: ") 170 (interactive "sNewsgroup: ")
355 (gnus-summary-limit-to-marks marks 'reverse))) 356 (gnus-summary-limit-to-marks marks 'reverse)))
356 357
357 (defun gnus-apply-kill-file-unless-scored () 358 (defun gnus-apply-kill-file-unless-scored ()
358 "Apply .KILL file, unless a .SCORE file for the same newsgroup exists." 359 "Apply .KILL file, unless a .SCORE file for the same newsgroup exists."
359 (cond ((file-exists-p (gnus-score-file-name gnus-newsgroup-name)) 360 (cond ((file-exists-p (gnus-score-file-name gnus-newsgroup-name))
360 ;; Ignores global KILL. 361 ;; Ignores global KILL.
361 (when (file-exists-p (gnus-newsgroup-kill-file gnus-newsgroup-name)) 362 (when (file-exists-p (gnus-newsgroup-kill-file gnus-newsgroup-name))
362 (gnus-message 3 "Note: Ignoring %s.KILL; preferring .SCORE" 363 (gnus-message 3 "Note: Ignoring %s.KILL; preferring .SCORE"
363 gnus-newsgroup-name)) 364 gnus-newsgroup-name))
364 0) 365 0)
365 ((or (file-exists-p (gnus-newsgroup-kill-file nil)) 366 ((or (file-exists-p (gnus-newsgroup-kill-file nil))
366 (file-exists-p (gnus-newsgroup-kill-file gnus-newsgroup-name))) 367 (file-exists-p (gnus-newsgroup-kill-file gnus-newsgroup-name)))
367 (gnus-apply-kill-file-internal)) 368 (gnus-apply-kill-file-internal))
368 (t 369 (t
369 0))) 370 0)))
370 371
371 (defun gnus-apply-kill-file-internal () 372 (defun gnus-apply-kill-file-internal ()
372 "Apply a kill file to the current newsgroup. 373 "Apply a kill file to the current newsgroup.
373 Returns the number of articles marked as read." 374 Returns the number of articles marked as read."
374 (let* ((kill-files (list (gnus-newsgroup-kill-file nil) 375 (let* ((kill-files (list (gnus-newsgroup-kill-file nil)
396 gnus-newsgroup-killed) 397 gnus-newsgroup-killed)
397 (push (mail-header-number (car headers)) 398 (push (mail-header-number (car headers))
398 gnus-newsgroup-kill-headers)) 399 gnus-newsgroup-kill-headers))
399 (setq headers (cdr headers)))) 400 (setq headers (cdr headers))))
400 (setq files nil)) 401 (setq files nil))
401 (setq files (cdr files))))) 402 (setq files (cdr files)))))
402 (if (not gnus-newsgroup-kill-headers) 403 (if (not gnus-newsgroup-kill-headers)
403 () 404 ()
404 (save-window-excursion 405 (save-window-excursion
405 (save-excursion 406 (save-excursion
406 (while kill-files 407 (while kill-files
426 (gnus-message 6 "Marked %d articles as read" nunreads)) 427 (gnus-message 6 "Marked %d articles as read" nunreads))
427 nunreads) 428 nunreads)
428 0)))) 429 0))))
429 430
430 ;; Parse a Gnus killfile. 431 ;; Parse a Gnus killfile.
431 (defun gnus-score-insert-help (string alist idx)
432 (save-excursion
433 (pop-to-buffer "*Score Help*")
434 (buffer-disable-undo)
435 (erase-buffer)
436 (insert string ":\n\n")
437 (while alist
438 (insert (format " %c: %s\n" (caar alist) (nth idx (car alist))))
439 (setq alist (cdr alist)))))
440
441 (defun gnus-kill-parse-gnus-kill-file () 432 (defun gnus-kill-parse-gnus-kill-file ()
442 (goto-char (point-min)) 433 (goto-char (point-min))
443 (gnus-kill-file-mode) 434 (gnus-kill-file-mode)
444 (let (beg form) 435 (let (beg form)
445 (while (progn 436 (while (progn
586 (gnus-prin1-to-string (nth 3 object)))) 577 (gnus-prin1-to-string (nth 3 object))))
587 (when (nth 4 object) 578 (when (nth 4 object)
588 (insert "\n t")) 579 (insert "\n t"))
589 (insert ")") 580 (insert ")")
590 (prog1 581 (prog1
591 (buffer-substring (point-min) (point-max)) 582 (buffer-string)
592 (kill-buffer (current-buffer)))))) 583 (kill-buffer (current-buffer))))))
593 584
594 (defun gnus-execute-1 (function regexp form header) 585 (defun gnus-execute-1 (function regexp form header)
595 (save-excursion 586 (save-excursion
596 (let (did-kill) 587 (let (did-kill)
606 (unless (stringp value) 597 (unless (stringp value)
607 (setq value (gnus-prin1-to-string value))) 598 (setq value (gnus-prin1-to-string value)))
608 (setq did-kill (string-match regexp value))) 599 (setq did-kill (string-match regexp value)))
609 (cond ((stringp form) ;Keyboard macro. 600 (cond ((stringp form) ;Keyboard macro.
610 (execute-kbd-macro form)) 601 (execute-kbd-macro form))
611 ((gnus-functionp form) 602 ((functionp form)
612 (funcall form)) 603 (funcall form))
613 (t 604 (t
614 (eval form))))) 605 (eval form)))))
615 ;; Search article body. 606 ;; Search article body.
616 (let ((gnus-current-article nil) ;Save article pointer. 607 (let ((gnus-current-article nil) ;Save article pointer.
625 (set-buffer gnus-article-buffer) 616 (set-buffer gnus-article-buffer)
626 (goto-char (point-min)) 617 (goto-char (point-min))
627 (setq did-kill (re-search-forward regexp nil t))) 618 (setq did-kill (re-search-forward regexp nil t)))
628 (cond ((stringp form) ;Keyboard macro. 619 (cond ((stringp form) ;Keyboard macro.
629 (execute-kbd-macro form)) 620 (execute-kbd-macro form))
630 ((gnus-functionp form) 621 ((functionp form)
631 (funcall form)) 622 (funcall form))
632 (t 623 (t
633 (eval form))))))) 624 (eval form)))))))
634 did-kill))) 625 did-kill)))
635 626
639 If optional 1st argument BACKWARD is non-nil, do backward instead. 630 If optional 1st argument BACKWARD is non-nil, do backward instead.
640 If optional 2nd argument UNREAD is non-nil, articles which are 631 If optional 2nd argument UNREAD is non-nil, articles which are
641 marked as read or ticked are ignored." 632 marked as read or ticked are ignored."
642 (save-excursion 633 (save-excursion
643 (let ((killed-no 0) 634 (let ((killed-no 0)
644 function article header) 635 function article header extras)
645 (cond 636 (cond
646 ;; Search body. 637 ;; Search body.
647 ((or (null field) 638 ((or (null field)
648 (string-equal field "")) 639 (string-equal field ""))
649 (setq function nil)) 640 (setq function nil))
650 ;; Get access function of header field. 641 ;; Get access function of header field.
651 ((fboundp 642 ((cond ((fboundp
652 (setq function 643 (setq function
653 (intern-soft 644 (intern-soft
654 (concat "mail-header-" (downcase field))))) 645 (concat "mail-header-" (downcase field)))))
655 (setq function `(lambda (h) (,function h)))) 646 (setq function `(lambda (h) (,function h))))
647 ((when (setq extras
648 (member (downcase field)
649 (mapcar (lambda (header)
650 (downcase (symbol-name header)))
651 gnus-extra-headers)))
652 (setq function
653 `(lambda (h)
654 (gnus-extra-header
655 (quote ,(nth (- (length gnus-extra-headers)
656 (length extras))
657 gnus-extra-headers))
658 h)))))))
656 ;; Signal error. 659 ;; Signal error.
657 (t 660 (t
658 (error "Unknown header field: \"%s\"" field))) 661 (error "Unknown header field: \"%s\"" field)))
659 ;; Starting from the current article. 662 ;; Starting from the current article.
660 (while (or 663 (while (or
713 (switch-to-buffer gnus-group-buffer) 716 (switch-to-buffer gnus-group-buffer)
714 (gnus-group-save-newsrc))) 717 (gnus-group-save-newsrc)))
715 718
716 (provide 'gnus-kill) 719 (provide 'gnus-kill)
717 720
721 ;;; arch-tag: b30c0f53-df1a-490b-b81e-17b13474f395
718 ;;; gnus-kill.el ends here 722 ;;; gnus-kill.el ends here