Mercurial > hg > xemacs-beta
diff lisp/gnus/gnus-uu.el @ 70:131b0175ea99 r20-0b30
Import from CVS: tag r20-0b30
| author | cvs |
|---|---|
| date | Mon, 13 Aug 2007 09:02:59 +0200 |
| parents | e04119814345 |
| children | 0d2f883870bc |
line wrap: on
line diff
--- a/lisp/gnus/gnus-uu.el Mon Aug 13 09:00:04 2007 +0200 +++ b/lisp/gnus/gnus-uu.el Mon Aug 13 09:02:59 2007 +0200 @@ -1,5 +1,5 @@ ;;; gnus-uu.el --- extract (uu)encoded files in Gnus -;; Copyright (C) 1985,86,87,93,94,95,96,97 Free Software Foundation, Inc. +;; Copyright (C) 1985,86,87,93,94,95,96 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> ;; Created: 2 Oct 1993 @@ -24,40 +24,21 @@ ;;; Commentary: -;;; Code: +;;; Code: (require 'gnus) -(require 'gnus-art) -(require 'message) (require 'gnus-msg) - -(defgroup gnus-extract nil - "Extracting encoded files." - :prefix "gnus-uu-" - :group 'gnus) - -(defgroup gnus-extract-view nil - "Viewwing extracted files." - :group 'gnus-extract) - -(defgroup gnus-extract-archive nil - "Extracting encoded archives." - :group 'gnus-extract) - -(defgroup gnus-extract-post nil - "Extracting encoded archives." - :prefix "gnus-uu-post" - :group 'gnus-extract) +(eval-when-compile (require 'cl)) ;; Default viewing action rules -(defcustom gnus-uu-default-view-rules +(defvar gnus-uu-default-view-rules '(("\\.te?xt$\\|\\.doc$\\|read.*me\\|\\.c?$\\|\\.h$\\|\\.bat$\\|\\.asm$\\|makefile" "cat %s | sed s/\r//g") ("\\.pas$" "cat %s | sed s/\r//g") ("\\.[1-9]$" "groff -mandoc -Tascii %s | sed s/\b.//g") ("\\.\\(jpe?g\\|gif\\|tiff?\\|p[pgb]m\\|xwd\\|xbm\\|pcx\\)$" "xv") ("\\.tga$" "tgatoppm %s | xv -") - ("\\.\\(wav\\|aiff\\|hcom\\|u[blw]\\|s[bfw]\\|voc\\|smp\\)$" + ("\\.\\(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") @@ -67,9 +48,9 @@ ("\\.html$" "xmosaic") ("\\.mpe?g$" "mpeg_play") ("\\.\\(flc\\|fli\\|rle\\|iff\\|pfx\\|avi\\|sme\\|rpza\\|dl\\|qt\\|rsrc\\|mov\\)$" "xanim") - ("\\.\\(tar\\|arj\\|zip\\|zoo\\|arc\\|gz\\|Z\\|lzh\\|ar\\|lha\\)$" + ("\\.\\(tar\\|arj\\|zip\\|zoo\\|arc\\|gz\\|Z\\|lzh\\|ar\\|lha\\)$" "gnus-uu-archive")) - "Default actions to be taken when the user asks to view a file. + "*Default actions to be taken when the user asks to view a file. To change the behaviour, you can either edit this variable or set `gnus-uu-user-view-rules' to something useful. @@ -80,44 +61,38 @@ (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 variable 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." - :group 'gnus-extract-view - :type '(repeat (group regexp (string :tag "Command")))) +match.") -(defcustom gnus-uu-user-view-rules nil - "What actions are to be taken to view a file. -See the documentation on the `gnus-uu-default-view-rules' variable for -details." - :group 'gnus-extract-view - :type '(repeat (group regexp (string :tag "Command")))) +(defvar gnus-uu-user-view-rules nil + "*Variable detailing what actions are to be taken to view a file. +See the documentation on the `gnus-uu-default-view-rules' variable for +details.") -(defcustom gnus-uu-user-view-rules-end +(defvar gnus-uu-user-view-rules-end '(("" "file")) - "What actions are to be taken if no rule matched the file name. -See the documentation on the `gnus-uu-default-view-rules' variable for -details." - :group 'gnus-extract-view - :type '(repeat (group regexp (string :tag "Command")))) + "*Variable saying what actions are to be taken if no rule matched the file name. +See the documentation on the `gnus-uu-default-view-rules' variable for +details.") ;; Default unpacking commands -(defcustom gnus-uu-default-archive-rules +(defvar gnus-uu-default-archive-rules '(("\\.tar$" "tar xf") ("\\.zip$" "unzip -o") ("\\.ar$" "ar x") @@ -126,49 +101,38 @@ ("\\.\\(lzh\\|lha\\)$" "lha x") ("\\.Z$" "uncompress") ("\\.gz$" "gunzip") - ("\\.arc$" "arc -x")) - "See `gnus-uu-user-archive-rules'." - :group 'gnus-extract-archive - :type '(repeat (group regexp (string :tag "Command")))) + ("\\.arc$" "arc -x"))) -(defvar gnus-uu-destructive-archivers +(defvar gnus-uu-destructive-archivers (list "uncompress" "gunzip")) -(defcustom gnus-uu-user-archive-rules nil - "A list that can be set to override the default archive unpacking commands. +(defvar gnus-uu-user-archive-rules nil + "*A list that can be set to override the default archive unpacking commands. To use, for instance, 'untar' to unpack tar files and 'zip -x' to unpack zip files, say the following: - (setq gnus-uu-user-archive-rules + (setq gnus-uu-user-archive-rules '((\"\\\\.tar$\" \"untar\") - (\"\\\\.zip$\" \"zip -x\")))" - :group 'gnus-extract-archive - :type '(repeat (group regexp (string :tag "Command")))) + (\"\\\\.zip$\" \"zip -x\")))") -(defcustom gnus-uu-ignore-files-by-name nil +(defvar gnus-uu-ignore-files-by-name nil "*A regular expression saying what files should not be viewed based on name. -If, for instance, you want gnus-uu to ignore all .au and .wav files, +If, for instance, you want gnus-uu to ignore all .au and .wav files, you could say something like (setq gnus-uu-ignore-files-by-name \"\\\\.au$\\\\|\\\\.wav$\") Note that this variable can be used in conjunction with the -`gnus-uu-ignore-files-by-type' variable." - :group 'gnus-extract - :type '(choice (const :tag "off" nil) - (regexp :format "%v"))) +`gnus-uu-ignore-files-by-type' variable.") -(defcustom gnus-uu-ignore-files-by-type nil +(defvar gnus-uu-ignore-files-by-type nil "*A regular expression saying what files that shouldn't be viewed, based on MIME file type. -If, for instance, you want gnus-uu to ignore all audio files and all mpegs, +If, for instance, you want gnus-uu to ignore all audio files and all mpegs, you could say something like (setq gnus-uu-ignore-files-by-type \"audio/\\\\|video/mpeg\") Note that this variable can be used in conjunction with the -`gnus-uu-ignore-files-by-name' variable." - :group 'gnus-extract - :type '(choice (const :tag "off" nil) - (regexp :format "%v"))) +`gnus-uu-ignore-files-by-name' variable.") ;; Pseudo-MIME support @@ -211,97 +175,63 @@ ("\\.rsrc$" "video/rsrc") ("\\..*$" "unknown/unknown"))) -;; Various variables users may set +;; Various variables users may set -(defcustom gnus-uu-tmp-dir "/tmp/" +(defvar gnus-uu-tmp-dir "/tmp/" "*Variable saying where gnus-uu is to do its work. -Default is \"/tmp/\"." - :group 'gnus-extract - :type 'directory) +Default is \"/tmp/\".") -(defcustom gnus-uu-do-not-unpack-archives nil - "*Non-nil means that gnus-uu won't peek inside archives looking for files to display. -Default is nil." - :group 'gnus-extract-archive - :type 'boolean) +(defvar gnus-uu-do-not-unpack-archives nil + "*Non-nil means that gnus-uu won't peek inside archives looking for files to display. +Default is nil.") -(defcustom gnus-uu-ignore-default-view-rules 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." - :group 'gnus-extract-view - :type 'boolean) +Only the user viewing rules will be consulted. Default is nil.") -(defcustom gnus-uu-grabbed-file-functions nil - "Functions run on each file after successful decoding. +(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'." - :group 'gnus-extract - :options '(gnus-uu-grab-view gnus-uu-grab-move) - :type 'hook) +Likely functions you can use in this list are `gnus-uu-grab-view' +and `gnus-uu-grab-move'.") -(defcustom 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." - :group 'gnus-extract-archive - :type 'boolean) +(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.") -(defcustom gnus-uu-kill-carriage-return t +(defvar gnus-uu-kill-carriage-return t "*Non-nil means that gnus-uu will strip all carriage returns from articles. -Default is t." - :group 'gnus-extract - :type 'boolean) +Default is t.") -(defcustom gnus-uu-view-with-metamail nil +(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 -it nil." - :group 'gnus-extract - :type 'boolean) +to guess at a content-type based on file name suffixes. Default +it nil.") -(defcustom gnus-uu-unmark-articles-not-decoded nil - "*Non-nil means that gnus-uu will mark articles that were unsuccessfully decoded as unread. -Default is nil." - :group 'gnus-extract - :type 'boolean) +(defvar gnus-uu-unmark-articles-not-decoded nil + "*Non-nil means that gnus-uu will mark articles that were unsuccessfully decoded as unread. +Default is nil.") -(defcustom gnus-uu-correct-stripped-uucode nil - "*Non-nil means that gnus-uu will *try* to fix uuencoded files that have had trailing spaces deleted. -Default is nil." - :group 'gnus-extract - :type 'boolean) +(defvar gnus-uu-correct-stripped-uucode nil + "*Non-nil means that gnus-uu will *try* to fix uuencoded files that have had trailing spaces deleted. +Default is nil.") -(defcustom gnus-uu-save-in-digest 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 - -no easy way to specify any meaningful volume and issue numbers were found, -so I simply dropped them." - :group 'gnus-extract - :type 'boolean) +If this variable is nil, gnus-uu will just save everything in a +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.") -(defcustom gnus-uu-digest-headers +(defvar gnus-uu-digest-headers '("^Date:" "^From:" "^To:" "^Cc:" "^Subject:" "^Message-ID:" "^Keywords:" "^Summary:" "^References:") - "List of regexps to match headers included in digested messages. -The headers will be included in the sequence they are matched." - :group 'gnus-extract - :type '(repeat regexp)) + "*List of regexps to match headers included in digested messages. +The headers will be included in the sequence they are matched.") -(defcustom gnus-uu-save-separate-articles nil - "*Non-nil means that gnus-uu will save articles in separate files." - :group 'gnus-extract - :type 'boolean) - -(defcustom gnus-uu-be-dangerous 'ask - "*Specifies what to do if unusual situations arise during decoding. -If nil, be as conservative as possible. If t, ignore things that -didn't work, and overwrite existing files. Otherwise, ask each time." - :group 'gnus-extract - :type '(choice (const :tag "conservative" nil) - (const :tag "ask" ask) - (const :tag "liberal" t))) +(defvar gnus-uu-save-separate-articles nil + "*Non-nil means that gnus-uu will save articles in separate files.") ;; Internal variables @@ -339,39 +269,37 @@ ;; Keymaps -(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-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) -(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-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-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 @@ -389,7 +317,7 @@ (defun gnus-uu-decode-uu (&optional n) "Uudecodes the current article." - (interactive "P") + (interactive "P") (gnus-uu-decode-with-method 'gnus-uu-uustrip-article n)) (defun gnus-uu-decode-uu-and-save (n dir) @@ -421,7 +349,7 @@ "Saves the current article." (interactive (list current-prefix-arg - (read-file-name + (read-file-name (if gnus-uu-save-separate-articles "Save articles is dir: " "Save articles in file: ") @@ -438,12 +366,12 @@ (read-file-name "Unbinhex and save in dir: " gnus-uu-default-dir gnus-uu-default-dir)))) - (setq gnus-uu-binhex-article-name + (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 (&optional n) - "Uudecodes and views the current article." + "Uudecodes and views the current article." (interactive "P") (let ((gnus-view-pseudos (or gnus-view-pseudos 'automatic))) (gnus-uu-decode-uu n))) @@ -491,7 +419,7 @@ (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 + (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))) @@ -503,45 +431,43 @@ "Digests and forwards all articles in this series." (interactive "P") (let ((gnus-uu-save-in-digest t) - (file (make-temp-name (nnheader-concat gnus-uu-tmp-dir "forward"))) - buf subject from newsgroups) - (gnus-setup-message 'forward - (setq gnus-uu-digest-from-subject nil) - (gnus-uu-decode-save n file) - (setq buf (switch-to-buffer (get-buffer-create " *gnus-uu-forward*"))) - (gnus-add-current-to-buffer-list) - (erase-buffer) - (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 - (unless (string= from (caar fs)) - (setq from nil))) - (when subject - (unless (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)) - (when (re-search-forward "^Subject: ") - (delete-region (point) (gnus-point-at-eol)) - (insert subject)) - (goto-char (point-min)) - (when (re-search-forward "^From: ") - (delete-region (point) (gnus-point-at-eol)) - (insert from)) - (message-forward post)) + (file (make-temp-name (concat gnus-uu-tmp-dir "forward"))) + buf subject from) + (setq gnus-uu-digest-from-subject nil) + (gnus-uu-decode-save n 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)) + (if (not fs) + () + (setq from (caar fs) + subject (gnus-simplify-subject-fuzzy (cdar fs)) + fs (cdr fs)) + (while (and fs (or from subject)) + (and from + (or (string= from (caar fs)) + (setq from nil))) + (and subject + (or (string= (gnus-simplify-subject-fuzzy (cdar fs)) + subject) + (setq subject nil))) + (setq fs (cdr fs)))) + (or subject (setq subject "Digested Articles")) + (or from (setq from "Various"))) + (goto-char (point-min)) + (and (re-search-forward "^Subject: ") + (progn + (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 from))) + (message-forward post) (delete-file file) (kill-buffer buf) (setq gnus-uu-digest-from-subject nil))) @@ -603,12 +529,12 @@ "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) @@ -630,18 +556,6 @@ (> (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") @@ -663,15 +577,14 @@ (gnus-set-global-variables) (let ((marked (nreverse gnus-newsgroup-processable)) subject articles total headers) - (unless marked - (error "No articles marked with the process mark")) + (or marked (error "No articles marked with the process mark")) (setq gnus-newsgroup-processable nil) (save-excursion (while marked - (and (vectorp (setq headers + (and (vectorp (setq headers (gnus-summary-article-header (car marked)))) (setq subject (mail-header-subject headers) - articles (gnus-uu-find-articles-matching + articles (gnus-uu-find-articles-matching (gnus-uu-reginize-string subject)) total (nconc total articles))) (while articles @@ -699,7 +612,7 @@ (setq data (cdr data))))) (gnus-summary-position-point)) -;; All PostScript functions written by Erik Selberg <speed@cs.washington.edu>. +;; All PostScript functions written by Erik Selberg <speed@cs.washington.edu>. (defun gnus-uu-decode-postscript (&optional n) "Gets postscript of the current article." @@ -720,7 +633,7 @@ (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 + (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) @@ -736,11 +649,10 @@ ;; Internal functions. -(defun gnus-uu-decode-with-method (method n &optional save not-insert +(defun gnus-uu-decode-with-method (method n &optional save not-insert scan cdir) (gnus-uu-initialize scan) - (when save - (setq gnus-uu-default-dir save)) + (if save (setq gnus-uu-default-dir save)) ;; Create the directory we save to. (when (and scan cdir save (not (file-exists-p save))) @@ -749,11 +661,9 @@ files) (setq files (gnus-uu-grab-articles articles method t)) (let ((gnus-current-article (car articles))) - (when scan - (setq files (gnus-uu-scan-directory gnus-uu-work-dir)))) - (when save - (gnus-uu-save-files files save)) - (when (eq gnus-uu-do-not-unpack-archives nil) + (and scan (setq files (gnus-uu-scan-directory gnus-uu-work-dir)))) + (and save (gnus-uu-save-files files save)) + (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 (not gnus-insert-pseudo-articles) @@ -770,7 +680,7 @@ out) (when (file-directory-p file) (setq out (nconc (gnus-uu-scan-directory file t) out))))) - (if rec + (if rec out (nreverse out)))) @@ -784,13 +694,11 @@ (string-match reg file) (setq fromdir (substring file (match-end 0))) (if (file-directory-p file) - (gnus-make-directory (concat dir fromdir)) + (unless (file-exists-p (concat dir fromdir)) + (make-directory (concat dir fromdir) t)) (setq to-file (concat dir fromdir)) (when (or (not (file-exists-p to-file)) - (eq gnus-uu-be-dangerous t) - (and gnus-uu-be-dangerous - (gnus-y-or-n-p (format "%s exists; overwrite? " - 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")))) @@ -799,48 +707,49 @@ ;; Function called by gnus-uu-grab-articles to treat each article. (defun gnus-uu-save-article (buffer in-state) - (cond + (cond (gnus-uu-save-separate-articles (save-excursion (set-buffer buffer) - (gnus-write-buffer - (concat gnus-uu-saved-article-name gnus-current-article)) + (write-region 1 (point-max) (concat gnus-uu-saved-article-name + gnus-current-article)) (cond ((eq in-state 'first) (list gnus-uu-saved-article-name 'begin)) - ((eq in-state 'first-and-last) (list gnus-uu-saved-article-name + ((eq in-state 'first-and-last) (list gnus-uu-saved-article-name 'begin 'end)) ((eq in-state 'last) (list 'end)) (t (list 'middle))))) ((not gnus-uu-save-in-digest) (save-excursion (set-buffer buffer) - (write-region (point-min) (point-max) gnus-uu-saved-article-name t) + (write-region 1 (point-max) gnus-uu-saved-article-name t) (cond ((eq in-state 'first) (list gnus-uu-saved-article-name 'begin)) - ((eq in-state 'first-and-last) (list gnus-uu-saved-article-name + ((eq in-state 'first-and-last) (list gnus-uu-saved-article-name 'begin 'end)) ((eq in-state 'last) (list 'end)) (t (list 'middle))))) (t (let ((header (gnus-summary-article-header))) - (push (cons (mail-header-from header) - (mail-header-subject header)) - gnus-uu-digest-from-subject)) + (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) + (if (or (eq in-state 'first) (eq in-state 'first-and-last)) - (progn + (progn (setq state (list 'begin)) (save-excursion (set-buffer (get-buffer-create "*gnus-uu-body*")) (erase-buffer)) - (save-excursion + (save-excursion (set-buffer (get-buffer-create "*gnus-uu-pre*")) (erase-buffer) - (insert (format + (insert (format "Date: %s\nFrom: %s\nSubject: %s Digest\n\nTopics:\n" (current-time-string) name name)))) - (when (not (eq in-state 'end)) - (setq state (list 'middle)))) + (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))) @@ -869,9 +778,9 @@ (setq headers (cdr headers)) (goto-char (point-min)) (while (re-search-forward headline nil t) - (setq sorthead + (setq sorthead (concat sorthead - (buffer-substring + (buffer-substring (match-beginning 0) (or (and (re-search-forward "^[^ \t]" nil t) (1- (point))) @@ -881,38 +790,39 @@ (insert body) (goto-char (point-max)) (insert (concat "\n" (make-string 30 ?-) "\n\n")) (goto-char beg) - (when (re-search-forward "^Subject: \\(.*\\)$" nil t) - (setq subj (buffer-substring (match-beginning 1) (match-end 1))) - (save-excursion - (set-buffer (get-buffer "*gnus-uu-pre*")) - (insert (format " %s\n" subj))))) - (when (or (eq in-state 'last) - (eq in-state 'first-and-last)) - (save-excursion - (set-buffer (get-buffer "*gnus-uu-pre*")) - (insert (format "\n\n%s\n\n" (make-string 70 ?-))) - (gnus-write-buffer gnus-uu-saved-article-name)) - (save-excursion - (set-buffer (get-buffer "*gnus-uu-body*")) - (goto-char (point-max)) - (insert - (concat (setq end-string (format "End of %s Digest" name)) - "\n")) - (insert (concat (make-string (length end-string) ?*) "\n")) - (write-region - (point-min) (point-max) gnus-uu-saved-article-name t)) - (kill-buffer (get-buffer "*gnus-uu-pre*")) - (kill-buffer (get-buffer "*gnus-uu-body*")) - (push 'end state)) + (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) + (eq in-state 'first-and-last)) + (progn + (save-excursion + (set-buffer (get-buffer "*gnus-uu-pre*")) + (insert (format "\n\n%s\n\n" (make-string 70 ?-))) + (write-region 1 (point-max) gnus-uu-saved-article-name)) + (save-excursion + (set-buffer (get-buffer "*gnus-uu-body*")) + (goto-char (point-max)) + (insert + (concat (setq end-string (format "End of %s Digest" name)) + "\n")) + (insert (concat (make-string (length end-string) ?*) "\n")) + (write-region 1 (point-max) gnus-uu-saved-article-name t)) + (kill-buffer (get-buffer "*gnus-uu-pre*")) + (kill-buffer (get-buffer "*gnus-uu-body*")) + (setq state (cons 'end state)))) (if (memq 'begin state) (cons gnus-uu-saved-article-name state) state))))) -;; Binhex treatment - not very advanced. +;; Binhex treatment - not very advanced. -(defconst gnus-uu-binhex-body-line +(defconst gnus-uu-binhex-body-line "^[^:]...............................................................$") -(defconst gnus-uu-binhex-begin-line +(defconst gnus-uu-binhex-begin-line "^:...............................................................$") (defconst gnus-uu-binhex-end-line ":$") @@ -923,9 +833,9 @@ (set-buffer buffer) (widen) (goto-char (point-min)) - (when (not (re-search-forward gnus-uu-binhex-begin-line nil t)) - (when (not (re-search-forward gnus-uu-binhex-body-line nil t)) - (setq state (list 'wrong-type)))) + (if (not (re-search-forward gnus-uu-binhex-begin-line nil t)) + (if (not (re-search-forward gnus-uu-binhex-body-line nil t)) + (setq state (list 'wrong-type)))) (if (memq 'wrong-type state) () @@ -937,17 +847,16 @@ (write-region 1 1 gnus-uu-binhex-article-name)) (setq state (list 'middle))) (goto-char (point-max)) - (re-search-backward (concat gnus-uu-binhex-body-line "\\|" - gnus-uu-binhex-end-line) - nil t) - (when (looking-at gnus-uu-binhex-end-line) - (setq state (if (memq 'begin state) - (cons 'end state) - (list 'end)))) + (re-search-backward (concat gnus-uu-binhex-body-line "\\|" + gnus-uu-binhex-end-line) nil t) + (if (looking-at gnus-uu-binhex-end-line) + (setq state (if (memq 'begin state) + (cons 'end state) + (list 'end)))) (beginning-of-line) (forward-line 1) - (when (file-exists-p gnus-uu-binhex-article-name) - (append-to-file start-char (point) gnus-uu-binhex-article-name)))) + (if (file-exists-p gnus-uu-binhex-article-name) + (append-to-file start-char (point) gnus-uu-binhex-article-name)))) (if (memq 'begin state) (cons gnus-uu-binhex-article-name state) state))) @@ -974,7 +883,7 @@ (write-region (point-min) (point-max) file-name) (setq state (list file-name 'begin 'end))))) state)) - + ;; Find actions. @@ -983,7 +892,7 @@ action name) (while files (setq name (cdr (assq 'name (car files)))) - (and + (and (setq action (gnus-uu-get-action name)) (setcar files (nconc (list (if (string= action "gnus-uu-archive") (cons 'action "file") @@ -996,20 +905,20 @@ (defun gnus-uu-get-action (file-name) (let (action) - (setq action - (gnus-uu-choose-action + (setq action + (gnus-uu-choose-action file-name - (append + (append gnus-uu-user-view-rules - (if gnus-uu-ignore-default-view-rules - nil + (if gnus-uu-ignore-default-view-rules + nil gnus-uu-default-view-rules) gnus-uu-user-view-rules-end))) - (when (and (not (string= (or action "") "gnus-uu-archive")) - gnus-uu-view-with-metamail) - (when (setq action + (if (and (not (string= (or action "") "gnus-uu-archive")) + gnus-uu-view-with-metamail) + (if (setq action (gnus-uu-choose-action file-name gnus-uu-ext-to-mime-list)) - (setq action (format "metamail -d -b -c \"%s\"" action)))) + (setq action (format "metamail -d -b -c \"%s\"" action)))) action)) @@ -1020,7 +929,7 @@ ;; 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]+:") @@ -1034,9 +943,10 @@ (setq case-fold-search nil) (goto-char (point-min)) - (when (looking-at vernum) - (replace-match vernum t t) - (setq beg (length vernum))) + (if (looking-at vernum) + (progn + (replace-match vernum t t) + (setq beg (length vernum)))) (goto-char beg) (if (re-search-forward "[ \t]*[0-9]+/[0-9]+" nil t) @@ -1047,9 +957,14 @@ (replace-match "[0-9]+ of [0-9]+") (end-of-line) - (if (re-search-backward "\\([^0-9]\\)[0-9]+\\([^0-9]+\\)[0-9]+" - nil t) - (replace-match "\\1[0-9]+\\2[0-9]+" t nil nil nil)))) + (while (and (re-search-backward "[0-9]" nil t) (> count 0)) + (while (and + (looking-at "[0-9]") + (< 1 (goto-char (1- (point)))))) + (re-search-forward "[0-9]+" nil t) + (replace-match "[0-9]+") + (backward-char 5) + (setq count (1- count))))) (goto-char beg) (while (re-search-forward "[ \t]+" nil t) @@ -1061,19 +976,18 @@ ;; If N is non-nil, the article numbers of the N next articles ;; will be returned. ;; If any articles have been marked as processable, they will be - ;; returned. + ;; returned. ;; Failing that, articles that have subjects that are part of the ;; same "series" as the current will be returned. (let (articles) - (cond + (cond (n - (setq n (prefix-numeric-value n)) (let ((backward (< n 0)) (n (abs n))) (save-excursion (while (and (> n 0) - (push (gnus-summary-article-number) - articles) + (setq articles (cons (gnus-summary-article-number) + articles)) (gnus-summary-search-forward nil nil backward)) (setq n (1- n)))) (nreverse articles))) @@ -1085,13 +999,13 @@ (defun gnus-uu-string< (l1 l2) (string< (car l1) (car l2))) -(defun gnus-uu-find-articles-matching +(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 + (let ((subject (or subject (gnus-uu-reginize-string (gnus-summary-article-subject)))) list-of-subjects) (save-excursion @@ -1111,23 +1025,24 @@ (= mark gnus-dormant-mark)) (setq subj (mail-header-subject (gnus-data-header d))) (string-match subject subj) - (push (cons subj (gnus-data-number d)) - list-of-subjects)))) + (setq list-of-subjects + (cons (cons subj (gnus-data-number d)) + list-of-subjects))))) ;; Expand numbers, sort, and return the list of article ;; numbers. - (mapcar (lambda (sub) (cdr sub)) - (sort (gnus-uu-expand-numbers + (mapcar (lambda (sub) (cdr sub)) + (sort (gnus-uu-expand-numbers list-of-subjects - (not do-not-translate)) + (not do-not-translate)) 'gnus-uu-string<)))))) (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) (save-excursion @@ -1142,15 +1057,15 @@ (replace-match " ")) ;; Translate all characters to "a". (goto-char (point-min)) - (when translate - (while (re-search-forward "[A-Za-z]" nil t) - (replace-match "a" t t))) + (if translate + (while (re-search-forward "[A-Za-z]" nil t) + (replace-match "a" t t))) ;; Expand numbers. (goto-char (point-min)) (while (re-search-forward "[0-9]+" nil t) - (replace-match - (format "%06d" - (string-to-int (buffer-substring + (replace-match + (format "%06d" + (string-to-int (buffer-substring (match-beginning 0) (match-end 0)))))) (setq string (buffer-substring 1 (point-max))) (setcar (car string-list) string) @@ -1163,14 +1078,14 @@ ;; 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 @@ -1189,29 +1104,30 @@ (if (not (and gnus-uu-has-been-grabbed gnus-uu-unmark-articles-not-decoded)) () - (when dont-unmark-last-article - (setq art (car gnus-uu-has-been-grabbed)) - (setq gnus-uu-has-been-grabbed (cdr gnus-uu-has-been-grabbed))) + (if dont-unmark-last-article + (progn + (setq art (car gnus-uu-has-been-grabbed)) + (setq gnus-uu-has-been-grabbed (cdr gnus-uu-has-been-grabbed)))) (while gnus-uu-has-been-grabbed (gnus-summary-tick-article (car gnus-uu-has-been-grabbed) t) (setq gnus-uu-has-been-grabbed (cdr gnus-uu-has-been-grabbed))) - (when dont-unmark-last-article - (setq gnus-uu-has-been-grabbed (list art)))))) + (if dont-unmark-last-article + (setq gnus-uu-has-been-grabbed (list art)))))) ;; This function takes a list of articles and a function to apply to -;; each article grabbed. -;; +;; each article grabbed. +;; ;; 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 +(defun gnus-uu-grab-articles (articles process-function &optional sloppy limit no-errors) - (let ((state 'first) + (let ((state 'first) 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) - - (while (and articles + + (while (and articles (not (memq 'error process-state)) (or sloppy (not (memq 'end process-state)))) @@ -1219,45 +1135,40 @@ (setq article (pop articles)) (push article article-series) - (unless articles + (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..." + (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 + (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 + ;; 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) + (and (or (eq state 'first) (eq state 'first-and-last)) (memq 'ok process-state))) - (when 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) - (not gnus-uu-be-dangerous) - (or (eq gnus-uu-be-dangerous t) - (gnus-y-or-n-p - (format "Delete unsuccessfully decoded file %s" - result-file)))) - (delete-file result-file))) + (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)) + (delete-file result-file))) (when (memq 'begin process-state) (setq result-file (car process-state))) (setq has-been-begin t)) @@ -1281,7 +1192,6 @@ (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))) @@ -1291,14 +1201,11 @@ ;; the partially decoded file. (and (or (eq state 'last) (eq state 'first-and-last)) (not (memq 'end process-state)) - result-file + result-file (file-exists-p result-file) - (not gnus-uu-be-dangerous) - (or (eq gnus-uu-be-dangerous t) - (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 + ;; 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) @@ -1323,7 +1230,7 @@ (gnus-message 2 "Wrong type file")) ((memq 'error process-state) (gnus-message 2 "An error occurred during decoding")) - ((not (or (memq 'ok process-state) + ((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. @@ -1354,7 +1261,7 @@ (defun gnus-uu-part-number (article) (let* ((header (gnus-summary-article-header article)) (subject (and header (mail-header-subject header)))) - (if (and subject + (if (and subject (string-match "[0-9]+ */[0-9]+\\|[0-9]+ * of *[0-9]+" subject)) (match-string 0 subject) ""))) @@ -1367,7 +1274,7 @@ (save-excursion (set-buffer process-buffer) (let ((state (list 'wrong-type)) - process-connection-type case-fold-search buffer-read-only + process-connection-type case-fold-search buffer-read-only files start-char) (goto-char (point-min)) @@ -1388,11 +1295,10 @@ (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 + (setq gnus-uu-file-name (let ((nnheader-file-name-translation-alist '((?/ . ?,) (? . ?_) (?* . ?_) (?$ . ?_)))) (nnheader-translate-file-chars (match-string 1)))) - (replace-match (concat "begin 644 " gnus-uu-file-name) t t) ;; Remove any non gnus-uu-body-line right after start. (forward-line 1) @@ -1402,7 +1308,7 @@ ;; If a process is running, we kill it. (when (and gnus-uu-uudecode-process - (memq (process-status 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)) @@ -1413,24 +1319,24 @@ (progn (cd gnus-uu-work-dir) (setq gnus-uu-uudecode-process - (start-process - "*uudecode*" + (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 + (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) - (push 'end state) + (setq state (cons 'end state)) (goto-char (point-max)) (re-search-backward gnus-uu-body-line nil t)) - + (forward-line 1) (when gnus-uu-uudecode-process @@ -1443,8 +1349,8 @@ (condition-case nil (process-send-region gnus-uu-uudecode-process start-char (point)) - (error - (progn + (error + (progn (delete-process gnus-uu-uudecode-process) (gnus-message 2 "gnus-uu: Couldn't uudecode") (setq state (list 'wrong-type))))) @@ -1452,8 +1358,9 @@ (if (memq 'end state) (progn ;; Send an EOF, just in case. - (ignore-errors - (process-send-eof gnus-uu-uudecode-process)) + (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))) @@ -1478,12 +1385,10 @@ (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")))) + (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 " ; sh")))) state)) ;; Returns the name of what the shar file is going to unpack. @@ -1491,8 +1396,8 @@ (let ((oldpoint (point)) res) (goto-char (point-min)) - (when (re-search-forward gnus-uu-shar-name-marker nil t) - (setq res (buffer-substring (match-beginning 1) (match-end 1)))) + (if (re-search-forward gnus-uu-shar-name-marker nil t) + (setq res (buffer-substring (match-beginning 1) (match-end 1)))) (goto-char oldpoint) res)) @@ -1503,42 +1408,41 @@ (let ((action-list (copy-sequence file-action-list)) (case-fold-search t) rule action) - (and - (unless no-ignore - (and (not - (and gnus-uu-ignore-files-by-name - (string-match gnus-uu-ignore-files-by-name file-name))) - (not - (and gnus-uu-ignore-files-by-type - (string-match gnus-uu-ignore-files-by-type - (or (gnus-uu-choose-action - file-name gnus-uu-ext-to-mime-list t) - "")))))) + (and + (or no-ignore + (and (not + (and gnus-uu-ignore-files-by-name + (string-match gnus-uu-ignore-files-by-name file-name))) + (not + (and gnus-uu-ignore-files-by-type + (string-match gnus-uu-ignore-files-by-type + (or (gnus-uu-choose-action + file-name gnus-uu-ext-to-mime-list t) + "")))))) (while (not (or (eq action-list ()) action)) (setq rule (car action-list)) (setq action-list (cdr action-list)) - (when (string-match (car rule) file-name) - (setq action (cadr rule))))) + (if (string-match (car rule) file-name) + (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 dir) - (setq action (gnus-uu-choose-action + (setq action (gnus-uu-choose-action file-path (append gnus-uu-user-archive-rules (if gnus-uu-ignore-default-archive-rules nil gnus-uu-default-archive-rules)))) - (when (not action) - (error "No unpackers for the file %s" file-path)) + (if (not action) (error "No unpackers for the file %s" file-path)) (string-match "/[^/]*$" file-path) (setq dir (substring file-path 0 (match-beginning 0))) - (when (member action gnus-uu-destructive-archivers) - (copy-file file-path (concat file-path "~") t)) + (if (member action gnus-uu-destructive-archivers) + (copy-file file-path (concat file-path "~") t)) (setq command (format "cd %s ; %s" dir (gnus-uu-command action file-path))) @@ -1548,15 +1452,15 @@ (gnus-message 5 "Unpacking: %s..." (gnus-uu-command action file-path)) - (if (= 0 (call-process shell-file-name nil + (if (= 0 (call-process shell-file-name nil (get-buffer-create gnus-uu-output-buffer-name) nil shell-command-switch command)) (message "") (gnus-message 2 "Error during unpacking of archive") (setq did-unpack nil)) - (when (member action gnus-uu-destructive-archivers) - (rename-file (concat file-path "~") file-path t)) + (if (member action gnus-uu-destructive-archivers) + (rename-file (concat file-path "~") file-path t)) did-unpack)) @@ -1566,34 +1470,35 @@ (while dirs (if (file-directory-p (setq file (car dirs))) (setq files (append files (gnus-uu-dir-files file))) - (push file files)) + (setq files (cons file files))) (setq dirs (cdr dirs))) files)) (defun gnus-uu-unpack-files (files &optional ignore) - ;; Go through FILES and look for files to unpack. + ;; Go through FILES and look for files to unpack. (let* ((totfiles (gnus-uu-ls-r gnus-uu-work-dir)) (ofiles files) file did-unpack) (while files (setq file (cdr (assq 'name (car files)))) - (when (and (not (member file ignore)) - (equal (gnus-uu-get-action (file-name-nondirectory file)) - "gnus-uu-archive")) - (push file did-unpack) - (unless (gnus-uu-treat-archive file) - (gnus-message 2 "Error during unpacking of %s" file)) - (let* ((newfiles (gnus-uu-ls-r gnus-uu-work-dir)) - (nfiles newfiles)) - (while nfiles - (unless (member (car nfiles) totfiles) - (push (list (cons 'name (car nfiles)) - (cons 'original file)) - ofiles)) - (setq nfiles (cdr nfiles))) - (setq totfiles newfiles))) + (if (and (not (member file ignore)) + (equal (gnus-uu-get-action (file-name-nondirectory file)) + "gnus-uu-archive")) + (progn + (setq did-unpack (cons file did-unpack)) + (or (gnus-uu-treat-archive file) + (gnus-message 2 "Error during unpacking of %s" file)) + (let* ((newfiles (gnus-uu-ls-r gnus-uu-work-dir)) + (nfiles newfiles)) + (while nfiles + (or (member (car nfiles) totfiles) + (setq ofiles (cons (list (cons 'name (car nfiles)) + (cons 'original file)) + ofiles))) + (setq nfiles (cdr nfiles))) + (setq totfiles newfiles)))) (setq files (cdr files))) - (if did-unpack + (if did-unpack (gnus-uu-unpack-files ofiles (append did-unpack ignore)) ofiles))) @@ -1601,9 +1506,10 @@ (let* ((files (gnus-uu-directory-files dir t)) (ofiles files)) (while files - (when (file-directory-p (car files)) - (setq ofiles (delete (car files) ofiles)) - (setq ofiles (append ofiles (gnus-uu-ls-r (car files))))) + (if (file-directory-p (car files)) + (progn + (setq ofiles (delete (car files) ofiles)) + (setq ofiles (append ofiles (gnus-uu-ls-r (car files)))))) (setq files (cdr files))) ofiles)) @@ -1615,8 +1521,8 @@ (while files (setq file (car files)) (setq files (cdr files)) - (unless (member (file-name-nondirectory file) '("." "..")) - (push file out))) + (or (member (file-name-nondirectory file) '("." "..")) + (setq out (cons file out)))) (setq out (nreverse out)) out)) @@ -1632,25 +1538,25 @@ (goto-char start) (while (not (eobp)) (progn - (when (looking-at "\n") - (replace-match "")) + (if (looking-at "\n") (replace-match "")) (forward-line 1)))) - + (while (not (eobp)) - (if (looking-at (concat gnus-uu-begin-string "\\|" + (if (looking-at (concat gnus-uu-begin-string "\\|" gnus-uu-end-string)) () - (when (not found) - (beginning-of-line) - (setq beg (point)) - (end-of-line) - (setq length (- (point) beg))) + (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) - (when (not (= length (- (point) beg))) - (insert (make-string (- length (- (point) beg)) ? )))) + (if (not (= length (- (point) beg))) + (insert (make-string (- length (- (point) beg)) ? )))) (forward-line 1))))))) (defvar gnus-uu-tmp-alist nil) @@ -1658,27 +1564,28 @@ (defun gnus-uu-initialize (&optional scan) (let (entry) (if (and (not scan) - (when (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))) + (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 + (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) - (when (not (file-writable-p gnus-uu-tmp-dir)) - (error "Temp directory %s can't be written to" - 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 + (setq gnus-uu-work-dir (make-temp-name (concat gnus-uu-tmp-dir "gnus"))) - (gnus-make-directory gnus-uu-work-dir) + (if (not (file-directory-p gnus-uu-work-dir)) + (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)) - (push (cons gnus-newsgroup-name gnus-uu-work-dir) - gnus-uu-tmp-alist)))) + (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. @@ -1688,29 +1595,23 @@ (memq (process-status (or gnus-uu-uudecode-process "nevair")) '(stop run)) (delete-process gnus-uu-uudecode-process)) - (when (setq buf (get-buffer gnus-uu-output-buffer-name)) - (kill-buffer buf)))) + (and (setq buf (get-buffer gnus-uu-output-buffer-name)) + (kill-buffer buf)))) -(defun gnus-quote-arg-for-sh-or-csh (arg) - (let ((pos 0) new-pos accum) - ;; *** bug: we don't handle newline characters properly - (while (setq new-pos (string-match "[!`\"$\\& \t{}]" arg pos)) - (push (substring arg pos new-pos) accum) - (push "\\" accum) - (push (list (aref arg new-pos)) accum) - (setq pos (1+ new-pos))) - (if (= pos 0) - arg - (apply 'concat (nconc (nreverse accum) (list (substring arg pos))))))) - -;; Inputs an action and a filename and returns a full command, making sure -;; that the filename will be treated as a single argument when the shell -;; executes the command. +;; Inputs an action and a file and returns a full command, putting +;; quotes round the file name and escaping any quotes in the file name. (defun gnus-uu-command (action file) - (let ((quoted-file (gnus-quote-arg-for-sh-or-csh file))) + (let ((ofile "")) + (while (string-match "!\\|`\\|\"\\|\\$\\|\\\\\\|&" file) + (progn + (setq ofile + (concat ofile (substring file 0 (match-beginning 0)) "\\" + (substring file (match-beginning 0) (match-end 0)))) + (setq file (substring file (1+ (match-beginning 0)))))) + (setq ofile (concat "\"" ofile file "\"")) (if (string-match "%s" action) - (format action quoted-file) - (concat action " " quoted-file)))) + (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'." @@ -1742,53 +1643,40 @@ ;;; ;; 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. -(defcustom gnus-uu-post-encode-method 'gnus-uu-post-encode-uuencode +(defvar gnus-uu-post-encode-method 'gnus-uu-post-encode-uuencode "Function used for encoding binary files. There are three functions supplied with gnus-uu for encoding files: `gnus-uu-post-encode-uuencode', which does straight uuencoding; -`gnus-uu-post-encode-mime', which encodes with base64 and adds MIME -headers; and `gnus-uu-post-encode-mime-uuencode', which encodes with -uuencode and adds MIME headers." - :group 'gnus-extract-post - :type '(radio (function-item gnus-uu-post-encode-uuencode) - (function-item gnus-uu-post-encode-mime) - (function-item gnus-uu-post-encode-mime-uuencode) - (function :tag "Other"))) +`gnus-uu-post-encode-mime', which encodes with base64 and adds MIME +headers; and `gnus-uu-post-encode-mime-uuencode', which encodes with +uuencode and adds MIME headers.") -(defcustom gnus-uu-post-include-before-composing nil +(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." - :group 'gnus-extract-post - :type 'boolean) +\\[gnus-uu-post-insert-binary-in-article] or have one included for you when you post the article.") -(defcustom gnus-uu-post-length 990 +(defvar gnus-uu-post-length 990 "Maximum length of an article. The encoded file will be split into how many articles it takes to -post the entire file." - :group 'gnus-extract-post - :type 'integer) +post the entire file.") -(defcustom gnus-uu-post-threaded nil +(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 -one package that does that - gnus-uu, but somehow, I don't think that -counts...) Default is nil." - :group 'gnus-extract-post - :type 'boolean) +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.") -(defcustom gnus-uu-post-separate-description t +(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 -is nil, the description the user enters will be included at the -beginning of the first article, which will be numbered (1/x). Default -is t." - :group 'gnus-extract-post - :type 'boolean) +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 +is t.") (defvar gnus-uu-post-binary-separator "--binary follows this line--") (defvar gnus-uu-post-message-id nil) @@ -1808,44 +1696,47 @@ (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) - - (when gnus-uu-post-include-before-composing - (save-excursion (setq gnus-uu-post-inserted-file-name - (gnus-uu-post-insert-binary))))) + + (if gnus-uu-post-include-before-composing + (save-excursion (setq gnus-uu-post-inserted-file-name + (gnus-uu-post-insert-binary))))) (defun gnus-uu-post-insert-binary-in-article () "Inserts an encoded file in the buffer. The user will be asked for a file name." (interactive) - (save-excursion + (save-excursion (setq gnus-uu-post-inserted-file-name (gnus-uu-post-insert-binary)))) ;; Encodes with uuencode and substitutes all spaces with backticks. (defun gnus-uu-post-encode-uuencode (path file-name) - (when (gnus-uu-post-encode-file "uuencode" path file-name) - (goto-char (point-min)) - (forward-line 1) - (while (re-search-forward " " nil t) - (replace-match "`")) - t)) + (if (gnus-uu-post-encode-file "uuencode" path file-name) + (progn + (goto-char (point-min)) + (forward-line 1) + (while (re-search-forward " " nil t) + (replace-match "`")) + t))) ;; Encodes with uuencode and adds MIME headers. (defun gnus-uu-post-encode-mime-uuencode (path file-name) - (when (gnus-uu-post-encode-uuencode path file-name) - (gnus-uu-post-make-mime file-name "x-uue") - t)) + (if (gnus-uu-post-encode-uuencode path file-name) + (progn + (gnus-uu-post-make-mime file-name "x-uue") + t))) ;; Encodes with base64 and adds MIME headers (defun gnus-uu-post-encode-mime (path file-name) - (when (gnus-uu-post-encode-file "mmencode" path file-name) - (gnus-uu-post-make-mime file-name "base64") - t)) + (if (gnus-uu-post-encode-file "mmencode" path file-name) + (progn + (gnus-uu-post-make-mime file-name "base64") + t))) ;; Adds MIME headers. (defun gnus-uu-post-make-mime (file-name encoding) (goto-char (point-min)) - (insert (format "Content-Type: %s; name=\"%s\"\n" - (gnus-uu-choose-action file-name gnus-uu-ext-to-mime-list) + (insert (format "Content-Type: %s; name=\"%s\"\n" + (gnus-uu-choose-action file-name gnus-uu-ext-to-mime-list) file-name)) (insert (format "Content-Transfer-Encoding: %s\n\n" encoding)) (save-restriction @@ -1854,15 +1745,16 @@ (re-search-forward (concat "^" (regexp-quote mail-header-separator) "$")) (forward-line -1) (narrow-to-region 1 (point)) - (unless (mail-fetch-field "mime-version") - (widen) - (insert "MIME-Version: 1.0\n")) + (or (mail-fetch-field "mime-version") + (progn + (widen) + (insert "MIME-Version: 1.0\n"))) (widen))) ;; 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 shell-file-name nil t nil shell-command-switch + (= 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 () @@ -1875,9 +1767,9 @@ (if gnus-uu-post-inserted-file-name (setq file-name gnus-uu-post-inserted-file-name) (setq file-name (gnus-uu-post-insert-binary))) - + (if gnus-uu-post-threaded - (let ((message-required-news-headers + (let ((message-required-news-headers (if (memq 'Message-ID message-required-news-headers) message-required-news-headers (cons 'Message-ID message-required-news-headers))) @@ -1886,45 +1778,46 @@ (setq gnus-inews-article-hook (if (listp gnus-inews-article-hook) gnus-inews-article-hook (list gnus-inews-article-hook))) - (push - '(lambda () - (save-excursion - (goto-char (point-min)) - (if (re-search-forward "^Message-ID: \\(.*\\)$" nil t) - (setq gnus-uu-post-message-id - (buffer-substring - (match-beginning 1) (match-end 1))) - (setq gnus-uu-post-message-id nil)))) - gnus-inews-article-hook) + (setq gnus-inews-article-hook + (cons + '(lambda () + (save-excursion + (goto-char (point-min)) + (if (re-search-forward "^Message-ID: \\(.*\\)$" nil t) + (setq gnus-uu-post-message-id + (buffer-substring + (match-beginning 1) (match-end 1))) + (setq gnus-uu-post-message-id nil)))) + gnus-inews-article-hook)) (gnus-uu-post-encoded file-name t)) (gnus-uu-post-encoded file-name nil))) (setq gnus-uu-post-inserted-file-name nil) - (when gnus-uu-winconf-post-news - (set-window-configuration gnus-uu-winconf-post-news))) - + (and gnus-uu-winconf-post-news + (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 uubuf file-name) - (setq file-path (read-file-name + (setq file-path (read-file-name "What file do you want to encode? ")) - (when (not (file-exists-p file-path)) - (error "%s: No such file" file-path)) + (if (not (file-exists-p file-path)) + (error "%s: No such file" file-path)) (goto-char (point-max)) (insert (format "\n%s\n" gnus-uu-post-binary-separator)) - - (when (string-match "^~/" file-path) - (setq file-path (concat "$HOME" (substring file-path 1)))) + + (if (string-match "^~/" file-path) + (setq file-path (concat "$HOME" (substring file-path 1)))) (if (string-match "/[^/]*$" file-path) (setq file-name (substring file-path (1+ (match-beginning 0)))) (setq file-name file-path)) (unwind-protect (if (save-excursion - (set-buffer (setq uubuf + (set-buffer (setq uubuf (get-buffer-create uuencode-buffer-name))) (erase-buffer) (funcall gnus-uu-post-encode-method file-path file-name)) @@ -1945,34 +1838,33 @@ (setq post-buf (current-buffer)) (goto-char (point-min)) - (when (not (re-search-forward - (if gnus-uu-post-separate-description - (concat "^" (regexp-quote gnus-uu-post-binary-separator) - "$") - (concat "^" (regexp-quote mail-header-separator) "$")) - nil t)) - (error "Internal error: No binary/header separator")) + (if (not (re-search-forward + (if gnus-uu-post-separate-description + (concat "^" (regexp-quote gnus-uu-post-binary-separator) + "$") + (concat "^" (regexp-quote mail-header-separator) "$")) nil t)) + (error "Internal error: No binary/header separator")) (beginning-of-line) (forward-line 1) (setq beg-binary (point)) (setq end-binary (point-max)) - (save-excursion + (save-excursion (set-buffer (setq uubuf (get-buffer-create encoded-buffer-name))) (erase-buffer) (insert-buffer-substring post-buf beg-binary end-binary) (goto-char (point-min)) (setq length (count-lines 1 (point-max))) (setq parts (/ length gnus-uu-post-length)) - (when (not (< (% length gnus-uu-post-length) 4)) - (setq parts (1+ parts)))) + (if (not (< (% length gnus-uu-post-length) 4)) + (setq parts (1+ parts)))) - (when gnus-uu-post-separate-description - (forward-line -1)) + (if gnus-uu-post-separate-description + (forward-line -1)) (kill-region (point) (point-max)) (goto-char (point-min)) - (re-search-forward + (re-search-forward (concat "^" (regexp-quote mail-header-separator) "$") nil t) (beginning-of-line) (setq header (buffer-substring 1 (point))) @@ -1980,9 +1872,10 @@ (goto-char (point-min)) (if (not gnus-uu-post-separate-description) () - (when (and (not threaded) (re-search-forward "^Subject: " nil t)) - (end-of-line) - (insert (format " (0/%d)" parts))) + (if (and (not threaded) (re-search-forward "^Subject: " nil t)) + (progn + (end-of-line) + (insert (format " (0/%d)" parts)))) (message-send)) (save-excursion @@ -1992,19 +1885,19 @@ (set-buffer (get-buffer-create send-buffer-name)) (erase-buffer) (insert header) - (when (and threaded gnus-uu-post-message-id) - (insert (format "References: %s\n" gnus-uu-post-message-id))) + (if (and threaded gnus-uu-post-message-id) + (insert (format "References: %s\n" gnus-uu-post-message-id))) (insert separator) (setq whole-len (- 62 (length (format top-string "" file-name i parts "")))) - (when (> 1 (setq minlen (/ whole-len 2))) - (setq minlen 1)) - (setq - beg-line + (if (> 1 (setq minlen (/ whole-len 2))) + (setq minlen 1)) + (setq + beg-line (format top-string - (make-string minlen ?-) + (make-string minlen ?-) file-name i parts - (make-string + (make-string (if (= 0 (% whole-len 2)) (1- minlen) minlen) ?-))) (goto-char (point-min)) @@ -2014,10 +1907,10 @@ (progn (end-of-line) (insert (format " (%d/%d)" i parts))) - (when (or (and (= i 2) gnus-uu-post-separate-description) - (and (= i 1) (not gnus-uu-post-separate-description))) - (replace-match "Subject: Re: ")))) - + (if (or (and (= i 2) gnus-uu-post-separate-description) + (and (= i 1) (not gnus-uu-post-separate-description))) + (replace-match "Subject: Re: ")))) + (goto-char (point-max)) (save-excursion (set-buffer uubuf) @@ -2025,8 +1918,8 @@ (if (= i parts) (goto-char (point-max)) (forward-line gnus-uu-post-length)) - (when (and (= (1+ i) parts) (< (count-lines (point) (point-max)) 4)) - (forward-line -4)) + (if (and (= (1+ i) parts) (< (count-lines (point) (point-max)) 4)) + (forward-line -4)) (setq end (point))) (insert-buffer-substring uubuf beg end) (insert beg-line) @@ -2038,25 +1931,26 @@ (concat "^" (regexp-quote mail-header-separator) "$") nil t) (beginning-of-line) (forward-line 2) - (when (re-search-forward - (concat "^" (regexp-quote gnus-uu-post-binary-separator) "$") - nil t) - (replace-match "") - (forward-line 1)) + (if (re-search-forward + (concat "^" (regexp-quote gnus-uu-post-binary-separator) "$") + nil t) + (progn + (replace-match "") + (forward-line 1))) (insert beg-line) (insert "\n") (let (message-sent-message-via) (message-send)))) - (when (setq buf (get-buffer send-buffer-name)) - (kill-buffer buf)) - (when (setq buf (get-buffer encoded-buffer-name)) - (kill-buffer buf)) + (and (setq buf (get-buffer send-buffer-name)) + (kill-buffer buf)) + (and (setq buf (get-buffer encoded-buffer-name)) + (kill-buffer buf)) - (when (not gnus-uu-post-separate-description) - (set-buffer-modified-p nil) - (when (fboundp 'bury-buffer) - (bury-buffer))))) + (if (not gnus-uu-post-separate-description) + (progn + (set-buffer-modified-p nil) + (and (fboundp 'bury-buffer) (bury-buffer)))))) (provide 'gnus-uu)