X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-uu.el;h=a0adc3a5d8b78efd962eeeb9d5f2a2c4bf8c8765;hb=d0498ec691ac9cc3f6bdd9f4ba3ac26457cc3d8a;hp=f2660fd8143562bd1aeec68ef89ce39dfc6eed70;hpb=150bebacb9e691850c6a2825319cbf64799cd241;p=gnus diff --git a/lisp/gnus-uu.el b/lisp/gnus-uu.el index f2660fd81..a0adc3a5d 100644 --- a/lisp/gnus-uu.el +++ b/lisp/gnus-uu.el @@ -1,9 +1,8 @@ ;;; gnus-uu.el --- extract (uu)encoded files in Gnus -;; Copyright (C) 1985,86,87,93,94,95 Free Software Foundation, Inc. +;; Copyright (C) 1985,86,87,93,94,95,96 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Created: 2 Oct 1993 -;; Version: v3.0 ;; Keyword: news ;; This file is part of GNU Emacs. @@ -19,14 +18,17 @@ ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to -;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Commentary: ;;; Code: -(require 'gnus) +(require 'gnus-load) +(require 'gnus-art) +(require 'message) (require 'gnus-msg) ;; Default viewing action rules @@ -40,6 +42,7 @@ ("\\.\\(wav\\|aiff\\|hcom\\|u[blw]\\|s[bfw]\\|voc\\|smp\\)$" "sox -v .5 %s -t .au -u - > /dev/audio") ("\\.au$" "cat %s > /dev/audio") + ("\\.midi?$" "playmidi -f") ("\\.mod$" "str32") ("\\.ps$" "ghostview") ("\\.dvi$" "xdvi") @@ -59,21 +62,21 @@ following in your .emacs file: (setq gnus-uu-user-view-rules '((\"jpg$\\\\|gif$\" \"xli\"))) -Both these variables are lists of lists with two string elements. The -first string is a regular expression. If the file name matches this +Both these variables are lists of lists with two string elements. The +first string is a regular expression. If the file name matches this regular expression, the command in the second string is executed with the file as an argument. If the command string contains \"%s\", the file name will be inserted -at that point in the command string. If there's no \"%s\" in the +at that point in the command string. If there's no \"%s\" in the command string, the file name will be appended to the command string before executing. There are several user variables to tailor the behaviour of gnus-uu to -your needs. First we have `gnus-uu-user-view-rules', which is the +your needs. First we have `gnus-uu-user-view-rules', which is the variable gnus-uu first consults when trying to decide how to view a -file. If this variable contains no matches, gnus-uu examines the -default rule vaiable provided in this package. If gnus-uu finds no +file. If this variable contains no matches, gnus-uu examines the +default rule variable provided in this package. If gnus-uu finds no match here, it uses `gnus-uu-user-view-rules-end' to try to make a match.") @@ -180,21 +183,22 @@ Note that this variable can be used in conjunction with the Default is \"/tmp/\".") (defvar gnus-uu-do-not-unpack-archives nil - "*Non-nil means that gnus-uu won't peek inside archives looking for files to dispay. + "*Non-nil means that gnus-uu won't peek inside archives looking for files to display. Default is nil.") -(defvar gnus-uu-view-and-save nil - "*Non-nil means that the user will always be asked to save a file after viewing it. -If the variable is nil, the suer will only be asked to save if the -viewing is unsuccessful. Default is nil.") - (defvar gnus-uu-ignore-default-view-rules nil "*Non-nil means that gnus-uu will ignore the default viewing rules. -Only the user viewing rules will be consulted. Default is nil.") +Only the user viewing rules will be consulted. Default is nil.") + +(defvar gnus-uu-grabbed-file-functions nil + "*Functions run on each file after successful decoding. +They will be called with the name of the file as the argument. +Likely functions you can use in this list are `gnus-uu-grab-view' +and `gnus-uu-grab-move'.") (defvar gnus-uu-ignore-default-archive-rules nil "*Non-nil means that gnus-uu will ignore the default archive unpacking commands. -Only the user unpacking commands will be consulted. Default is nil.") +Only the user unpacking commands will be consulted. Default is nil.") (defvar gnus-uu-kill-carriage-return t "*Non-nil means that gnus-uu will strip all carriage returns from articles. @@ -203,7 +207,7 @@ Default is t.") (defvar gnus-uu-view-with-metamail nil "*Non-nil means that files will be viewed with metamail. The gnus-uu viewing functions will be ignored and gnus-uu will try -to guess at a content-type based on file name suffixes. Default +to guess at a content-type based on file name suffixes. Default it nil.") (defvar gnus-uu-unmark-articles-not-decoded nil @@ -211,13 +215,13 @@ it nil.") Default is nil.") (defvar gnus-uu-correct-stripped-uucode nil - "*Non-nil means that gnus-uu will *try* to fix uuencoded files that have had traling spaces deleted. + "*Non-nil means that gnus-uu will *try* to fix uuencoded files that have had trailing spaces deleted. Default is nil.") (defvar gnus-uu-save-in-digest nil "*Non-nil means that gnus-uu, when asked to save without decoding, will save in digests. If this variable is nil, gnus-uu will just save everything in a -file without any embellishments. The digesting almost conforms to RFC1153 - +file without any embellishments. The digesting almost conforms to RFC1153 - no easy way to specify any meaningful volume and issue numbers were found, so I simply dropped them.") @@ -255,66 +259,66 @@ The headers will be included in the sequence they are matched.") (defvar gnus-uu-file-name nil) (defconst gnus-uu-uudecode-process nil) +(defvar gnus-uu-binhex-article-name nil) -(defvar gnus-uu-generated-file-list nil) (defvar gnus-uu-work-dir nil) -(defconst gnus-uu-output-buffer-name "*Gnus UU Output*") +(defconst gnus-uu-output-buffer-name " *Gnus UU Output*") -(defconst gnus-uu-highest-article-number 1) -(defvar gnus-uu-default-dir default-directory) +(defvar gnus-uu-default-dir gnus-article-save-directory) +(defvar gnus-uu-digest-from-subject nil) ;; Keymaps -(defvar gnus-uu-extract-map nil) -(defvar gnus-uu-extract-view-map nil) -(defvar gnus-uu-mark-map nil) - -(define-prefix-command 'gnus-uu-mark-map) -(define-key gnus-summary-mark-map "p" 'gnus-uu-mark-map) -(define-key gnus-uu-mark-map "p" 'gnus-summary-mark-as-processable) -(define-key gnus-uu-mark-map "u" 'gnus-summary-unmark-as-processable) -(define-key gnus-uu-mark-map "U" 'gnus-summary-unmark-all-processable) -(define-key gnus-uu-mark-map "s" 'gnus-uu-mark-series) -(define-key gnus-uu-mark-map "r" 'gnus-uu-mark-region) -(define-key gnus-uu-mark-map "R" 'gnus-uu-mark-by-regexp) -(define-key gnus-uu-mark-map "t" 'gnus-uu-mark-thread) -(define-key gnus-uu-mark-map "a" 'gnus-uu-mark-all) -(define-key gnus-uu-mark-map "S" 'gnus-uu-mark-sparse) - -(define-prefix-command 'gnus-uu-extract-map) -(define-key gnus-summary-mode-map "X" 'gnus-uu-extract-map) -;;(define-key gnus-uu-extract-map "x" 'gnus-uu-extract-any) -;;(define-key gnus-uu-extract-map "m" 'gnus-uu-extract-mime) -(define-key gnus-uu-extract-map "u" 'gnus-uu-decode-uu) -(define-key gnus-uu-extract-map "U" 'gnus-uu-decode-uu-and-save) -(define-key gnus-uu-extract-map "s" 'gnus-uu-decode-unshar) -(define-key gnus-uu-extract-map "S" 'gnus-uu-decode-unshar-and-save) -(define-key gnus-uu-extract-map "o" 'gnus-uu-decode-save) -(define-key gnus-uu-extract-map "O" 'gnus-uu-decode-save) -(define-key gnus-uu-extract-map "b" 'gnus-uu-decode-binhex) -(define-key gnus-uu-extract-map "B" 'gnus-uu-decode-binhex) -(define-key gnus-uu-extract-map "p" 'gnus-uu-decode-postscript) -(define-key gnus-uu-extract-map "P" 'gnus-uu-decode-postscript-and-save) - -(define-prefix-command 'gnus-uu-extract-view-map) -(define-key gnus-uu-extract-map "v" 'gnus-uu-extract-view-map) -(define-key gnus-uu-extract-view-map "u" 'gnus-uu-decode-uu-view) -(define-key gnus-uu-extract-view-map "U" 'gnus-uu-decode-uu-and-save-view) -(define-key gnus-uu-extract-view-map "s" 'gnus-uu-decode-unshar-view) -(define-key gnus-uu-extract-view-map "S" 'gnus-uu-decode-unshar-and-save-view) -(define-key gnus-uu-extract-view-map "o" 'gnus-uu-decode-save-view) -(define-key gnus-uu-extract-view-map "O" 'gnus-uu-decode-save-view) -(define-key gnus-uu-extract-view-map "b" 'gnus-uu-decode-binhex-view) -(define-key gnus-uu-extract-view-map "B" 'gnus-uu-decode-binhex-view) -(define-key gnus-uu-extract-view-map "p" 'gnus-uu-decode-postscript-view) -(define-key gnus-uu-extract-view-map "P" 'gnus-uu-decode-postscript-and-save-view) - +(gnus-define-keys (gnus-uu-mark-map "P" gnus-summary-mark-map) + "p" gnus-summary-mark-as-processable + "u" gnus-summary-unmark-as-processable + "U" gnus-summary-unmark-all-processable + "v" gnus-uu-mark-over + "s" gnus-uu-mark-series + "r" gnus-uu-mark-region + "R" gnus-uu-mark-by-regexp + "t" gnus-uu-mark-thread + "T" gnus-uu-unmark-thread + "a" gnus-uu-mark-all + "b" gnus-uu-mark-buffer + "S" gnus-uu-mark-sparse + "k" gnus-summary-kill-process-mark + "y" gnus-summary-yank-process-mark + "w" gnus-summary-save-process-mark + "i" gnus-uu-invert-processable) + +(gnus-define-keys (gnus-uu-extract-map "X" gnus-summary-mode-map) + ;;"x" gnus-uu-extract-any + ;;"m" gnus-uu-extract-mime + "u" gnus-uu-decode-uu + "U" gnus-uu-decode-uu-and-save + "s" gnus-uu-decode-unshar + "S" gnus-uu-decode-unshar-and-save + "o" gnus-uu-decode-save + "O" gnus-uu-decode-save + "b" gnus-uu-decode-binhex + "B" gnus-uu-decode-binhex + "p" gnus-uu-decode-postscript + "P" gnus-uu-decode-postscript-and-save) + +(gnus-define-keys + (gnus-uu-extract-view-map "v" gnus-uu-extract-map) + "u" gnus-uu-decode-uu-view + "U" gnus-uu-decode-uu-and-save-view + "s" gnus-uu-decode-unshar-view + "S" gnus-uu-decode-unshar-and-save-view + "o" gnus-uu-decode-save-view + "O" gnus-uu-decode-save-view + "b" gnus-uu-decode-binhex-view + "B" gnus-uu-decode-binhex-view + "p" gnus-uu-decode-postscript-view + "P" gnus-uu-decode-postscript-and-save-view) ;; Commands. -(defun gnus-uu-decode-uu (n) +(defun gnus-uu-decode-uu (&optional n) "Uudecodes the current article." (interactive "P") (gnus-uu-decode-with-method 'gnus-uu-uustrip-article n)) @@ -323,24 +327,26 @@ The headers will be included in the sequence they are matched.") "Decodes and saves the resulting file." (interactive (list current-prefix-arg - (read-file-name "Uudecode and save in dir: " - gnus-uu-default-dir - gnus-uu-default-dir t))) - (gnus-uu-decode-with-method 'gnus-uu-uustrip-article n dir)) + (file-name-as-directory + (read-file-name "Uudecode and save in dir: " + gnus-uu-default-dir + gnus-uu-default-dir t)))) + (gnus-uu-decode-with-method 'gnus-uu-uustrip-article n dir nil nil t)) -(defun gnus-uu-decode-unshar (n) +(defun gnus-uu-decode-unshar (&optional n) "Unshars the current article." (interactive "P") - (gnus-uu-decode-with-method 'gnus-uu-unshar-article n)) + (gnus-uu-decode-with-method 'gnus-uu-unshar-article n nil nil 'scan t)) (defun gnus-uu-decode-unshar-and-save (n dir) "Unshars and saves the current article." (interactive (list current-prefix-arg - (read-file-name "Unshar and save in dir: " - gnus-uu-default-dir - gnus-uu-default-dir t))) - (gnus-uu-decode-with-method 'gnus-uu-unshar-article n dir)) + (file-name-as-directory + (read-file-name "Unshar and save in dir: " + gnus-uu-default-dir + gnus-uu-default-dir t)))) + (gnus-uu-decode-with-method 'gnus-uu-unshar-article n dir nil 'scan t)) (defun gnus-uu-decode-save (n file) "Saves the current article." @@ -353,20 +359,21 @@ The headers will be included in the sequence they are matched.") gnus-uu-default-dir gnus-uu-default-dir))) (setq gnus-uu-saved-article-name file) - (gnus-uu-decode-with-method 'gnus-uu-save-article n nil t) - (setq gnus-uu-generated-file-list - (delete file gnus-uu-generated-file-list))) + (gnus-uu-decode-with-method 'gnus-uu-save-article n nil t)) (defun gnus-uu-decode-binhex (n dir) "Unbinhexes the current article." (interactive (list current-prefix-arg - (read-file-name "Unbinhex and save in dir: " - gnus-uu-default-dir - gnus-uu-default-dir t))) + (file-name-as-directory + (read-file-name "Unbinhex and save in dir: " + gnus-uu-default-dir + gnus-uu-default-dir)))) + (setq gnus-uu-binhex-article-name + (make-temp-name (concat gnus-uu-work-dir "binhex"))) (gnus-uu-decode-with-method 'gnus-uu-binhex-article n dir)) -(defun gnus-uu-decode-uu-view (n) +(defun gnus-uu-decode-uu-view (&optional n) "Uudecodes and views the current article." (interactive "P") (let ((gnus-view-pseudos (or gnus-view-pseudos 'automatic))) @@ -382,7 +389,7 @@ The headers will be included in the sequence they are matched.") (let ((gnus-view-pseudos (or gnus-view-pseudos 'automatic))) (gnus-uu-decode-uu-and-save n dir))) -(defun gnus-uu-decode-unshar-view (n) +(defun gnus-uu-decode-unshar-view (&optional n) "Unshars and views the current article." (interactive "P") (let ((gnus-view-pseudos (or gnus-view-pseudos 'automatic))) @@ -415,59 +422,84 @@ The headers will be included in the sequence they are matched.") (list current-prefix-arg (read-file-name "Unbinhex, view and save in dir: " gnus-uu-default-dir gnus-uu-default-dir))) + (setq gnus-uu-binhex-article-name + (make-temp-name (concat gnus-uu-work-dir "binhex"))) (let ((gnus-view-pseudos (or gnus-view-pseudos 'automatic))) (gnus-uu-decode-binhex n file))) ;; Digest and forward articles -(defun gnus-uu-digest-mail-forward (n &optional post) +(defun gnus-uu-digest-mail-forward (&optional n post) "Digests and forwards all articles in this series." (interactive "P") - (gnus-uu-initialize) (let ((gnus-uu-save-in-digest t) - (file (concat gnus-uu-work-dir (make-temp-name "forward"))) - (winconf (current-window-configuration)) - buf) + (file (make-temp-name (concat gnus-uu-tmp-dir "forward"))) + buf subject from newsgroups) + (setq gnus-uu-digest-from-subject nil) (gnus-uu-decode-save n file) - (gnus-uu-add-file file) (setq buf (switch-to-buffer (get-buffer-create " *gnus-uu-forward*"))) (gnus-add-current-to-buffer-list) (erase-buffer) (delete-other-windows) (insert-file file) + (let ((fs gnus-uu-digest-from-subject)) + (when fs + (setq from (caar fs) + subject (gnus-simplify-subject-fuzzy (cdar fs)) + fs (cdr fs)) + (while (and fs (or from subject)) + (when from + (or (string= from (caar fs)) + (setq from nil))) + (when subject + (or (string= (gnus-simplify-subject-fuzzy (cdar fs)) + subject) + (setq subject nil))) + (setq fs (cdr fs)))) + (unless subject + (setq subject "Digested Articles")) + (unless from + (setq from + (if (gnus-news-group-p gnus-newsgroup-name) + gnus-newsgroup-name + "Various")))) (goto-char (point-min)) - (and (re-search-forward "^Subject: ") - (progn - (delete-region (point) (gnus-point-at-eol)) - (insert "Digested Articles"))) + (when (re-search-forward "^Subject: ") + (delete-region (point) (gnus-point-at-eol)) + (insert subject)) (goto-char (point-min)) - (and (re-search-forward "^From: ") - (progn - (delete-region (point) (gnus-point-at-eol)) - (insert "Various"))) - (if post - (gnus-forward-using-post) - (funcall gnus-mail-forward-method)) - (kill-buffer buf))) - -(defun gnus-uu-digest-post-forward (n) + (when (re-search-forward "^From: ") + (delete-region (point) (gnus-point-at-eol)) + (insert from)) + (message-forward post) + (delete-file file) + (kill-buffer buf) + (setq gnus-uu-digest-from-subject nil))) + +(defun gnus-uu-digest-post-forward (&optional n) "Digest and forward to a newsgroup." (interactive "P") (gnus-uu-digest-mail-forward n t)) ;; Process marking. -(defun gnus-uu-mark-by-regexp (regexp) +(defun gnus-uu-mark-by-regexp (regexp &optional unmark) "Ask for a regular expression and set the process mark on all articles that match." (interactive (list (read-from-minibuffer "Mark (regexp): "))) (gnus-set-global-variables) (let ((articles (gnus-uu-find-articles-matching regexp))) (while articles - (gnus-summary-set-process-mark (car articles)) - (setq articles (cdr articles))) + (if unmark + (gnus-summary-remove-process-mark (pop articles)) + (gnus-summary-set-process-mark (pop articles)))) (message "")) - (gnus-summary-position-cursor)) + (gnus-summary-position-point)) + +(defun gnus-uu-unmark-by-regexp (regexp &optional unmark) + "Ask for a regular expression and remove the process mark on all articles that match." + (interactive (list (read-from-minibuffer "Mark (regexp): "))) + (gnus-uu-mark-by-regexp regexp t)) (defun gnus-uu-mark-series () "Mark the current series with the process mark." @@ -478,29 +510,83 @@ The headers will be included in the sequence they are matched.") (gnus-summary-set-process-mark (car articles)) (setq articles (cdr articles))) (message "")) - (gnus-summary-position-cursor)) + (gnus-summary-position-point)) -(defun gnus-uu-mark-region (beg end) - "Marks all articles between point and mark." +(defun gnus-uu-mark-region (beg end &optional unmark) + "Set the process mark on all articles between point and mark." (interactive "r") (gnus-set-global-variables) (save-excursion (goto-char beg) (while (< (point) end) - (gnus-summary-set-process-mark (gnus-summary-article-number)) + (if unmark + (gnus-summary-remove-process-mark (gnus-summary-article-number)) + (gnus-summary-set-process-mark (gnus-summary-article-number))) (forward-line 1))) - (gnus-summary-position-cursor)) + (gnus-summary-position-point)) + +(defun gnus-uu-unmark-region (beg end) + "Remove the process mark from all articles between point and mark." + (interactive "r") + (gnus-uu-mark-region beg end t)) + +(defun gnus-uu-mark-buffer () + "Set the process mark on all articles in the buffer." + (interactive) + (gnus-uu-mark-region (point-min) (point-max))) + +(defun gnus-uu-unmark-buffer () + "Remove the process mark on all articles in the buffer." + (interactive) + (gnus-uu-mark-region (point-min) (point-max) t)) (defun gnus-uu-mark-thread () "Marks all articles downwards in this thread." (interactive) (gnus-set-global-variables) - (save-excursion - (let ((level (gnus-summary-thread-level))) + (let ((level (gnus-summary-thread-level))) (while (and (gnus-summary-set-process-mark (gnus-summary-article-number)) (zerop (gnus-summary-next-subject 1)) - (> (gnus-summary-thread-level) level))))) - (gnus-summary-position-cursor)) + (> (gnus-summary-thread-level) level)))) + (gnus-summary-position-point)) + +(defun gnus-uu-unmark-thread () + "Unmarks all articles downwards in this thread." + (interactive) + (gnus-set-global-variables) + (let ((level (gnus-summary-thread-level))) + (while (and (gnus-summary-remove-process-mark + (gnus-summary-article-number)) + (zerop (gnus-summary-next-subject 1)) + (> (gnus-summary-thread-level) level)))) + (gnus-summary-position-point)) + +(defun gnus-uu-invert-processable () + "Invert the list of process-marked articles." + (let ((data gnus-newsgroup-data) + d number) + (save-excursion + (while data + (if (memq (setq number (gnus-data-number (pop data))) + gnus-newsgroup-processable) + (gnus-summary-remove-process-mark number) + (gnus-summary-set-process-mark number))))) + (gnus-summary-position-point)) + +(defun gnus-uu-mark-over (&optional score) + "Mark all articles with a score over SCORE (the prefix.)" + (interactive "P") + (let ((score (gnus-score-default score)) + (data gnus-newsgroup-data)) + (save-excursion + (while data + (when (> (or (cdr (assq (gnus-data-number (car data)) + gnus-newsgroup-scored)) + gnus-summary-default-score 0) + score) + (gnus-summary-set-process-mark (caar data))) + (setq data (cdr data)))) + (gnus-summary-position-point))) (defun gnus-uu-mark-sparse () "Mark all series that have some articles marked." @@ -512,8 +598,9 @@ The headers will be included in the sequence they are matched.") (setq gnus-newsgroup-processable nil) (save-excursion (while marked - (and (setq headers (gnus-get-header-by-number (car marked))) - (setq subject (header-subject headers) + (and (vectorp (setq headers + (gnus-summary-article-header (car marked)))) + (setq subject (mail-header-subject headers) articles (gnus-uu-find-articles-matching (gnus-uu-reginize-string subject)) total (nconc total articles))) @@ -523,7 +610,7 @@ The headers will be included in the sequence they are matched.") (setq articles (cdr articles))) (setq marked (cdr marked))) (setq gnus-newsgroup-processable (nreverse total))) - (gnus-summary-position-cursor))) + (gnus-summary-position-point))) (defun gnus-uu-mark-all () "Mark all articles in \"series\" order." @@ -531,23 +618,25 @@ The headers will be included in the sequence they are matched.") (gnus-set-global-variables) (setq gnus-newsgroup-processable nil) (save-excursion - (goto-char (point-min)) - (let (number) - (while (and (not (eobp)) - (setq number (gnus-summary-article-number))) - (if (not (memq number gnus-newsgroup-processable)) - (save-excursion (gnus-uu-mark-series))) - (forward-line 1)))) - (gnus-summary-position-cursor)) + (let ((data gnus-newsgroup-data) + number) + (while data + (when (and (not (memq (setq number (gnus-data-number (car data))) + gnus-newsgroup-processable)) + (vectorp (gnus-data-header (car data)))) + (gnus-summary-goto-subject number) + (gnus-uu-mark-series)) + (setq data (cdr data))))) + (gnus-summary-position-point)) ;; All PostScript functions written by Erik Selberg . -(defun gnus-uu-decode-postscript (n) +(defun gnus-uu-decode-postscript (&optional n) "Gets postscript of the current article." (interactive "P") (gnus-uu-decode-with-method 'gnus-uu-decode-postscript-article n)) -(defun gnus-uu-decode-postscript-view (n) +(defun gnus-uu-decode-postscript-view (&optional n) "Gets and views the current article." (interactive "P") (let ((gnus-view-pseudos (or gnus-view-pseudos 'automatic))) @@ -557,11 +646,12 @@ The headers will be included in the sequence they are matched.") "Extracts postscript and saves the current article." (interactive (list current-prefix-arg - (read-file-name "Where do you want to save the file(s)? " - gnus-uu-default-dir - gnus-uu-default-dir t))) - (gnus-uu-decode-with-method 'gnus-uu-decode-postscript-article n dir)) - + (file-name-as-directory + (read-file-name "Save in dir: " + gnus-uu-default-dir + gnus-uu-default-dir t)))) + (gnus-uu-decode-with-method 'gnus-uu-decode-postscript-article + n dir nil nil t)) (defun gnus-uu-decode-postscript-and-save-view (n dir) "Decodes, views and saves the resulting file." @@ -576,33 +666,57 @@ The headers will be included in the sequence they are matched.") ;; Internal functions. -(defun gnus-uu-decode-with-method (method n &optional save not-insert) - (gnus-uu-initialize) +(defun gnus-uu-decode-with-method (method n &optional save not-insert + scan cdir) + (gnus-uu-initialize scan) (if save (setq gnus-uu-default-dir save)) + ;; Create the directory we save to. + (when (and scan cdir save + (not (file-exists-p save))) + (make-directory save t)) (let ((articles (gnus-uu-get-list-of-articles n)) files) (setq files (gnus-uu-grab-articles articles method t)) + (let ((gnus-current-article (car articles))) + (and scan (setq files (gnus-uu-scan-directory gnus-uu-work-dir)))) (and save (gnus-uu-save-files files save)) - (setq files (gnus-uu-unpack-files files)) - (gnus-uu-add-file (mapcar (lambda (file) (cdr (assq 'name file))) files)) + (if (eq gnus-uu-do-not-unpack-archives nil) + (setq files (gnus-uu-unpack-files files))) (setq files (nreverse (gnus-uu-get-actions files))) - (or not-insert (gnus-summary-insert-pseudos files)))) + (or not-insert (not gnus-insert-pseudo-articles) + (gnus-summary-insert-pseudos files save)))) + +(defun gnus-uu-scan-directory (dir &optional rec) + "Return a list of all files under DIR." + (let ((files (directory-files dir t)) + out file) + (while (setq file (pop files)) + (unless (member (file-name-nondirectory file) '("." "..")) + (push (list (cons 'name file) + (cons 'article gnus-current-article)) + out) + (when (file-directory-p file) + (setq out (nconc (gnus-uu-scan-directory file t) out))))) + (if rec + out + (nreverse out)))) (defun gnus-uu-save-files (files dir) + "Save FILES in DIR." (let ((len (length files)) - to-file file) - (while files - (setq file (cdr (assq 'name (car files)))) - (and (file-exists-p file) - (progn - (setq to-file (if (file-directory-p dir) - (concat dir (file-name-nondirectory file)) - dir)) - (and (or (not (file-exists-p to-file)) - (gnus-y-or-n-p (format "%s exists; overwrite? " to-file))) - (copy-file file to-file 1 t)))) - (setq files (cdr files))) - (message "Saved %d file%s" len (if (> len 1) "s" "")))) + (reg (concat "^" (regexp-quote gnus-uu-work-dir))) + to-file file fromdir) + (while (setq file (cdr (assq 'name (pop files)))) + (when (file-exists-p file) + (string-match reg file) + (setq fromdir (substring file (match-end 0))) + (if (file-directory-p file) + (gnus-make-directory (concat dir fromdir)) + (setq to-file (concat dir fromdir)) + (when (or (not (file-exists-p to-file)) + (gnus-y-or-n-p (format "%s exists; overwrite? " to-file))) + (copy-file file to-file t t))))) + (gnus-message 5 "Saved %d file%s" len (if (= len 1) "" "s")))) ;; Functions for saving and possibly digesting articles without ;; any decoding. @@ -629,55 +743,73 @@ The headers will be included in the sequence they are matched.") 'begin 'end)) ((eq in-state 'last) (list 'end)) (t (list 'middle))))) - (t - (let ((name (file-name-nondirectory gnus-uu-saved-article-name)) - beg subj headers headline sorthead body end-string state) - (if (or (eq in-state 'first) - (eq in-state 'first-and-last)) - (progn - (setq state (list 'begin)) - (save-excursion (set-buffer (get-buffer-create "*gnus-uu-body*")) - (erase-buffer)) - (save-excursion - (set-buffer (get-buffer-create "*gnus-uu-pre*")) - (erase-buffer) - (insert (format - "Date: %s\nFrom: %s\nSubject: %s Digest\n\nTopics:\n" - (current-time-string) name name)))) - (if (not (eq in-state 'end)) - (setq state (list 'middle)))) - (save-excursion - (set-buffer (get-buffer "*gnus-uu-body*")) - (goto-char (setq beg (point-max))) - (save-excursion - (save-restriction - (set-buffer buffer) - (goto-char (point-min)) - (re-search-forward "\n\n") - (setq body (buffer-substring (1- (point)) (point-max))) - (narrow-to-region 1 (point)) - (setq headers gnus-uu-digest-headers) - (while headers - (setq headline (car headers)) - (setq headers (cdr headers)) - (goto-char (point-min)) - (if (re-search-forward headline nil t) - (setq sorthead - (concat sorthead - (buffer-substring - (match-beginning 0) - (or (and (re-search-forward "^[^ \t]" nil t) - (1- (point))) - (progn (forward-line 1) (point)))))))) - (widen))) - (insert sorthead)(goto-char (point-max)) - (insert body)(goto-char (point-max)) - (insert (concat "\n" (make-string 30 ?-) "\n\n")) - (goto-char beg) - (if (re-search-forward "^Subject: \\(.*\\)$" nil t) - (progn - (setq subj (buffer-substring (match-beginning 1) (match-end 1))) - (save-excursion + (t + (let ((header (gnus-summary-article-header))) + (setq gnus-uu-digest-from-subject + (cons (cons (mail-header-from header) + (mail-header-subject header)) + gnus-uu-digest-from-subject))) + (let ((name (file-name-nondirectory gnus-uu-saved-article-name)) + (delim (concat "^" (make-string 30 ?-) "$")) + beg subj headers headline sorthead body end-string state) + (if (or (eq in-state 'first) + (eq in-state 'first-and-last)) + (progn + (setq state (list 'begin)) + (save-excursion (set-buffer (get-buffer-create "*gnus-uu-body*")) + (erase-buffer)) + (save-excursion + (set-buffer (get-buffer-create "*gnus-uu-pre*")) + (erase-buffer) + (insert (format + "Date: %s\nFrom: %s\nSubject: %s Digest\n\nTopics:\n" + (current-time-string) name name)))) + (if (not (eq in-state 'end)) + (setq state (list 'middle)))) + (save-excursion + (set-buffer (get-buffer "*gnus-uu-body*")) + (goto-char (setq beg (point-max))) + (save-excursion + (save-restriction + (set-buffer buffer) + (let (buffer-read-only) + (gnus-set-text-properties (point-min) (point-max) nil) + ;; These two are necessary for XEmacs 19.12 fascism. + (put-text-property (point-min) (point-max) 'invisible nil) + (put-text-property (point-min) (point-max) 'intangible nil)) + (goto-char (point-min)) + (re-search-forward "\n\n") + ;; Quote all 30-dash lines. + (save-excursion + (while (re-search-forward delim nil t) + (beginning-of-line) + (delete-char 1) + (insert " "))) + (setq body (buffer-substring (1- (point)) (point-max))) + (narrow-to-region (point-min) (point)) + (if (not (setq headers gnus-uu-digest-headers)) + (setq sorthead (buffer-substring (point-min) (point-max))) + (while headers + (setq headline (car headers)) + (setq headers (cdr headers)) + (goto-char (point-min)) + (while (re-search-forward headline nil t) + (setq sorthead + (concat sorthead + (buffer-substring + (match-beginning 0) + (or (and (re-search-forward "^[^ \t]" nil t) + (1- (point))) + (progn (forward-line 1) (point))))))))) + (widen))) + (insert sorthead) (goto-char (point-max)) + (insert body) (goto-char (point-max)) + (insert (concat "\n" (make-string 30 ?-) "\n\n")) + (goto-char beg) + (if (re-search-forward "^Subject: \\(.*\\)$" nil t) + (progn + (setq subj (buffer-substring (match-beginning 1) (match-end 1))) + (save-excursion (set-buffer (get-buffer "*gnus-uu-pre*")) (insert (format " %s\n" subj)))))) (if (or (eq in-state 'last) @@ -710,7 +842,6 @@ The headers will be included in the sequence they are matched.") "^:...............................................................$") (defconst gnus-uu-binhex-end-line ":$") -(defvar gnus-uu-binhex-article-name nil) (defun gnus-uu-binhex-article (buffer in-state) (let (state start-char) @@ -752,23 +883,21 @@ The headers will be included in the sequence they are matched.") (let ((state (list 'ok)) start-char end-char file-name) (save-excursion - (set-buffer process-buffer) - (goto-char (point-min)) - (if (not (re-search-forward gnus-uu-postscript-begin-string nil t)) - (setq state (list 'wrong-type)) - (beginning-of-line) - (setq start-char (point)) - (if (not (re-search-forward gnus-uu-postscript-end-string nil t)) - (setq state (list 'wrong-type)) - (setq end-char (point)) - (set-buffer (get-buffer-create gnus-uu-output-buffer-name)) - (insert-buffer-substring process-buffer start-char end-char) - (setq file-name (concat gnus-uu-work-dir (cdr gnus-article-current) ".ps")) - (write-region (point-min) (point-max) file-name) - (setq state (list file-name'begin 'end)) - - )) - ) + (set-buffer process-buffer) + (goto-char (point-min)) + (if (not (re-search-forward gnus-uu-postscript-begin-string nil t)) + (setq state (list 'wrong-type)) + (beginning-of-line) + (setq start-char (point)) + (if (not (re-search-forward gnus-uu-postscript-end-string nil t)) + (setq state (list 'wrong-type)) + (setq end-char (point)) + (set-buffer (get-buffer-create gnus-uu-output-buffer-name)) + (insert-buffer-substring process-buffer start-char end-char) + (setq file-name (concat gnus-uu-work-dir + (cdr gnus-article-current) ".ps")) + (write-region (point-min) (point-max) file-name) + (setq state (list file-name 'begin 'end))))) state)) @@ -781,10 +910,11 @@ The headers will be included in the sequence they are matched.") (setq name (cdr (assq 'name (car files)))) (and (setq action (gnus-uu-get-action name)) - (setcar files (nconc (list (cons 'action action) - (cons 'execute (if (string-match "%" action) - (format action name) - (concat action " " name)))) + (setcar files (nconc (list (if (string= action "gnus-uu-archive") + (cons 'action "file") + (cons 'action action)) + (cons 'execute (gnus-uu-command + action name))) (car files)))) (setq files (cdr files))) ofiles)) @@ -815,11 +945,11 @@ The headers will be included in the sequence they are matched.") ;; ignores any leading "version numbers" thingies that they use in ;; the comp.binaries groups, and either replaces anything that looks ;; like "2/3" with "[0-9]+/[0-9]+" or, if it can't find something - ;; like that, replaces the last two numbers with "[0-9]+". This, in + ;; like that, replaces the last two numbers with "[0-9]+". This, in ;; my experience, should get most postings of a series. (let ((count 2) (vernum "v[0-9]+[a-z][0-9]+:") - reg beg) + beg) (save-excursion (set-buffer (get-buffer-create gnus-uu-output-buffer-name)) (buffer-disable-undo (current-buffer)) @@ -865,22 +995,22 @@ The headers will be included in the sequence they are matched.") ;; returned. ;; Failing that, articles that have subjects that are part of the ;; same "series" as the current will be returned. - (let (articles process) - (cond - (n - (let ((backward (< n 0)) - (n (abs n))) - (save-excursion - (while (and (> n 0) - (setq articles (cons (gnus-summary-article-number) - articles)) - (gnus-summary-search-forward nil nil backward)) - (setq n (1- n)))) - (nreverse articles))) - (gnus-newsgroup-processable - (reverse gnus-newsgroup-processable)) - (t - (gnus-uu-find-articles-matching))))) + (let (articles) + (cond + (n + (let ((backward (< n 0)) + (n (abs n))) + (save-excursion + (while (and (> n 0) + (setq articles (cons (gnus-summary-article-number) + articles)) + (gnus-summary-search-forward nil nil backward)) + (setq n (1- n)))) + (nreverse articles))) + (gnus-newsgroup-processable + (reverse gnus-newsgroup-processable)) + (t + (gnus-uu-find-articles-matching))))) (defun gnus-uu-string< (l1 l2) (string< (car l1) (car l2))) @@ -888,31 +1018,32 @@ The headers will be included in the sequence they are matched.") (defun gnus-uu-find-articles-matching (&optional subject only-unread do-not-translate) ;; Finds all articles that matches the regexp SUBJECT. If it is - ;; nil, the current article name will be used. If ONLY-UNREAD is - ;; non-nil, only unread articles are chosen. If DO-NOT-TRANSLATE is + ;; nil, the current article name will be used. If ONLY-UNREAD is + ;; non-nil, only unread articles are chosen. If DO-NOT-TRANSLATE is ;; non-nil, article names are not equalized before sorting. (let ((subject (or subject - (gnus-uu-reginize-string (gnus-summary-subject-string)))) - beg end list-of-subjects) + (gnus-uu-reginize-string (gnus-summary-article-subject)))) + list-of-subjects) (save-excursion (if (not subject) () ;; Collect all subjects matching subject. (let ((case-fold-search t) - subj mark) - (goto-char (point-min)) - (while (not (eobp)) - (and (setq subj (gnus-summary-subject-string)) - (string-match subject subj) + (data gnus-newsgroup-data) + subj mark d) + (while data + (setq d (pop data)) + (and (not (gnus-data-pseudo-p d)) (or (not only-unread) - (= (setq mark (gnus-summary-article-mark)) + (= (setq mark (gnus-data-mark d)) gnus-unread-mark) (= mark gnus-ticked-mark) (= mark gnus-dormant-mark)) + (setq subj (mail-header-subject (gnus-data-header d))) + (string-match subject subj) (setq list-of-subjects - (cons (cons subj (gnus-summary-article-number)) - list-of-subjects))) - (forward-line 1))) + (cons (cons subj (gnus-data-number d)) + list-of-subjects))))) ;; Expand numbers, sort, and return the list of article ;; numbers. @@ -925,17 +1056,17 @@ The headers will be included in the sequence they are matched.") (defun gnus-uu-expand-numbers (string-list &optional translate) ;; Takes a list of strings and "expands" all numbers in all the ;; strings. That is, this function makes all numbers equal length by - ;; prepending lots of zeroes before each number. This is to ease later + ;; prepending lots of zeroes before each number. This is to ease later ;; sorting to find out what sequence the articles are supposed to be - ;; decoded in. Returns the list of expanded strings. + ;; decoded in. Returns the list of expanded strings. (let ((out-list string-list) - string pos num) + string) (save-excursion (set-buffer (get-buffer-create gnus-uu-output-buffer-name)) (buffer-disable-undo (current-buffer)) (while string-list (erase-buffer) - (insert (car (car string-list))) + (insert (caar string-list)) ;; Translate multiple spaces to one space. (goto-char (point-min)) (while (re-search-forward "[ \t]+" nil t) @@ -963,21 +1094,21 @@ The headers will be included in the sequence they are matched.") ;; to apply to each article. ;; ;; The function to be called should take two parameters. The first -;; parameter is the article buffer. The function should leave the -;; result, if any, in this buffer. Most treatment functions will just +;; parameter is the article buffer. The function should leave the +;; result, if any, in this buffer. Most treatment functions will just ;; generate files... ;; ;; The second parameter is the state of the list of articles, and can ;; have four values: `first', `middle', `last' and `first-and-last'. ;; -;; The function should return a list. The list may contain the +;; The function should return a list. The list may contain the ;; following symbols: ;; `error' if an error occurred ;; `begin' if the beginning of an encoded file has been received ;; If the list returned contains a `begin', the first element of ;; the list *must* be a string with the file name of the decoded ;; file. -;; `end' if the the end of an encoded file has been received +;; `end' if the end of an encoded file has been received ;; `middle' if the article was a body part of an encoded file ;; `wrong-type' if the article was not a part of an encoded file ;; `ok', which can be used everything is ok @@ -1004,138 +1135,157 @@ The headers will be included in the sequence they are matched.") ;; ;; This function returns a list of files decoded if the grabbing and ;; the process-function has been successful and nil otherwise. -(defun gnus-uu-grab-articles - (articles process-function &optional sloppy limit no-errors) +(defun gnus-uu-grab-articles (articles process-function + &optional sloppy limit no-errors) (let ((state 'first) - (wrong-type t) - has-been-begin has-been-end - article result-file result-files process-state article-buffer - begin-article) + (gnus-asynchronous nil) + has-been-begin article result-file result-files process-state + gnus-summary-display-article-function + gnus-article-display-hook gnus-article-prepare-hook + article-series files) - (if (not (gnus-server-opened gnus-current-select-method)) - (progn - (gnus-start-news-server) - (gnus-request-group gnus-newsgroup-name))) - - (setq gnus-uu-has-been-grabbed nil) - (while (and articles (not (memq 'error process-state)) (or sloppy (not (memq 'end process-state)))) - (setq article (car articles)) - (setq articles (cdr articles)) - (setq gnus-uu-has-been-grabbed (cons article gnus-uu-has-been-grabbed)) + (setq article (pop articles)) + (push article article-series) - (if (> article gnus-uu-highest-article-number) - (setq gnus-uu-highest-article-number article)) - - (if (eq articles ()) - (if (eq state 'first) - (setq state 'first-and-last) - (setq state 'last))) - - (message "Getting article %d, %s" article (gnus-uu-part-number article)) - - (if (not (= (or gnus-current-article 0) article)) - (progn - (gnus-request-article article gnus-newsgroup-name - nntp-server-buffer) - (setq gnus-last-article gnus-current-article) - (setq gnus-current-article article) - (setq gnus-article-current (cons gnus-newsgroup-name article)) - (if (stringp nntp-server-buffer) - (setq article-buffer nntp-server-buffer) - (setq article-buffer (buffer-name nntp-server-buffer)))) - (setq article-buffer gnus-article-buffer)) - - (buffer-disable-undo article-buffer) - ;; Mark article as read. - (run-hooks 'gnus-mark-article-hook) - (and (memq article gnus-newsgroup-processable) - (gnus-summary-remove-process-mark article)) - - (setq process-state (funcall process-function article-buffer state)) - - (if (or (memq 'begin process-state) - (and (or (eq state 'first) (eq state 'first-and-last)) - (memq 'ok process-state))) - (progn - (if has-been-begin - (if (and result-file (file-exists-p result-file)) - (delete-file result-file))) - (if (memq 'begin process-state) - (setq result-file (car process-state))) - (setq begin-article article) - (setq has-been-begin t) - (setq has-been-end nil))) - - (if (memq 'end process-state) - (progn - (setq gnus-uu-has-been-grabbed nil) - (setq result-files (cons (list (cons 'name result-file) - (cons 'article article)) - result-files)) - (setq has-been-end t) - (setq has-been-begin nil) - (and limit (= (length result-files) limit) - (setq articles nil)))) - - (if (and (or (eq state 'last) (eq state 'first-and-last)) - (not (memq 'end process-state))) - (if (and result-file (file-exists-p result-file)) - (delete-file result-file))) - - (if (not (memq 'wrong-type process-state)) - (setq wrong-type nil) - (if gnus-uu-unmark-articles-not-decoded - (gnus-summary-tick-article article t))) - - (if sloppy (setq wrong-type nil)) + (unless articles + (if (eq state 'first) + (setq state 'first-and-last) + (setq state 'last))) + (let ((part (gnus-uu-part-number article))) + (gnus-message 6 "Getting article %d%s..." + article (if (string= part "") "" (concat ", " part)))) + (gnus-summary-display-article article) + + ;; Push the article to the processing function. + (save-excursion + (set-buffer gnus-original-article-buffer) + (let ((buffer-read-only nil)) + (save-excursion + (set-buffer gnus-summary-buffer) + (setq process-state + (funcall process-function + gnus-original-article-buffer state))))) + + (gnus-summary-remove-process-mark article) + + ;; If this is the beginning of a decoded file, we push it + ;; on to a list. + (when (or (memq 'begin process-state) + (and (or (eq state 'first) + (eq state 'first-and-last)) + (memq 'ok process-state))) + (if has-been-begin + ;; If there is a `result-file' here, that means that the + ;; file was unsuccessfully decoded, so we delete it. + (when (and result-file + (file-exists-p result-file) + (gnus-y-or-n-p + (format "Delete unsuccessfully decoded file %s" + result-file))) + (delete-file result-file))) + (when (memq 'begin process-state) + (setq result-file (car process-state))) + (setq has-been-begin t)) + + ;; Check whether we have decoded one complete file. + (when (memq 'end process-state) + (setq article-series nil) + (setq has-been-begin nil) + (if (stringp result-file) + (setq files (list result-file)) + (setq files result-file)) + (setq result-file (car files)) + (while files + (push (list (cons 'name (pop files)) + (cons 'article article)) + result-files)) + ;; Allow user-defined functions to be run on this file. + (when gnus-uu-grabbed-file-functions + (let ((funcs gnus-uu-grabbed-file-functions)) + (unless (listp funcs) + (setq funcs (list funcs))) + (while funcs + (funcall (pop funcs) result-file)))) + (setq result-file nil) + ;; Check whether we have decoded enough articles. + (and limit (= (length result-files) limit) + (setq articles nil))) + + ;; If this is the last article to be decoded, and + ;; we still haven't reached the end, then we delete + ;; the partially decoded file. + (and (or (eq state 'last) (eq state 'first-and-last)) + (not (memq 'end process-state)) + result-file + (file-exists-p result-file) + (gnus-y-or-n-p (format "Delete incomplete file %s? " result-file)) + (delete-file result-file)) + + ;; If this was a file of the wrong sort, then + (when (and (or (memq 'wrong-type process-state) + (memq 'error process-state)) + gnus-uu-unmark-articles-not-decoded) + (gnus-summary-tick-article article t)) + + ;; Set the new series state. (if (and (not has-been-begin) (not sloppy) (or (memq 'end process-state) (memq 'middle process-state))) (progn (setq process-state (list 'error)) - (message "No begin part at the beginning") + (gnus-message 2 "No begin part at the beginning") (sleep-for 2)) (setq state 'middle))) - ;; Make sure the last article is put in the article buffer & fix - ;; windows etc. - - (if (not (string= article-buffer gnus-article-buffer)) - (save-excursion - (set-buffer (get-buffer-create gnus-article-buffer)) - (let ((buffer-read-only nil)) - (widen) - (erase-buffer) - (insert-buffer-substring article-buffer) - (goto-char (point-min))))) - + ;; When there are no result-files, then something must be wrong. (if result-files - () - (if (not has-been-begin) - (if (not no-errors) (message "Wrong type file")) - (if (memq 'error process-state) - (setq result-files nil) - (if (not (or (memq 'ok process-state) - (memq 'end process-state))) - (progn - (if (not no-errors) - (message "End of articles reached before end of file")) - (setq result-files nil)) - (gnus-uu-unmark-list-of-grabbed))))) + (message "") + (cond + ((not has-been-begin) + (gnus-message 2 "Wrong type file")) + ((memq 'error process-state) + (gnus-message 2 "An error occurred during decoding")) + ((not (or (memq 'ok process-state) + (memq 'end process-state))) + (gnus-message 2 "End of articles reached before end of file"))) + ;; Make unsuccessfully decoded articles unread. + (when gnus-uu-unmark-articles-not-decoded + (while article-series + (gnus-summary-tick-article (pop article-series) t)))) + result-files)) +(defun gnus-uu-grab-view (file) + "View FILE using the gnus-uu methods." + (let ((action (gnus-uu-get-action file))) + (gnus-execute-command + (if (string-match "%" action) + (format action file) + (concat action " " file)) + (eq gnus-view-pseudos 'not-confirm)))) + +(defun gnus-uu-grab-move (file) + "Move FILE to somewhere." + (when gnus-uu-default-dir + (let ((to-file (concat (file-name-as-directory gnus-uu-default-dir) + (file-name-nondirectory file)))) + (rename-file file to-file) + (unless (file-exists-p file) + (make-symbolic-link to-file file))))) + (defun gnus-uu-part-number (article) - (let ((subject (header-subject (gnus-get-header-by-number article)))) - (if (string-match "[0-9]+ */[0-9]+\\|[0-9]+ * of *[0-9]+" - subject) - (substring subject (match-beginning 0) (match-end 0)) + (let* ((header (gnus-summary-article-header article)) + (subject (and header (mail-header-subject header)))) + (if (and subject + (string-match "[0-9]+ */[0-9]+\\|[0-9]+ * of *[0-9]+" subject)) + (match-string 0 subject) ""))) (defun gnus-uu-uudecode-sentinel (process event) @@ -1143,112 +1293,106 @@ The headers will be included in the sequence they are matched.") (defun gnus-uu-uustrip-article (process-buffer in-state) ;; Uudecodes a file asynchronously. - (let ((state (list 'ok)) - (process-connection-type nil) - start-char pst name-beg name-end) - (save-excursion - (set-buffer process-buffer) - (let ((case-fold-search nil) - (buffer-read-only nil)) + (save-excursion + (set-buffer process-buffer) + (let ((state (list 'wrong-type)) + process-connection-type case-fold-search buffer-read-only + files start-char) + (goto-char (point-min)) - (goto-char (point-min)) + ;; Deal with ^M at the end of the lines. + (when gnus-uu-kill-carriage-return + (save-excursion + (while (search-forward "\r" nil t) + (delete-backward-char 1)))) - (if gnus-uu-kill-carriage-return - (progn - (while (search-forward "\r" nil t) - (delete-backward-char 1)) - (goto-char (point-min)))) - - (if (not (re-search-forward gnus-uu-begin-string nil t)) - (if (not (re-search-forward gnus-uu-body-line nil t)) - (setq state (list 'wrong-type)))) - - (if (memq 'wrong-type state) - () - (beginning-of-line) - (setq start-char (point)) - - (if (looking-at gnus-uu-begin-string) - (progn - (setq name-end (match-end 1)) - - ; Replace any slashes and spaces in file names before decoding - (goto-char (setq name-beg (match-beginning 1))) - (while (re-search-forward "/" name-end t) - (replace-match ",")) - (goto-char name-beg) - (while (re-search-forward " " name-end t) - (replace-match "_")) - (goto-char name-beg) - (if (re-search-forward "_*$" name-end t) - (replace-match "")) - - (setq gnus-uu-file-name (buffer-substring name-beg name-end)) - (and gnus-uu-uudecode-process - (setq pst (process-status - (or gnus-uu-uudecode-process "nevair"))) - (if (or (eq pst 'stop) (eq pst 'run)) - (progn - (delete-process gnus-uu-uudecode-process) - (gnus-uu-unmark-list-of-grabbed t)))) - (if (get-process "*uudecode*") - (delete-process "*uudecode*")) - (setq gnus-uu-uudecode-process - (start-process - "*uudecode*" - (get-buffer-create gnus-uu-output-buffer-name) - "sh" "-c" - (format "cd %s ; uudecode" gnus-uu-work-dir))) - (set-process-sentinel - gnus-uu-uudecode-process 'gnus-uu-uudecode-sentinel) - (setq state (list 'begin)) - (gnus-uu-add-file (concat gnus-uu-work-dir gnus-uu-file-name))) - (setq state (list 'middle))) - - (goto-char (point-max)) + (while (or (re-search-forward gnus-uu-begin-string nil t) + (re-search-forward gnus-uu-body-line nil t)) + (setq state (list 'ok)) + ;; Ok, we are at the first uucoded line. + (beginning-of-line) + (setq start-char (point)) - (re-search-backward - (concat gnus-uu-body-line "\\|" gnus-uu-end-string) nil t) - (beginning-of-line) + (if (not (looking-at gnus-uu-begin-string)) + (setq state (list 'middle)) + ;; This is the beginning of an uuencoded article. + ;; We replace certain characters that could make things messy. + (setq gnus-uu-file-name + (let ((nnheader-file-name-translation-alist + '((?/ . ?,) (? . ?_) (?* . ?_) (?$ . ?_)))) + (nnheader-translate-file-chars (match-string 1)))) - (if (looking-at gnus-uu-end-string) - (setq state (cons 'end state))) + ;; Remove any non gnus-uu-body-line right after start. (forward-line 1) + (while (and (not (eobp)) + (not (looking-at gnus-uu-body-line))) + (gnus-delete-line)) + + ;; If a process is running, we kill it. + (when (and gnus-uu-uudecode-process + (memq (process-status gnus-uu-uudecode-process) + '(run stop))) + (delete-process gnus-uu-uudecode-process) + (gnus-uu-unmark-list-of-grabbed t)) + + ;; Start a new uudecoding process. + (let ((cdir default-directory)) + (unwind-protect + (progn + (cd gnus-uu-work-dir) + (setq gnus-uu-uudecode-process + (start-process + "*uudecode*" + (get-buffer-create gnus-uu-output-buffer-name) + shell-file-name shell-command-switch + (format "cd %s %s uudecode" gnus-uu-work-dir + gnus-shell-command-separator)))) + (cd cdir))) + (set-process-sentinel + gnus-uu-uudecode-process 'gnus-uu-uudecode-sentinel) + (setq state (list 'begin)) + (push (concat gnus-uu-work-dir gnus-uu-file-name) files)) + + ;; We look for the end of the thing to be decoded. + (if (re-search-forward gnus-uu-end-string nil t) + (setq state (cons 'end state)) + (goto-char (point-max)) + (re-search-backward gnus-uu-body-line nil t)) + + (forward-line 1) - (and gnus-uu-uudecode-process - (setq pst (process-status - (or gnus-uu-uudecode-process "nevair"))) - (if (or (eq pst 'run) (eq pst 'stop)) - (progn - (if gnus-uu-correct-stripped-uucode - (progn - (gnus-uu-check-correct-stripped-uucode - start-char (point)) - (goto-char (point-max)) - (re-search-backward - (concat gnus-uu-body-line "\\|" - gnus-uu-end-string) - nil t) - (forward-line 1))) - - (condition-case err - (process-send-region gnus-uu-uudecode-process - start-char (point)) - (error - (progn - (delete-process gnus-uu-uudecode-process) - (message "gnus-uu: Couldn't uudecode") -; (sleep-for 2) - (setq state (list 'wrong-type))))) - - (if (memq 'end state) - (accept-process-output gnus-uu-uudecode-process))) - (setq state (list 'wrong-type)))) - (if (not gnus-uu-uudecode-process) - (setq state (list 'wrong-type))))) + (when gnus-uu-uudecode-process + (when (memq (process-status gnus-uu-uudecode-process) '(run stop)) + ;; Try to correct mishandled uucode. + (when gnus-uu-correct-stripped-uucode + (gnus-uu-check-correct-stripped-uucode start-char (point))) + + ;; Send the text to the process. + (condition-case nil + (process-send-region + gnus-uu-uudecode-process start-char (point)) + (error + (progn + (delete-process gnus-uu-uudecode-process) + (gnus-message 2 "gnus-uu: Couldn't uudecode") + (setq state (list 'wrong-type))))) + + (if (memq 'end state) + (progn + ;; Send an EOF, just in case. + (condition-case () + (process-send-eof gnus-uu-uudecode-process) + (error nil)) + (while (memq (process-status gnus-uu-uudecode-process) + '(open run)) + (accept-process-output gnus-uu-uudecode-process 1))) + (when (or (not gnus-uu-uudecode-process) + (not (memq (process-status gnus-uu-uudecode-process) + '(run stop)))) + (setq state (list 'wrong-type))))))) (if (memq 'begin state) - (cons (concat gnus-uu-work-dir gnus-uu-file-name) state) + (cons (if (= (length files) 1) (car files) files) state) state)))) ;; This function is used by `gnus-uu-grab-articles' to treat @@ -1257,16 +1401,18 @@ The headers will be included in the sequence they are matched.") (let ((state (list 'ok)) start-char) (save-excursion - (set-buffer process-buffer) - (goto-char (point-min)) - (if (not (re-search-forward gnus-uu-shar-begin-string nil t)) - (setq state (list 'wrong-type)) - (beginning-of-line) - (setq start-char (point)) - (call-process-region - start-char (point-max) "sh" nil - (get-buffer-create gnus-uu-output-buffer-name) nil - "-c" (concat "cd " gnus-uu-work-dir " ; sh")))) + (set-buffer process-buffer) + (goto-char (point-min)) + (if (not (re-search-forward gnus-uu-shar-begin-string nil t)) + (setq state (list 'wrong-type)) + (beginning-of-line) + (setq start-char (point)) + (call-process-region + start-char (point-max) shell-file-name nil + (get-buffer-create gnus-uu-output-buffer-name) nil + shell-command-switch + (concat "cd " gnus-uu-work-dir " " + gnus-shell-command-separator " sh")))) state)) ;; Returns the name of what the shar file is going to unpack. @@ -1284,6 +1430,7 @@ The headers will be included in the sequence they are matched.") ;; found, or the name of the command to run if such a rule is found. (defun gnus-uu-choose-action (file-name file-action-list &optional no-ignore) (let ((action-list (copy-sequence file-action-list)) + (case-fold-search t) rule action) (and (or no-ignore @@ -1300,13 +1447,13 @@ The headers will be included in the sequence they are matched.") (setq rule (car action-list)) (setq action-list (cdr action-list)) (if (string-match (car rule) file-name) - (setq action (car (cdr rule)))))) + (setq action (cadr rule))))) action)) (defun gnus-uu-treat-archive (file-path) - ;; Unpacks an archive. Returns t if unpacking is successful. + ;; Unpacks an archive. Returns t if unpacking is successful. (let ((did-unpack t) - action command files file file-name dir) + action command dir) (setq action (gnus-uu-choose-action file-path (append gnus-uu-user-archive-rules (if gnus-uu-ignore-default-archive-rules @@ -1316,7 +1463,6 @@ The headers will be included in the sequence they are matched.") (if (not action) (error "No unpackers for the file %s" file-path)) (string-match "/[^/]*$" file-path) - (setq file-name (substring file-path (1+ (match-beginning 0)))) (setq dir (substring file-path 0 (match-beginning 0))) (if (member action gnus-uu-destructive-archivers) @@ -1328,13 +1474,13 @@ The headers will be included in the sequence they are matched.") (set-buffer (get-buffer-create gnus-uu-output-buffer-name)) (erase-buffer)) - (message "Unpacking: %s..." (gnus-uu-command action file-path)) + (gnus-message 5 "Unpacking: %s..." (gnus-uu-command action file-path)) - (if (= 0 (call-process "sh" nil + (if (= 0 (call-process shell-file-name nil (get-buffer-create gnus-uu-output-buffer-name) - nil "-c" command)) + nil shell-command-switch command)) (message "") - (message "Error during unpacking of archive") + (gnus-message 2 "Error during unpacking of archive") (setq did-unpack nil)) (if (member action gnus-uu-destructive-archivers) @@ -1365,7 +1511,7 @@ The headers will be included in the sequence they are matched.") (progn (setq did-unpack (cons file did-unpack)) (or (gnus-uu-treat-archive file) - (message "Error during unpacking of %s" file)) + (gnus-message 2 "Error during unpacking of %s" file)) (let* ((newfiles (gnus-uu-ls-r gnus-uu-work-dir)) (nfiles newfiles)) (while nfiles @@ -1399,108 +1545,87 @@ The headers will be included in the sequence they are matched.") (while files (setq file (car files)) (setq files (cdr files)) - (or (string-match "/\\.\\.?$" file) + (or (member (file-name-nondirectory file) '("." "..")) (setq out (cons file out)))) (setq out (nreverse out)) out)) (defun gnus-uu-check-correct-stripped-uucode (start end) - (let (found beg length short) - (if (not gnus-uu-correct-stripped-uucode) - () - (goto-char start) + (save-excursion + (let (found beg length) + (if (not gnus-uu-correct-stripped-uucode) + () + (goto-char start) - (if (re-search-forward " \\|`" end t) - (progn - (goto-char start) - (while (not (eobp)) - (progn - (if (looking-at "\n") (replace-match "")) - (forward-line 1)))) - - (while (not (eobp)) - (if (looking-at (concat gnus-uu-begin-string "\\|" - gnus-uu-end-string)) - () - (if (not found) + (if (re-search-forward " \\|`" end t) + (progn + (goto-char start) + (while (not (eobp)) (progn - (beginning-of-line) - (setq beg (point)) - (end-of-line) - (setq length (- (point) beg)))) - (setq found t) - (beginning-of-line) - (setq beg (point)) - (end-of-line) - (if (not (= length (- (point) beg))) - (insert (make-string (- length (- (point) beg)) ? )))) - (forward-line 1)))))) - -(defun gnus-uu-initialize () - (setq gnus-uu-highest-article-number 1) - (gnus-uu-check-for-generated-files) - (setq gnus-uu-tmp-dir (expand-file-name gnus-uu-tmp-dir)) - (if (string-match "[^/]$" gnus-uu-tmp-dir) - (setq gnus-uu-tmp-dir (concat gnus-uu-tmp-dir "/"))) - (if (not (file-directory-p gnus-uu-tmp-dir)) - (error "Temp directory %s doesn't exist" gnus-uu-tmp-dir) - (if (not (file-writable-p gnus-uu-tmp-dir)) - (error "Temp directory %s can't be written to" gnus-uu-tmp-dir))) - (setq gnus-uu-work-dir - (concat gnus-uu-tmp-dir (make-temp-name "gnus"))) - (gnus-uu-add-file gnus-uu-work-dir) - (if (not (file-directory-p gnus-uu-work-dir)) - (make-directory gnus-uu-work-dir)) - (set-file-modes gnus-uu-work-dir 448) - (setq gnus-uu-work-dir (concat gnus-uu-work-dir "/"))) + (if (looking-at "\n") (replace-match "")) + (forward-line 1)))) + + (while (not (eobp)) + (if (looking-at (concat gnus-uu-begin-string "\\|" + gnus-uu-end-string)) + () + (if (not found) + (progn + (beginning-of-line) + (setq beg (point)) + (end-of-line) + (setq length (- (point) beg)))) + (setq found t) + (beginning-of-line) + (setq beg (point)) + (end-of-line) + (if (not (= length (- (point) beg))) + (insert (make-string (- length (- (point) beg)) ? )))) + (forward-line 1))))))) + +(defvar gnus-uu-tmp-alist nil) + +(defun gnus-uu-initialize (&optional scan) + (let (entry) + (if (and (not scan) + (if (setq entry (assoc gnus-newsgroup-name gnus-uu-tmp-alist)) + (if (file-exists-p (cdr entry)) + (setq gnus-uu-work-dir (cdr entry)) + (setq gnus-uu-tmp-alist (delq entry gnus-uu-tmp-alist)) + nil))) + t + (setq gnus-uu-tmp-dir (file-name-as-directory + (expand-file-name gnus-uu-tmp-dir))) + (if (not (file-directory-p gnus-uu-tmp-dir)) + (error "Temp directory %s doesn't exist" gnus-uu-tmp-dir) + (if (not (file-writable-p gnus-uu-tmp-dir)) + (error "Temp directory %s can't be written to" + gnus-uu-tmp-dir))) + + (setq gnus-uu-work-dir + (make-temp-name (concat gnus-uu-tmp-dir "gnus"))) + (gnus-make-directory gnus-uu-work-dir) + (set-file-modes gnus-uu-work-dir 448) + (setq gnus-uu-work-dir (file-name-as-directory gnus-uu-work-dir)) + (setq gnus-uu-tmp-alist (cons (cons gnus-newsgroup-name gnus-uu-work-dir) + gnus-uu-tmp-alist))))) + ;; Kills the temporary uu buffers, kills any processes, etc. (defun gnus-uu-clean-up () - (let (buf pst) + (let (buf) (and gnus-uu-uudecode-process - (setq pst (process-status (or gnus-uu-uudecode-process "nevair"))) - (if (or (eq pst 'stop) (eq pst 'run)) - (delete-process gnus-uu-uudecode-process))) + (memq (process-status (or gnus-uu-uudecode-process "nevair")) + '(stop run)) + (delete-process gnus-uu-uudecode-process)) (and (setq buf (get-buffer gnus-uu-output-buffer-name)) (kill-buffer buf)))) -;; `gnus-uu-check-for-generated-files' deletes any generated files that -;; hasn't been deleted, if, for instance, the user terminated decoding -;; with `C-g'. -(defun gnus-uu-check-for-generated-files () - (let (file dirs) - (while gnus-uu-generated-file-list - (setq file (car gnus-uu-generated-file-list)) - (setq gnus-uu-generated-file-list (cdr gnus-uu-generated-file-list)) - (if (not (string-match "/\\.[\\.]?$" file)) - (progn - (if (file-directory-p file) - (setq dirs (cons file dirs)) - (if (file-exists-p file) - (delete-file file)))))) - (setq dirs (nreverse dirs)) - (while dirs - (setq file (car dirs)) - (setq dirs (cdr dirs)) - (if (file-directory-p file) - (if (string-match "/$" file) - (delete-directory (substring file 0 (match-beginning 0))) - (delete-directory file)))))) - -;; Add a file (or a list of files) to be checked (and deleted if it/they -;; still exists upon exiting the newsgroup). -(defun gnus-uu-add-file (file) - (if (stringp file) - (setq gnus-uu-generated-file-list - (cons file gnus-uu-generated-file-list)) - (setq gnus-uu-generated-file-list - (append file gnus-uu-generated-file-list)))) - ;; Inputs an action and a file and returns a full command, putting -;; ticks round the file name and escaping any ticks in the file name. +;; quotes round the file name and escaping any quotes in the file name. (defun gnus-uu-command (action file) (let ((ofile "")) - (while (string-match "`\\|\"\\|\\$\\|\\\\" file) + (while (string-match "!\\|`\\|\"\\|\\$\\|\\\\\\|&" file) (progn (setq ofile (concat ofile (substring file 0 (match-beginning 0)) "\\" @@ -1511,11 +1636,28 @@ The headers will be included in the sequence they are matched.") (format action ofile) (concat action " " ofile)))) +(defun gnus-uu-delete-work-dir (&optional dir) + "Delete recursively all files and directories under `gnus-uu-work-dir'." + (if dir + (gnus-message 7 "Deleting directory %s..." dir) + (setq dir gnus-uu-work-dir)) + (when (and dir + (file-exists-p dir)) + (let ((files (directory-files dir t nil t)) + file) + (while (setq file (pop files)) + (unless (member (file-name-nondirectory file) '("." "..")) + (if (file-directory-p file) + (gnus-uu-delete-work-dir file) + (gnus-message 9 "Deleting file %s..." file) + (delete-file file)))) + (delete-directory dir))) + (gnus-message 7 "")) ;; Initializing (add-hook 'gnus-exit-group-hook 'gnus-uu-clean-up) -(add-hook 'gnus-exit-group-hook 'gnus-uu-check-for-generated-files) +(add-hook 'gnus-exit-group-hook 'gnus-uu-delete-work-dir) @@ -1523,11 +1665,8 @@ The headers will be included in the sequence they are matched.") ;;; uuencoded posting ;;; -(require 'sendmail) -(require 'rnews) - ;; Any function that is to be used as and encoding method will take two -;; parameters: PATH-NAME and FILE-NAME. (E.g. "/home/gaga/spiral.jpg" +;; parameters: PATH-NAME and FILE-NAME. (E.g. "/home/gaga/spiral.jpg" ;; and "spiral.jpg", respectively.) The function should return nil if ;; the encoding wasn't successful. (defvar gnus-uu-post-encode-method 'gnus-uu-post-encode-uuencode @@ -1541,7 +1680,7 @@ uuencode and adds MIME headers.") (defvar gnus-uu-post-include-before-composing nil "Non-nil means that gnus-uu will ask for a file to encode before you compose the article. If this variable is t, you can either include an encoded file with -\\\\[gnus-uu-post-insert-binary-in-article] or have one included for you when you post the article.") +\\[gnus-uu-post-insert-binary-in-article] or have one included for you when you post the article.") (defvar gnus-uu-post-length 990 "Maximum length of an article. @@ -1551,18 +1690,18 @@ post the entire file.") (defvar gnus-uu-post-threaded nil "Non-nil means that gnus-uu will post the encoded file in a thread. This may not be smart, as no other decoder I have seen are able to -follow threads when collecting uuencoded articles. (Well, I have seen +follow threads when collecting uuencoded articles. (Well, I have seen one package that does that - gnus-uu, but somehow, I don't think that counts...) Default is nil.") (defvar gnus-uu-post-separate-description t "Non-nil means that the description will be posted in a separate article. -The first article will typically be numbered (0/x). If this variable +The first article will typically be numbered (0/x). If this variable is nil, the description the user enters will be included at the -beginning of the first article, which will be numbered (1/x). Default +beginning of the first article, which will be numbered (1/x). Default is t.") -(defconst gnus-uu-post-binary-separator "--binary follows this line--") +(defvar gnus-uu-post-binary-separator "--binary follows this line--") (defvar gnus-uu-post-message-id nil) (defvar gnus-uu-post-inserted-file-name nil) (defvar gnus-uu-winconf-post-news nil) @@ -1577,7 +1716,6 @@ is t.") (use-local-map (copy-keymap (current-local-map))) (local-set-key "\C-c\C-c" 'gnus-summary-edit-article-done) - (local-set-key "\C-c\C-f\C-a" 'gnus-uu-post-reply-summary) (local-set-key "\C-c\C-c" 'gnus-uu-post-news-inews) (local-set-key "\C-c\C-s" 'gnus-uu-post-news-inews) (local-set-key "\C-c\C-i" 'gnus-uu-post-insert-binary-in-article) @@ -1590,8 +1728,6 @@ is t.") "Inserts an encoded file in the buffer. The user will be asked for a file name." (interactive) - (if (not (eq (current-buffer) (get-buffer gnus-post-news-buffer))) - (error "Not in post-news buffer")) (save-excursion (setq gnus-uu-post-inserted-file-name (gnus-uu-post-insert-binary)))) @@ -1627,7 +1763,7 @@ The user will be asked for a file name." file-name)) (insert (format "Content-Transfer-Encoding: %s\n\n" encoding)) (save-restriction - (set-buffer gnus-post-news-buffer) + (set-buffer gnus-message-buffer) (goto-char (point-min)) (re-search-forward (concat "^" (regexp-quote mail-header-separator) "$")) (forward-line -1) @@ -1641,15 +1777,13 @@ The user will be asked for a file name." ;; Encodes a file PATH with COMMAND, leaving the result in the ;; current buffer. (defun gnus-uu-post-encode-file (command path file-name) - (= 0 (call-process "sh" nil t nil "-c" + (= 0 (call-process shell-file-name nil t nil shell-command-switch (format "%s %s %s" command path file-name)))) (defun gnus-uu-post-news-inews () "Posts the composed news article and encoded file. If no file has been included, the user will be asked for a file." (interactive) - (if (not (eq (current-buffer) (get-buffer gnus-post-news-buffer))) - (error "Not in post news buffer")) (let (file-name) @@ -1658,11 +1792,11 @@ If no file has been included, the user will be asked for a file." (setq file-name (gnus-uu-post-insert-binary))) (if gnus-uu-post-threaded - (let ((gnus-required-headers - (if (memq 'Message-ID gnus-required-headers) - gnus-required-headers - (cons 'Message-ID gnus-required-headers))) - gnus-inews-article-hook elem) + (let ((message-required-news-headers + (if (memq 'Message-ID message-required-news-headers) + message-required-news-headers + (cons 'Message-ID message-required-news-headers))) + gnus-inews-article-hook) (setq gnus-inews-article-hook (if (listp gnus-inews-article-hook) gnus-inews-article-hook @@ -1685,10 +1819,10 @@ If no file has been included, the user will be asked for a file." (set-window-configuration gnus-uu-winconf-post-news))) ;; Asks for a file to encode, encodes it and inserts the result in -;; the current buffer. Returns the file name the user gave. +;; the current buffer. Returns the file name the user gave. (defun gnus-uu-post-insert-binary () (let ((uuencode-buffer-name "*uuencode buffer*") - file-path post-buf uubuf file-name) + file-path uubuf file-name) (setq file-path (read-file-name "What file do you want to encode? ")) @@ -1710,7 +1844,7 @@ If no file has been included, the user will be asked for a file." (get-buffer-create uuencode-buffer-name))) (erase-buffer) (funcall gnus-uu-post-encode-method file-path file-name)) - (insert-buffer uubuf) + (insert-buffer-substring uubuf) (error "Encoding unsuccessful")) (kill-buffer uubuf)) file-name)) @@ -1721,7 +1855,7 @@ If no file has been included, the user will be asked for a file." (encoded-buffer-name "*encoded buffer*") (top-string "[ cut here %s (%s %d/%d) %s gnus-uu ]") (separator (concat mail-header-separator "\n\n")) - file uubuf length parts header i end beg + uubuf length parts header i end beg beg-line minlen buf post-buf whole-len beg-binary end-binary) (setq post-buf (current-buffer)) @@ -1765,7 +1899,7 @@ If no file has been included, the user will be asked for a file." (progn (end-of-line) (insert (format " (0/%d)" parts)))) - (gnus-inews-news)) + (message-send)) (save-excursion (setq i 1) @@ -1828,7 +1962,8 @@ If no file has been included, the user will be asked for a file." (forward-line 1))) (insert beg-line) (insert "\n") - (gnus-inews-news))) + (let (message-sent-message-via) + (message-send)))) (and (setq buf (get-buffer send-buffer-name)) (kill-buffer buf))