Mercurial > emacs
comparison lisp/gnus/gnus-kill.el @ 82951:0fde48feb604
Import Gnus 5.10 from the v5_10 branch of the Gnus repository.
author | Andreas Schwab <schwab@suse.de> |
---|---|
date | Thu, 22 Jul 2004 16:45:51 +0000 |
parents | 695cf19ef79e |
children | 4b7fa3ee8e9e cce1c0ee76ee |
comparison
equal
deleted
inserted
replaced
56503:8bbd2323fbf2 | 82951:0fde48feb604 |
---|---|
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 ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2003 |
3 ;; Free Software Foundation, Inc. | 3 ;; Free Software Foundation, Inc. |
4 | 4 |
5 ;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> | 5 ;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> |
6 ;; Lars Magne Ingebrigtsen <larsi@gnus.org> | 6 ;; Lars Magne Ingebrigtsen <larsi@gnus.org> |
7 ;; Keywords: news | 7 ;; Keywords: news |
355 (gnus-summary-limit-to-marks marks 'reverse))) | 355 (gnus-summary-limit-to-marks marks 'reverse))) |
356 | 356 |
357 (defun gnus-apply-kill-file-unless-scored () | 357 (defun gnus-apply-kill-file-unless-scored () |
358 "Apply .KILL file, unless a .SCORE file for the same newsgroup exists." | 358 "Apply .KILL file, unless a .SCORE file for the same newsgroup exists." |
359 (cond ((file-exists-p (gnus-score-file-name gnus-newsgroup-name)) | 359 (cond ((file-exists-p (gnus-score-file-name gnus-newsgroup-name)) |
360 ;; Ignores global KILL. | 360 ;; Ignores global KILL. |
361 (when (file-exists-p (gnus-newsgroup-kill-file gnus-newsgroup-name)) | 361 (when (file-exists-p (gnus-newsgroup-kill-file gnus-newsgroup-name)) |
362 (gnus-message 3 "Note: Ignoring %s.KILL; preferring .SCORE" | 362 (gnus-message 3 "Note: Ignoring %s.KILL; preferring .SCORE" |
363 gnus-newsgroup-name)) | 363 gnus-newsgroup-name)) |
364 0) | 364 0) |
365 ((or (file-exists-p (gnus-newsgroup-kill-file nil)) | 365 ((or (file-exists-p (gnus-newsgroup-kill-file nil)) |
366 (file-exists-p (gnus-newsgroup-kill-file gnus-newsgroup-name))) | 366 (file-exists-p (gnus-newsgroup-kill-file gnus-newsgroup-name))) |
367 (gnus-apply-kill-file-internal)) | 367 (gnus-apply-kill-file-internal)) |
368 (t | 368 (t |
369 0))) | 369 0))) |
370 | 370 |
371 (defun gnus-apply-kill-file-internal () | 371 (defun gnus-apply-kill-file-internal () |
372 "Apply a kill file to the current newsgroup. | 372 "Apply a kill file to the current newsgroup. |
373 Returns the number of articles marked as read." | 373 Returns the number of articles marked as read." |
374 (let* ((kill-files (list (gnus-newsgroup-kill-file nil) | 374 (let* ((kill-files (list (gnus-newsgroup-kill-file nil) |
396 gnus-newsgroup-killed) | 396 gnus-newsgroup-killed) |
397 (push (mail-header-number (car headers)) | 397 (push (mail-header-number (car headers)) |
398 gnus-newsgroup-kill-headers)) | 398 gnus-newsgroup-kill-headers)) |
399 (setq headers (cdr headers)))) | 399 (setq headers (cdr headers)))) |
400 (setq files nil)) | 400 (setq files nil)) |
401 (setq files (cdr files))))) | 401 (setq files (cdr files))))) |
402 (if (not gnus-newsgroup-kill-headers) | 402 (if (not gnus-newsgroup-kill-headers) |
403 () | 403 () |
404 (save-window-excursion | 404 (save-window-excursion |
405 (save-excursion | 405 (save-excursion |
406 (while kill-files | 406 (while kill-files |
426 (gnus-message 6 "Marked %d articles as read" nunreads)) | 426 (gnus-message 6 "Marked %d articles as read" nunreads)) |
427 nunreads) | 427 nunreads) |
428 0)))) | 428 0)))) |
429 | 429 |
430 ;; Parse a Gnus killfile. | 430 ;; 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 () | 431 (defun gnus-kill-parse-gnus-kill-file () |
442 (goto-char (point-min)) | 432 (goto-char (point-min)) |
443 (gnus-kill-file-mode) | 433 (gnus-kill-file-mode) |
444 (let (beg form) | 434 (let (beg form) |
445 (while (progn | 435 (while (progn |
586 (gnus-prin1-to-string (nth 3 object)))) | 576 (gnus-prin1-to-string (nth 3 object)))) |
587 (when (nth 4 object) | 577 (when (nth 4 object) |
588 (insert "\n t")) | 578 (insert "\n t")) |
589 (insert ")") | 579 (insert ")") |
590 (prog1 | 580 (prog1 |
591 (buffer-substring (point-min) (point-max)) | 581 (buffer-string) |
592 (kill-buffer (current-buffer)))))) | 582 (kill-buffer (current-buffer)))))) |
593 | 583 |
594 (defun gnus-execute-1 (function regexp form header) | 584 (defun gnus-execute-1 (function regexp form header) |
595 (save-excursion | 585 (save-excursion |
596 (let (did-kill) | 586 (let (did-kill) |
606 (unless (stringp value) | 596 (unless (stringp value) |
607 (setq value (gnus-prin1-to-string value))) | 597 (setq value (gnus-prin1-to-string value))) |
608 (setq did-kill (string-match regexp value))) | 598 (setq did-kill (string-match regexp value))) |
609 (cond ((stringp form) ;Keyboard macro. | 599 (cond ((stringp form) ;Keyboard macro. |
610 (execute-kbd-macro form)) | 600 (execute-kbd-macro form)) |
611 ((gnus-functionp form) | 601 ((functionp form) |
612 (funcall form)) | 602 (funcall form)) |
613 (t | 603 (t |
614 (eval form))))) | 604 (eval form))))) |
615 ;; Search article body. | 605 ;; Search article body. |
616 (let ((gnus-current-article nil) ;Save article pointer. | 606 (let ((gnus-current-article nil) ;Save article pointer. |
625 (set-buffer gnus-article-buffer) | 615 (set-buffer gnus-article-buffer) |
626 (goto-char (point-min)) | 616 (goto-char (point-min)) |
627 (setq did-kill (re-search-forward regexp nil t))) | 617 (setq did-kill (re-search-forward regexp nil t))) |
628 (cond ((stringp form) ;Keyboard macro. | 618 (cond ((stringp form) ;Keyboard macro. |
629 (execute-kbd-macro form)) | 619 (execute-kbd-macro form)) |
630 ((gnus-functionp form) | 620 ((functionp form) |
631 (funcall form)) | 621 (funcall form)) |
632 (t | 622 (t |
633 (eval form))))))) | 623 (eval form))))))) |
634 did-kill))) | 624 did-kill))) |
635 | 625 |
639 If optional 1st argument BACKWARD is non-nil, do backward instead. | 629 If optional 1st argument BACKWARD is non-nil, do backward instead. |
640 If optional 2nd argument UNREAD is non-nil, articles which are | 630 If optional 2nd argument UNREAD is non-nil, articles which are |
641 marked as read or ticked are ignored." | 631 marked as read or ticked are ignored." |
642 (save-excursion | 632 (save-excursion |
643 (let ((killed-no 0) | 633 (let ((killed-no 0) |
644 function article header) | 634 function article header extras) |
645 (cond | 635 (cond |
646 ;; Search body. | 636 ;; Search body. |
647 ((or (null field) | 637 ((or (null field) |
648 (string-equal field "")) | 638 (string-equal field "")) |
649 (setq function nil)) | 639 (setq function nil)) |
650 ;; Get access function of header field. | 640 ;; Get access function of header field. |
651 ((fboundp | 641 ((cond ((fboundp |
652 (setq function | 642 (setq function |
653 (intern-soft | 643 (intern-soft |
654 (concat "mail-header-" (downcase field))))) | 644 (concat "mail-header-" (downcase field))))) |
655 (setq function `(lambda (h) (,function h)))) | 645 (setq function `(lambda (h) (,function h)))) |
646 ((when (setq extras | |
647 (member (downcase field) | |
648 (mapcar (lambda (header) | |
649 (downcase (symbol-name header))) | |
650 gnus-extra-headers))) | |
651 (setq function | |
652 `(lambda (h) | |
653 (gnus-extra-header | |
654 (quote ,(nth (- (length gnus-extra-headers) | |
655 (length extras)) | |
656 gnus-extra-headers)) | |
657 h))))))) | |
656 ;; Signal error. | 658 ;; Signal error. |
657 (t | 659 (t |
658 (error "Unknown header field: \"%s\"" field))) | 660 (error "Unknown header field: \"%s\"" field))) |
659 ;; Starting from the current article. | 661 ;; Starting from the current article. |
660 (while (or | 662 (while (or |