Mercurial > emacs
comparison lisp/gnus/gnus-uu.el @ 85712:a3c27999decb
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 |