Mercurial > emacs

comparison lisp/gnus/gnus-uu.el @ 85712:a3c27999decb

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Update Gnus to No Gnus 0.7 from the Gnus CVS trunk Revision: emacs@sv.gnu.org/emacs--devo--0--patch-911
author Miles Bader <miles@gnu.org>
date Sun, 28 Oct 2007 09:18:39 +0000
parents ff46392e7e97
children 8a486bfde38f 880960b70474
comparison
equal deleted inserted replaced
85711:b6f5dc84b2e1 85712:a3c27999decb
391 "Saves the current article." 391 "Saves the current article."
392 (interactive 392 (interactive
393 (list current-prefix-arg 393 (list current-prefix-arg
394 (read-file-name 394 (read-file-name
395 (if gnus-uu-save-separate-articles 395 (if gnus-uu-save-separate-articles
396 "Save articles is dir: " 396 "Save articles in dir: "
397 "Save articles in file: ") 397 "Save articles in file: ")
398 gnus-uu-default-dir 398 gnus-uu-default-dir
399 gnus-uu-default-dir))) 399 gnus-uu-default-dir)))
400 (setq gnus-uu-saved-article-name file) 400 (setq gnus-uu-saved-article-name file)
401 (gnus-uu-decode-with-method 'gnus-uu-save-article n nil t)) 401 (gnus-uu-decode-with-method 'gnus-uu-save-article n nil t))
480 gnus-uu-digest-buffer subject from) 480 gnus-uu-digest-buffer subject from)
481 (if (and n (not (numberp n))) 481 (if (and n (not (numberp n)))
482 (setq message-forward-as-mime (not message-forward-as-mime) 482 (setq message-forward-as-mime (not message-forward-as-mime)
483 n nil)) 483 n nil))
484 (let ((gnus-article-reply (gnus-summary-work-articles n))) 484 (let ((gnus-article-reply (gnus-summary-work-articles n)))
485 (when (and (not n)
486 (= (length gnus-article-reply) 1))
487 ;; The case where neither a number of articles nor a region is
488 ;; specified.
489 (gnus-summary-top-thread)
490 (setq gnus-article-reply (nreverse (gnus-uu-find-articles-matching))))
485 (gnus-setup-message 'forward 491 (gnus-setup-message 'forward
486 (setq gnus-uu-digest-from-subject nil) 492 (setq gnus-uu-digest-from-subject nil)
487 (setq gnus-uu-digest-buffer 493 (setq gnus-uu-digest-buffer
488 (gnus-get-buffer-create " *gnus-uu-forward*")) 494 (gnus-get-buffer-create " *gnus-uu-forward*"))
489 (gnus-uu-decode-save n file) 495 ;; Specify articles to be forwarded. Note that they should be
496 ;; reversed; see `gnus-uu-get-list-of-articles'.
497 (let ((gnus-newsgroup-processable (reverse gnus-article-reply)))
498 (gnus-uu-decode-save n file)
499 (setq gnus-article-reply gnus-newsgroup-processable))
500 ;; Restore the value of `gnus-newsgroup-processable' to which
501 ;; it should be set when it is not `let'-bound.
502 (setq gnus-newsgroup-processable (reverse gnus-article-reply))
490 (switch-to-buffer gnus-uu-digest-buffer) 503 (switch-to-buffer gnus-uu-digest-buffer)
491 (let ((fs gnus-uu-digest-from-subject)) 504 (let ((fs gnus-uu-digest-from-subject))
492 (when fs 505 (when fs
493 (setq from (caar fs) 506 (setq from (caar fs)
494 subject (gnus-simplify-subject-fuzzy (cdar fs)) 507 subject (gnus-simplify-subject-fuzzy (cdar fs))
509 (if (gnus-news-group-p gnus-newsgroup-name) 522 (if (gnus-news-group-p gnus-newsgroup-name)
510 gnus-newsgroup-name 523 gnus-newsgroup-name
511 "Various")))) 524 "Various"))))
512 (goto-char (point-min)) 525 (goto-char (point-min))
513 (when (re-search-forward "^Subject: ") 526 (when (re-search-forward "^Subject: ")
514 (delete-region (point) (gnus-point-at-eol)) 527 (delete-region (point) (point-at-eol))
515 (insert subject)) 528 (insert subject))
516 (goto-char (point-min)) 529 (goto-char (point-min))
517 (when (re-search-forward "^From:") 530 (when (re-search-forward "^From:")
518 (delete-region (point) (gnus-point-at-eol)) 531 (delete-region (point) (point-at-eol))
519 (insert " " from)) 532 (insert " " from))
520 (let ((message-forward-decoded-p t)) 533 (let ((message-forward-decoded-p t))
521 (message-forward post t)))) 534 (message-forward post t))))
522 (setq gnus-uu-digest-from-subject nil))) 535 (setq gnus-uu-digest-from-subject nil)))
523 536
528 541
529 ;; Process marking. 542 ;; Process marking.
530 543
531 (defun gnus-message-process-mark (unmarkp new-marked) 544 (defun gnus-message-process-mark (unmarkp new-marked)
532 (let ((old (- (length gnus-newsgroup-processable) (length new-marked)))) 545 (let ((old (- (length gnus-newsgroup-processable) (length new-marked))))
533 (message "%d mark%s %s%s" 546 (gnus-message 6 "%d mark%s %s%s"
534 (length new-marked) 547 (length new-marked)
535 (if (= (length new-marked) 1) "" "s") 548 (if (= (length new-marked) 1) "" "s")
536 (if unmarkp "removed" "added") 549 (if unmarkp "removed" "added")
537 (cond 550 (cond
538 ((and (zerop old) 551 ((and (zerop old)
539 (not unmarkp)) 552 (not unmarkp))
540 "") 553 "")
541 (unmarkp 554 (unmarkp
542 (format ", %d remain marked" 555 (format ", %d remain marked"
543 (length gnus-newsgroup-processable))) 556 (length gnus-newsgroup-processable)))
544 (t 557 (t
545 (format ", %d already marked" old)))))) 558 (format ", %d already marked" old))))))
546 559
547 (defun gnus-new-processable (unmarkp articles) 560 (defun gnus-new-processable (unmarkp articles)
548 (if unmarkp 561 (if unmarkp
549 (gnus-intersection gnus-newsgroup-processable articles) 562 (gnus-intersection gnus-newsgroup-processable articles)
550 (gnus-set-difference articles gnus-newsgroup-processable))) 563 (gnus-set-difference articles gnus-newsgroup-processable)))
568 "Remove the process mark from articles whose subjects match REGEXP. 581 "Remove the process mark from articles whose subjects match REGEXP.
569 When called interactively, prompt for REGEXP." 582 When called interactively, prompt for REGEXP."
570 (interactive "sUnmark (regexp): ") 583 (interactive "sUnmark (regexp): ")
571 (gnus-uu-mark-by-regexp regexp t)) 584 (gnus-uu-mark-by-regexp regexp t))
572 585
573 (defun gnus-uu-mark-series () 586 (defun gnus-uu-mark-series (&optional silent)
574 "Mark the current series with the process mark." 587 "Mark the current series with the process mark."
575 (interactive) 588 (interactive)
576 (let* ((articles (gnus-uu-find-articles-matching)) 589 (let* ((articles (gnus-uu-find-articles-matching))
577 (l (length articles))) 590 (l (length articles)))
578 (while articles 591 (while articles
579 (gnus-summary-set-process-mark (car articles)) 592 (gnus-summary-set-process-mark (car articles))
580 (setq articles (cdr articles))) 593 (setq articles (cdr articles)))
581 (message "Marked %d articles" l)) 594 (unless silent
582 (gnus-summary-position-point)) 595 (gnus-message 6 "Marked %d articles" l))
596 (gnus-summary-position-point)
597 l))
583 598
584 (defun gnus-uu-mark-region (beg end &optional unmark) 599 (defun gnus-uu-mark-region (beg end &optional unmark)
585 "Set the process mark on all articles between point and mark." 600 "Set the process mark on all articles between point and mark."
586 (interactive "r") 601 (interactive "r")
587 (save-excursion 602 (save-excursion
685 "Mark all articles in \"series\" order." 700 "Mark all articles in \"series\" order."
686 (interactive) 701 (interactive)
687 (setq gnus-newsgroup-processable nil) 702 (setq gnus-newsgroup-processable nil)
688 (save-excursion 703 (save-excursion
689 (let ((data gnus-newsgroup-data) 704 (let ((data gnus-newsgroup-data)
705 (count 0)
690 number) 706 number)
691 (while data 707 (while data
692 (when (and (not (memq (setq number (gnus-data-number (car data))) 708 (when (and (not (memq (setq number (gnus-data-number (car data)))
693 gnus-newsgroup-processable)) 709 gnus-newsgroup-processable))
694 (vectorp (gnus-data-header (car data)))) 710 (vectorp (gnus-data-header (car data))))
695 (gnus-summary-goto-subject number) 711 (gnus-summary-goto-subject number)
696 (gnus-uu-mark-series)) 712 (setq count (+ count (gnus-uu-mark-series t))))
697 (setq data (cdr data))))) 713 (setq data (cdr data)))
714 (gnus-message 6 "Marked %d articles" count)))
698 (gnus-summary-position-point)) 715 (gnus-summary-position-point))
699 716
700 ;; All PostScript functions written by Erik Selberg <speed@cs.washington.edu>. 717 ;; All PostScript functions written by Erik Selberg <speed@cs.washington.edu>.
701 718
702 (defun gnus-uu-decode-postscript (&optional n) 719 (defun gnus-uu-decode-postscript (&optional n)
850 (goto-char (setq beg (point-max))) 867 (goto-char (setq beg (point-max)))
851 (save-excursion 868 (save-excursion
852 (save-restriction 869 (save-restriction
853 (set-buffer buffer) 870 (set-buffer buffer)
854 (let (buffer-read-only) 871 (let (buffer-read-only)
855 (gnus-set-text-properties (point-min) (point-max) nil) 872 (set-text-properties (point-min) (point-max) nil)
856 ;; These two are necessary for XEmacs 19.12 fascism. 873 ;; These two are necessary for XEmacs 19.12 fascism.
857 (put-text-property (point-min) (point-max) 'invisible nil) 874 (put-text-property (point-min) (point-max) 'invisible nil)
858 (put-text-property (point-min) (point-max) 'intangible nil)) 875 (put-text-property (point-min) (point-max) 'intangible nil))
859 (when (and message-forward-as-mime 876 (when (and message-forward-as-mime
860 message-forward-show-mml 877 message-forward-show-mml
861 gnus-uu-digest-buffer) 878 gnus-uu-digest-buffer)
862 (mm-enable-multibyte) 879 (mm-enable-multibyte)
863 (mime-to-mml)) 880 (mime-to-mml))
864 (goto-char (point-min)) 881 (goto-char (point-min))
865 (re-search-forward "\n\n") 882 (search-forward "\n\n")
866 (unless (and message-forward-as-mime gnus-uu-digest-buffer) 883 (unless (and message-forward-as-mime gnus-uu-digest-buffer)
867 ;; Quote all 30-dash lines. 884 ;; Quote all 30-dash lines.
868 (save-excursion 885 (save-excursion
869 (while (re-search-forward "^-" nil t) 886 (while (re-search-forward "^-" nil t)
870 (beginning-of-line) 887 (beginning-of-line)
1151 (push (cons subj (gnus-data-number d)) 1168 (push (cons subj (gnus-data-number d))
1152 list-of-subjects)))) 1169 list-of-subjects))))
1153 1170
1154 ;; Expand numbers, sort, and return the list of article 1171 ;; Expand numbers, sort, and return the list of article
1155 ;; numbers. 1172 ;; numbers.
1156 (mapcar (lambda (sub) (cdr sub)) 1173 (mapcar 'cdr
1157 (sort (gnus-uu-expand-numbers 1174 (sort (gnus-uu-expand-numbers
1158 list-of-subjects 1175 list-of-subjects
1159 (not do-not-translate)) 1176 (not do-not-translate))
1160 'gnus-uu-string<)))))) 1177 'gnus-uu-string<))))))
1161 1178
1404 (while (string-match "[0-9]+/[0-9]+\\|[0-9]+[ \t]+of[ \t]+[0-9]+" 1421 (while (string-match "[0-9]+/[0-9]+\\|[0-9]+[ \t]+of[ \t]+[0-9]+"
1405 subject) 1422 subject)
1406 (setq part (match-string 0 subject)) 1423 (setq part (match-string 0 subject))
1407 (setq subject (substring subject (match-end 0))))) 1424 (setq subject (substring subject (match-end 0)))))
1408 (or part 1425 (or part
1409 (while (string-match "\\([0-9]+\\)[^0-9]+\\([0-9]+\\)" subject) 1426 (while (string-match "[0-9]+[^0-9]+[0-9]+" subject)
1410 (setq part (match-string 0 subject)) 1427 (setq part (match-string 0 subject))
1411 (setq subject (substring subject (match-end 0))))) 1428 (setq subject (substring subject (match-end 0)))))
1412 (or part ""))) 1429 (or part "")))
1413 1430
1414 (defun gnus-uu-uudecode-sentinel (process event) 1431 (defun gnus-uu-uudecode-sentinel (process event)
1706 out)) 1723 out))
1707 1724
1708 (defun gnus-uu-check-correct-stripped-uucode (start end) 1725 (defun gnus-uu-check-correct-stripped-uucode (start end)
1709 (save-excursion 1726 (save-excursion
1710 (let (found beg length) 1727 (let (found beg length)
1711 (if (not gnus-uu-correct-stripped-uucode) 1728 (unless gnus-uu-correct-stripped-uucode
1712 ()
1713 (goto-char start) 1729 (goto-char start)
1714 1730
1715 (if (re-search-forward " \\|`" end t) 1731 (if (re-search-forward " \\|`" end t)
1716 (progn 1732 (progn
1717 (goto-char start) 1733 (goto-char start)
1720 (when (looking-at "\n") 1736 (when (looking-at "\n")
1721 (replace-match "")) 1737 (replace-match ""))
1722 (forward-line 1)))) 1738 (forward-line 1))))
1723 1739
1724 (while (not (eobp)) 1740 (while (not (eobp))
1725 (if (looking-at (concat gnus-uu-begin-string "\\|" 1741 (unless (looking-at (concat gnus-uu-begin-string "\\|"
1726 gnus-uu-end-string)) 1742 gnus-uu-end-string))
1727 ()
1728 (when (not found) 1743 (when (not found)
1729 (beginning-of-line) 1744 (setq length (- (point-at-eol) (point-at-bol))))
1730 (setq beg (point))
1731 (end-of-line)
1732 (setq length (- (point) beg)))
1733 (setq found t) 1745 (setq found t)
1734 (beginning-of-line) 1746 (beginning-of-line)
1735 (setq beg (point)) 1747 (setq beg (point))
1736 (end-of-line) 1748 (end-of-line)
1737 (when (not (= length (- (point) beg))) 1749 (unless (= length (- (point) beg))
1738 (insert (make-string (- length (- (point) beg)) ? )))) 1750 (insert (make-string (- length (- (point) beg)) ? ))))
1739 (forward-line 1))))))) 1751 (forward-line 1)))))))
1740 1752
1741 (defvar gnus-uu-tmp-alist nil) 1753 (defvar gnus-uu-tmp-alist nil)
1742 1754
1757 (error "Temp directory %s can't be written to" 1769 (error "Temp directory %s can't be written to"
1758 gnus-uu-tmp-dir))) 1770 gnus-uu-tmp-dir)))
1759 1771
1760 (setq gnus-uu-work-dir 1772 (setq gnus-uu-work-dir
1761 (mm-make-temp-file (concat gnus-uu-tmp-dir "gnus") 'dir)) 1773 (mm-make-temp-file (concat gnus-uu-tmp-dir "gnus") 'dir))
1762 (set-file-modes gnus-uu-work-dir 448) 1774 (gnus-set-file-modes gnus-uu-work-dir 448)
1763 (setq gnus-uu-work-dir (file-name-as-directory gnus-uu-work-dir)) 1775 (setq gnus-uu-work-dir (file-name-as-directory gnus-uu-work-dir))
1764 (push (cons gnus-newsgroup-name gnus-uu-work-dir) 1776 (push (cons gnus-newsgroup-name gnus-uu-work-dir)
1765 gnus-uu-tmp-alist)))) 1777 gnus-uu-tmp-alist))))
1766 1778
1767 1779
1777 1789
1778 ;; Inputs an action and a filename and returns a full command, making sure 1790 ;; Inputs an action and a filename and returns a full command, making sure
1779 ;; that the filename will be treated as a single argument when the shell 1791 ;; that the filename will be treated as a single argument when the shell
1780 ;; executes the command. 1792 ;; executes the command.
1781 (defun gnus-uu-command (action file) 1793 (defun gnus-uu-command (action file)
1782 (let ((quoted-file (mm-quote-arg file))) 1794 (let ((quoted-file (shell-quote-argument file)))
1783 (if (string-match "%s" action) 1795 (if (string-match "%s" action)
1784 (format action quoted-file) 1796 (format action quoted-file)
1785 (concat action " " quoted-file)))) 1797 (concat action " " quoted-file))))
1786 1798
1787 (defun gnus-uu-delete-work-dir (&optional dir) 1799 (defun gnus-uu-delete-work-dir (&optional dir)
1901 ;; Encodes with uuencode and substitutes all spaces with backticks. 1913 ;; Encodes with uuencode and substitutes all spaces with backticks.
1902 (defun gnus-uu-post-encode-uuencode (path file-name) 1914 (defun gnus-uu-post-encode-uuencode (path file-name)
1903 (when (gnus-uu-post-encode-file "uuencode" path file-name) 1915 (when (gnus-uu-post-encode-file "uuencode" path file-name)
1904 (goto-char (point-min)) 1916 (goto-char (point-min))
1905 (forward-line 1) 1917 (forward-line 1)
1906 (while (re-search-forward " " nil t) 1918 (while (search-forward " " nil t)
1907 (replace-match "`")) 1919 (replace-match "`"))
1908 t)) 1920 t))
1909 1921
1910 ;; Encodes with uuencode and adds MIME headers. 1922 ;; Encodes with uuencode and adds MIME headers.
1911 (defun gnus-uu-post-encode-mime-uuencode (path file-name) 1923 (defun gnus-uu-post-encode-mime-uuencode (path file-name)
2032 (delete-region (point) (point-max)) 2044 (delete-region (point) (point-max))
2033 2045
2034 (goto-char (point-min)) 2046 (goto-char (point-min))
2035 (re-search-forward 2047 (re-search-forward
2036 (concat "^" (regexp-quote mail-header-separator) "$") nil t) 2048 (concat "^" (regexp-quote mail-header-separator) "$") nil t)
2037 (beginning-of-line) 2049 (setq header (buffer-substring (point-min) (point-at-bol)))
2038 (setq header (buffer-substring (point-min) (point)))
2039 2050
2040 (goto-char (point-min)) 2051 (goto-char (point-min))
2041 (when gnus-uu-post-separate-description 2052 (when gnus-uu-post-separate-description
2042 (when (re-search-forward "^Subject: " nil t) 2053 (when (re-search-forward "^Subject: " nil t)
2043 (end-of-line) 2054 (end-of-line)
2109 (gnus-kill-buffer send-buffer-name) 2120 (gnus-kill-buffer send-buffer-name)
2110 (gnus-kill-buffer encoded-buffer-name) 2121 (gnus-kill-buffer encoded-buffer-name)
2111 2122
2112 (when (not gnus-uu-post-separate-description) 2123 (when (not gnus-uu-post-separate-description)
2113 (set-buffer-modified-p nil) 2124 (set-buffer-modified-p nil)
2114 (when (fboundp 'bury-buffer) 2125 (bury-buffer))))
2115 (bury-buffer)))))
2116 2126
2117 (provide 'gnus-uu) 2127 (provide 'gnus-uu)
2118 2128
2119 ;;; arch-tag: 05312384-0a83-4720-9a58-b3160b888853 2129 ;;; arch-tag: 05312384-0a83-4720-9a58-b3160b888853
2120 ;;; gnus-uu.el ends here 2130 ;;; gnus-uu.el ends here