mirror of
https://git.savannah.gnu.org/git/emacs.git
synced 2024-12-17 10:06:13 +00:00
163cb72dcb
Merge from gnus--rel--5.10 Patches applied: * gnus--rel--5.10 (patch 83) - Update from CVS
2121 lines
71 KiB
EmacsLisp
2121 lines
71 KiB
EmacsLisp
;;; gnus-uu.el --- extract (uu)encoded files in Gnus
|
||
|
||
;; Copyright (C) 1985, 1986, 1987, 1993, 1994, 1995, 1996, 1997, 1998,
|
||
;; 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
|
||
|
||
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
|
||
;; Created: 2 Oct 1993
|
||
;; Keyword: news
|
||
|
||
;; This file is part of GNU Emacs.
|
||
|
||
;; GNU Emacs is free software; you can redistribute it and/or modify
|
||
;; it under the terms of the GNU General Public License as published by
|
||
;; the Free Software Foundation; either version 2, or (at your option)
|
||
;; any later version.
|
||
|
||
;; GNU Emacs is distributed in the hope that it will be useful,
|
||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||
;; 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, Inc., 51 Franklin Street, Fifth Floor,
|
||
;; Boston, MA 02110-1301, USA.
|
||
|
||
;;; Commentary:
|
||
|
||
;;; Code:
|
||
|
||
(eval-when-compile (require 'cl))
|
||
|
||
(require 'gnus)
|
||
(require 'gnus-art)
|
||
(require 'message)
|
||
(require 'gnus-msg)
|
||
(require 'mm-decode)
|
||
|
||
(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)
|
||
|
||
;; Default viewing action rules
|
||
|
||
(defcustom gnus-uu-default-view-rules
|
||
'(("\\.te?xt$\\|\\.doc$\\|read.*me\\|\\.c?$\\|\\.h$\\|\\.bat$\\|\\.asm$\\|makefile" "cat %s | sed 's/\r$//'")
|
||
("\\.pas$" "cat %s | sed 's/\r$//'")
|
||
("\\.[1-9]$" "groff -mandoc -Tascii %s | sed s/\b.//g")
|
||
("\\.\\(jpe?g\\|gif\\|tiff?\\|p[pgb]m\\|xwd\\|xbm\\|pcx\\)$" "display")
|
||
("\\.tga$" "tgatoppm %s | ee -")
|
||
("\\.\\(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")
|
||
("\\.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\\)$"
|
||
"gnus-uu-archive"))
|
||
"*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.
|
||
|
||
For example:
|
||
|
||
To make gnus-uu use 'xli' to display JPEG and GIF files, put the
|
||
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
|
||
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
|
||
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
|
||
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
|
||
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"))))
|
||
|
||
(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"))))
|
||
|
||
(defcustom 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"))))
|
||
|
||
;; Default unpacking commands
|
||
|
||
(defcustom gnus-uu-default-archive-rules
|
||
'(("\\.tar$" "tar xf")
|
||
("\\.zip$" "unzip -o")
|
||
("\\.ar$" "ar x")
|
||
("\\.arj$" "unarj x")
|
||
("\\.zoo$" "zoo -e")
|
||
("\\.\\(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"))))
|
||
|
||
(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.
|
||
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
|
||
'((\"\\\\.tar$\" \"untar\")
|
||
(\"\\\\.zip$\" \"zip -x\")))"
|
||
:group 'gnus-extract-archive
|
||
:type '(repeat (group regexp (string :tag "Command"))))
|
||
|
||
(defcustom 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,
|
||
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")))
|
||
|
||
(defcustom 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,
|
||
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")))
|
||
|
||
;; Pseudo-MIME support
|
||
|
||
(defconst gnus-uu-ext-to-mime-list
|
||
'(("\\.gif$" "image/gif")
|
||
("\\.jpe?g$" "image/jpeg")
|
||
("\\.tiff?$" "image/tiff")
|
||
("\\.xwd$" "image/xwd")
|
||
("\\.pbm$" "image/pbm")
|
||
("\\.pgm$" "image/pgm")
|
||
("\\.ppm$" "image/ppm")
|
||
("\\.xbm$" "image/xbm")
|
||
("\\.pcx$" "image/pcx")
|
||
("\\.tga$" "image/tga")
|
||
("\\.ps$" "image/postscript")
|
||
("\\.fli$" "video/fli")
|
||
("\\.wav$" "audio/wav")
|
||
("\\.aiff$" "audio/aiff")
|
||
("\\.hcom$" "audio/hcom")
|
||
("\\.voc$" "audio/voc")
|
||
("\\.smp$" "audio/smp")
|
||
("\\.mod$" "audio/mod")
|
||
("\\.dvi$" "image/dvi")
|
||
("\\.mpe?g$" "video/mpeg")
|
||
("\\.au$" "audio/basic")
|
||
("\\.\\(te?xt\\|doc\\|c\\|h\\)$" "text/plain")
|
||
("\\.\\(c\\|h\\)$" "text/source")
|
||
("read.*me" "text/plain")
|
||
("\\.html$" "text/html")
|
||
("\\.bat$" "text/bat")
|
||
("\\.[1-6]$" "text/man")
|
||
("\\.flc$" "video/flc")
|
||
("\\.rle$" "video/rle")
|
||
("\\.pfx$" "video/pfx")
|
||
("\\.avi$" "video/avi")
|
||
("\\.sme$" "video/sme")
|
||
("\\.rpza$" "video/prza")
|
||
("\\.dl$" "video/dl")
|
||
("\\.qt$" "video/qt")
|
||
("\\.rsrc$" "video/rsrc")
|
||
("\\..*$" "unknown/unknown")))
|
||
|
||
;; Various variables users may set
|
||
|
||
(defcustom gnus-uu-tmp-dir
|
||
(cond ((fboundp 'temp-directory) (temp-directory))
|
||
((boundp 'temporary-file-directory) temporary-file-directory)
|
||
("/tmp/"))
|
||
"*Variable saying where gnus-uu is to do its work.
|
||
Default is \"/tmp/\"."
|
||
:group 'gnus-extract
|
||
:type 'directory)
|
||
|
||
(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)
|
||
|
||
(defcustom 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)
|
||
|
||
(defcustom 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)
|
||
|
||
(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)
|
||
|
||
(defcustom 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)
|
||
|
||
(defcustom 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)
|
||
|
||
(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)
|
||
|
||
(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)
|
||
|
||
(defcustom 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)
|
||
|
||
(defcustom gnus-uu-pre-uudecode-hook nil
|
||
"Hook run before sending a message to uudecode."
|
||
:group 'gnus-extract
|
||
:type 'hook)
|
||
|
||
(defcustom gnus-uu-digest-headers
|
||
'("^Date:" "^From:" "^To:" "^Cc:" "^Subject:" "^Message-ID:" "^Keywords:"
|
||
"^Summary:" "^References:" "^Content-Type:" "^Content-Transfer-Encoding:"
|
||
"^MIME-Version:" "^Content-Disposition:" "^Content-Description:"
|
||
"^Content-ID:")
|
||
"*List of regexps to match headers included in digested messages.
|
||
The headers will be included in the sequence they are matched. If nil
|
||
include all headers."
|
||
:group 'gnus-extract
|
||
:type '(repeat regexp))
|
||
|
||
(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)))
|
||
|
||
;; Internal variables
|
||
|
||
(defvar gnus-uu-saved-article-name nil)
|
||
|
||
(defvar gnus-uu-begin-string "^begin[ \t]+0?[0-7][0-7][0-7][ \t]+\\(.*\\)$")
|
||
(defvar gnus-uu-end-string "^end[ \t]*$")
|
||
|
||
(defvar gnus-uu-body-line "^M")
|
||
(let ((i 61))
|
||
(while (> (setq i (1- i)) 0)
|
||
(setq gnus-uu-body-line (concat gnus-uu-body-line "[^a-z]")))
|
||
(setq gnus-uu-body-line (concat gnus-uu-body-line ".?$")))
|
||
|
||
;"^M.............................................................?$"
|
||
|
||
(defvar gnus-uu-shar-begin-string "^#! */bin/sh")
|
||
|
||
(defvar gnus-uu-shar-file-name nil)
|
||
(defvar gnus-uu-shar-name-marker
|
||
"begin 0?[0-7][0-7][0-7][ \t]+\\(\\(\\w\\|[.\\:]\\)*\\b\\)")
|
||
|
||
(defvar gnus-uu-postscript-begin-string "^%!PS-")
|
||
(defvar gnus-uu-postscript-end-string "^%%EOF$")
|
||
|
||
(defvar gnus-uu-file-name nil)
|
||
(defvar gnus-uu-uudecode-process nil)
|
||
(defvar gnus-uu-binhex-article-name nil)
|
||
|
||
(defvar gnus-uu-work-dir nil)
|
||
|
||
(defvar gnus-uu-output-buffer-name " *Gnus UU Output*")
|
||
|
||
(defvar gnus-uu-default-dir gnus-article-save-directory)
|
||
(defvar gnus-uu-digest-from-subject nil)
|
||
(defvar gnus-uu-digest-buffer nil)
|
||
|
||
;; Commands.
|
||
|
||
(defun gnus-uu-decode-uu (&optional n)
|
||
"Uudecodes the current article."
|
||
(interactive "P")
|
||
(gnus-uu-decode-with-method 'gnus-uu-uustrip-article n))
|
||
|
||
(defun gnus-uu-decode-uu-and-save (n dir)
|
||
"Decodes and saves the resulting file."
|
||
(interactive
|
||
(list current-prefix-arg
|
||
(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 (&optional n)
|
||
"Unshars the current article."
|
||
(interactive "P")
|
||
(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
|
||
(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."
|
||
(interactive
|
||
(list current-prefix-arg
|
||
(read-file-name
|
||
(if gnus-uu-save-separate-articles
|
||
"Save articles is dir: "
|
||
"Save articles in file: ")
|
||
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))
|
||
|
||
(defun gnus-uu-decode-binhex (n dir)
|
||
"Unbinhexes the current article."
|
||
(interactive
|
||
(list current-prefix-arg
|
||
(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
|
||
(mm-make-temp-file (expand-file-name "binhex" gnus-uu-work-dir)))
|
||
(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."
|
||
(interactive "P")
|
||
(let ((gnus-view-pseudos (or gnus-view-pseudos 'automatic)))
|
||
(gnus-uu-decode-uu n)))
|
||
|
||
(defun gnus-uu-decode-uu-and-save-view (n dir)
|
||
"Decodes, views and saves the resulting file."
|
||
(interactive
|
||
(list current-prefix-arg
|
||
(read-file-name "Uudecode, view and save in dir: "
|
||
gnus-uu-default-dir
|
||
gnus-uu-default-dir t)))
|
||
(let ((gnus-view-pseudos (or gnus-view-pseudos 'automatic)))
|
||
(gnus-uu-decode-uu-and-save n dir)))
|
||
|
||
(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)))
|
||
(gnus-uu-decode-unshar n)))
|
||
|
||
(defun gnus-uu-decode-unshar-and-save-view (n dir)
|
||
"Unshars and saves the current article."
|
||
(interactive
|
||
(list current-prefix-arg
|
||
(read-file-name "Unshar, view and save in dir: "
|
||
gnus-uu-default-dir
|
||
gnus-uu-default-dir t)))
|
||
(let ((gnus-view-pseudos (or gnus-view-pseudos 'automatic)))
|
||
(gnus-uu-decode-unshar-and-save n dir)))
|
||
|
||
(defun gnus-uu-decode-save-view (n file)
|
||
"Saves and views the current article."
|
||
(interactive
|
||
(list current-prefix-arg
|
||
(read-file-name (if gnus-uu-save-separate-articles
|
||
"Save articles is dir: "
|
||
"Save articles in file: ")
|
||
gnus-uu-default-dir gnus-uu-default-dir)))
|
||
(let ((gnus-view-pseudos (or gnus-view-pseudos 'automatic)))
|
||
(gnus-uu-decode-save n file)))
|
||
|
||
(defun gnus-uu-decode-binhex-view (n file)
|
||
"Unbinhexes and views the current article."
|
||
(interactive
|
||
(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
|
||
(mm-make-temp-file (expand-file-name "binhex" gnus-uu-work-dir)))
|
||
(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 (&optional n post)
|
||
"Digests and forwards all articles in this series."
|
||
(interactive "P")
|
||
(let ((gnus-uu-save-in-digest t)
|
||
(file (mm-make-temp-file (nnheader-concat gnus-uu-tmp-dir "forward")))
|
||
(message-forward-as-mime message-forward-as-mime)
|
||
(mail-parse-charset gnus-newsgroup-charset)
|
||
(mail-parse-ignored-charsets gnus-newsgroup-ignored-charsets)
|
||
gnus-uu-digest-buffer subject from)
|
||
(if (and n (not (numberp n)))
|
||
(setq message-forward-as-mime (not message-forward-as-mime)
|
||
n nil))
|
||
(let ((gnus-article-reply (gnus-summary-work-articles n)))
|
||
(gnus-setup-message 'forward
|
||
(setq gnus-uu-digest-from-subject nil)
|
||
(setq gnus-uu-digest-buffer
|
||
(gnus-get-buffer-create " *gnus-uu-forward*"))
|
||
(gnus-uu-decode-save n file)
|
||
(switch-to-buffer gnus-uu-digest-buffer)
|
||
(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))
|
||
(let ((message-forward-decoded-p t))
|
||
(message-forward post t))))
|
||
(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-message-process-mark (unmarkp new-marked)
|
||
(let ((old (- (length gnus-newsgroup-processable) (length new-marked))))
|
||
(message "%d mark%s %s%s"
|
||
(length new-marked)
|
||
(if (= (length new-marked) 1) "" "s")
|
||
(if unmarkp "removed" "added")
|
||
(cond
|
||
((and (zerop old)
|
||
(not unmarkp))
|
||
"")
|
||
(unmarkp
|
||
(format ", %d remain marked"
|
||
(length gnus-newsgroup-processable)))
|
||
(t
|
||
(format ", %d already marked" old))))))
|
||
|
||
(defun gnus-new-processable (unmarkp articles)
|
||
(if unmarkp
|
||
(gnus-intersection gnus-newsgroup-processable articles)
|
||
(gnus-set-difference articles gnus-newsgroup-processable)))
|
||
|
||
(defun gnus-uu-mark-by-regexp (regexp &optional unmark)
|
||
"Set the process mark on articles whose subjects match REGEXP.
|
||
When called interactively, prompt for REGEXP.
|
||
Optional UNMARK non-nil means unmark instead of mark."
|
||
(interactive "sMark (regexp): \nP")
|
||
(save-excursion
|
||
(let* ((articles (gnus-uu-find-articles-matching regexp))
|
||
(new-marked (gnus-new-processable unmark articles)))
|
||
(while articles
|
||
(if unmark
|
||
(gnus-summary-remove-process-mark (pop articles))
|
||
(gnus-summary-set-process-mark (pop articles))))
|
||
(gnus-message-process-mark unmark new-marked)))
|
||
(gnus-summary-position-point))
|
||
|
||
(defun gnus-uu-unmark-by-regexp (regexp)
|
||
"Remove the process mark from articles whose subjects match REGEXP.
|
||
When called interactively, prompt for REGEXP."
|
||
(interactive "sUnmark (regexp): ")
|
||
(gnus-uu-mark-by-regexp regexp t))
|
||
|
||
(defun gnus-uu-mark-series ()
|
||
"Mark the current series with the process mark."
|
||
(interactive)
|
||
(let* ((articles (gnus-uu-find-articles-matching))
|
||
(l (length articles)))
|
||
(while articles
|
||
(gnus-summary-set-process-mark (car articles))
|
||
(setq articles (cdr articles)))
|
||
(message "Marked %d articles" l))
|
||
(gnus-summary-position-point))
|
||
|
||
(defun gnus-uu-mark-region (beg end &optional unmark)
|
||
"Set the process mark on all articles between point and mark."
|
||
(interactive "r")
|
||
(save-excursion
|
||
(goto-char beg)
|
||
(while (< (point) end)
|
||
(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-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-save-hidden-threads
|
||
(let ((level (gnus-summary-thread-level)))
|
||
(while (and (gnus-summary-set-process-mark
|
||
(gnus-summary-article-number))
|
||
(zerop (gnus-summary-next-subject 1 nil t))
|
||
(> (gnus-summary-thread-level) level)))))
|
||
(gnus-summary-position-point))
|
||
|
||
(defun gnus-uu-unmark-thread ()
|
||
"Unmarks all articles downwards in this thread."
|
||
(interactive)
|
||
(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."
|
||
(interactive)
|
||
(let ((data gnus-newsgroup-data)
|
||
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 (or score gnus-summary-default-score 0))
|
||
(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."
|
||
(interactive)
|
||
(let ((marked (nreverse gnus-newsgroup-processable))
|
||
subject articles total headers)
|
||
(unless marked
|
||
(error "No articles marked with the process mark"))
|
||
(setq gnus-newsgroup-processable nil)
|
||
(save-excursion
|
||
(while marked
|
||
(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)))
|
||
(while articles
|
||
(gnus-summary-set-process-mark (car articles))
|
||
(setcdr marked (delq (car articles) (cdr marked)))
|
||
(setq articles (cdr articles)))
|
||
(setq marked (cdr marked)))
|
||
(setq gnus-newsgroup-processable (nreverse total)))
|
||
(gnus-summary-position-point)))
|
||
|
||
(defun gnus-uu-mark-all ()
|
||
"Mark all articles in \"series\" order."
|
||
(interactive)
|
||
(setq gnus-newsgroup-processable nil)
|
||
(save-excursion
|
||
(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 <speed@cs.washington.edu>.
|
||
|
||
(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 (&optional n)
|
||
"Gets and views the current article."
|
||
(interactive "P")
|
||
(let ((gnus-view-pseudos (or gnus-view-pseudos 'automatic)))
|
||
(gnus-uu-decode-postscript n)))
|
||
|
||
(defun gnus-uu-decode-postscript-and-save (n dir)
|
||
"Extracts postscript and saves the current article."
|
||
(interactive
|
||
(list current-prefix-arg
|
||
(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."
|
||
(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)))
|
||
(let ((gnus-view-pseudos (or gnus-view-pseudos 'automatic)))
|
||
(gnus-uu-decode-postscript-and-save n dir)))
|
||
|
||
|
||
;; Internal functions.
|
||
|
||
(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))
|
||
;; 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)))
|
||
(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)
|
||
(setq files (gnus-uu-unpack-files files)))
|
||
(setq files (nreverse (gnus-uu-get-actions 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))
|
||
(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))
|
||
(eq gnus-uu-be-dangerous t)
|
||
(and gnus-uu-be-dangerous
|
||
(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.
|
||
|
||
;; Function called by gnus-uu-grab-articles to treat each article.
|
||
(defun gnus-uu-save-article (buffer in-state)
|
||
(cond
|
||
(gnus-uu-save-separate-articles
|
||
(save-excursion
|
||
(set-buffer buffer)
|
||
(let ((coding-system-for-write mm-text-coding-system))
|
||
(gnus-write-buffer
|
||
(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
|
||
'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)
|
||
(cond ((eq in-state 'first) (list gnus-uu-saved-article-name 'begin))
|
||
((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))
|
||
(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 (gnus-get-buffer-create "*gnus-uu-body*"))
|
||
(erase-buffer))
|
||
(save-excursion
|
||
(set-buffer (gnus-get-buffer-create "*gnus-uu-pre*"))
|
||
(erase-buffer)
|
||
(insert (format
|
||
"Date: %s\nFrom: %s\nSubject: %s Digest\n\n"
|
||
(message-make-date) name name))
|
||
(when (and message-forward-as-mime gnus-uu-digest-buffer)
|
||
(insert
|
||
"<#mml type=message/rfc822>\nSubject: Topics\n\n<#/mml>\n")
|
||
(forward-line -1))
|
||
(insert "Topics:\n")))
|
||
(when (not (eq in-state 'end))
|
||
(setq state (list 'middle))))
|
||
(save-excursion
|
||
(set-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))
|
||
(when (and message-forward-as-mime
|
||
message-forward-show-mml
|
||
gnus-uu-digest-buffer)
|
||
(mm-enable-multibyte)
|
||
(mime-to-mml))
|
||
(goto-char (point-min))
|
||
(re-search-forward "\n\n")
|
||
(unless (and message-forward-as-mime gnus-uu-digest-buffer)
|
||
;; Quote all 30-dash lines.
|
||
(save-excursion
|
||
(while (re-search-forward "^-" 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-string))
|
||
(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)))
|
||
(if (and message-forward-as-mime gnus-uu-digest-buffer)
|
||
(if message-forward-show-mml
|
||
(progn
|
||
(insert "\n<#mml type=message/rfc822>\n")
|
||
(insert sorthead) (goto-char (point-max))
|
||
(insert body) (goto-char (point-max))
|
||
(insert "\n<#/mml>\n"))
|
||
(let ((buf (mml-generate-new-buffer " *mml*")))
|
||
(with-current-buffer buf
|
||
(insert sorthead)
|
||
(goto-char (point-min))
|
||
(when (re-search-forward "^Subject: \\(.*\\)$" nil t)
|
||
(setq subj (buffer-substring (match-beginning 1)
|
||
(match-end 1))))
|
||
(goto-char (point-max))
|
||
(insert body))
|
||
(insert "\n<#part type=message/rfc822"
|
||
" buffer=\"" (buffer-name buf) "\">\n")))
|
||
(insert sorthead) (goto-char (point-max))
|
||
(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))))
|
||
(when subj
|
||
(save-excursion
|
||
(set-buffer "*gnus-uu-pre*")
|
||
(insert (format " %s\n" subj)))))
|
||
(when (or (eq in-state 'last)
|
||
(eq in-state 'first-and-last))
|
||
(if (and message-forward-as-mime gnus-uu-digest-buffer)
|
||
(with-current-buffer gnus-uu-digest-buffer
|
||
(erase-buffer)
|
||
(insert-buffer-substring "*gnus-uu-pre*")
|
||
(goto-char (point-max))
|
||
(insert-buffer-substring "*gnus-uu-body*"))
|
||
(save-excursion
|
||
(set-buffer "*gnus-uu-pre*")
|
||
(insert (format "\n\n%s\n\n" (make-string 70 ?-)))
|
||
(if gnus-uu-digest-buffer
|
||
(with-current-buffer gnus-uu-digest-buffer
|
||
(erase-buffer)
|
||
(insert-buffer-substring "*gnus-uu-pre*"))
|
||
(let ((coding-system-for-write mm-text-coding-system))
|
||
(gnus-write-buffer gnus-uu-saved-article-name))))
|
||
(save-excursion
|
||
(set-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"))
|
||
(if gnus-uu-digest-buffer
|
||
(with-current-buffer gnus-uu-digest-buffer
|
||
(goto-char (point-max))
|
||
(insert-buffer-substring "*gnus-uu-body*"))
|
||
(let ((coding-system-for-write mm-text-coding-system)
|
||
(file-name-coding-system nnmail-pathname-coding-system))
|
||
(write-region
|
||
(point-min) (point-max) gnus-uu-saved-article-name t)))))
|
||
(gnus-kill-buffer "*gnus-uu-pre*")
|
||
(gnus-kill-buffer "*gnus-uu-body*")
|
||
(push 'end state))
|
||
(if (memq 'begin state)
|
||
(cons gnus-uu-saved-article-name state)
|
||
state)))))
|
||
|
||
;; Binhex treatment - not very advanced.
|
||
|
||
(defvar gnus-uu-binhex-body-line
|
||
"^[^:]...............................................................$")
|
||
(defvar gnus-uu-binhex-begin-line
|
||
"^:...............................................................$")
|
||
(defvar gnus-uu-binhex-end-line
|
||
":$")
|
||
|
||
(defun gnus-uu-binhex-article (buffer in-state)
|
||
(let (state start-char)
|
||
(save-excursion
|
||
(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 (memq 'wrong-type state)
|
||
()
|
||
(beginning-of-line)
|
||
(setq start-char (point))
|
||
(if (looking-at gnus-uu-binhex-begin-line)
|
||
(progn
|
||
(setq state (list 'begin))
|
||
(write-region (point-min) (point-min)
|
||
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))))
|
||
(beginning-of-line)
|
||
(forward-line 1)
|
||
(when (file-exists-p gnus-uu-binhex-article-name)
|
||
(mm-append-to-file start-char (point) gnus-uu-binhex-article-name))))
|
||
(if (memq 'begin state)
|
||
(cons gnus-uu-binhex-article-name state)
|
||
state)))
|
||
|
||
;; PostScript
|
||
|
||
(defun gnus-uu-decode-postscript-article (process-buffer in-state)
|
||
(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 (gnus-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))
|
||
|
||
|
||
;; Find actions.
|
||
|
||
(defun gnus-uu-get-actions (files)
|
||
(let ((ofiles files)
|
||
action name)
|
||
(while files
|
||
(setq name (cdr (assq 'name (car files))))
|
||
(and
|
||
(setq action (gnus-uu-get-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))
|
||
|
||
(defun gnus-uu-get-action (file-name)
|
||
(let (action)
|
||
(setq action
|
||
(gnus-uu-choose-action
|
||
file-name
|
||
(append
|
||
gnus-uu-user-view-rules
|
||
(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
|
||
(gnus-uu-choose-action file-name gnus-uu-ext-to-mime-list))
|
||
(setq action (format "metamail -d -b -c \"%s\"" action))))
|
||
action))
|
||
|
||
|
||
;; Functions for treating subjects and collecting series.
|
||
|
||
(defun gnus-uu-reginize-string (string)
|
||
;; Takes a string and puts a \ in front of every special character;
|
||
;; replaces the last thing that looks like "2/3" with "[0-9]+/3"
|
||
;; or, if it can't find something like that, tries "2 of 3", then
|
||
;; finally just replaces the next to last number with "[0-9]+".
|
||
(save-excursion
|
||
(set-buffer (gnus-get-buffer-create gnus-uu-output-buffer-name))
|
||
(buffer-disable-undo)
|
||
(erase-buffer)
|
||
(insert (regexp-quote string))
|
||
|
||
(setq case-fold-search nil)
|
||
|
||
(end-of-line)
|
||
(if (re-search-backward "\\([^0-9]\\)[0-9]+/\\([0-9]+\\)" nil t)
|
||
(replace-match "\\1[0-9]+/\\2")
|
||
|
||
(end-of-line)
|
||
(if (re-search-backward "\\([^0-9]\\)[0-9]+[ \t]*of[ \t]*\\([0-9]+\\)"
|
||
nil t)
|
||
(replace-match "\\1[0-9]+ of \\2")
|
||
|
||
(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))))
|
||
|
||
(goto-char 1)
|
||
(while (re-search-forward "[ \t]+" nil t)
|
||
(replace-match "[ \t]+" t t))
|
||
|
||
(buffer-string)))
|
||
|
||
(defun gnus-uu-get-list-of-articles (n)
|
||
;; 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.
|
||
;; Failing that, articles that have subjects that are part of the
|
||
;; same "series" as the current will be returned.
|
||
(let (articles)
|
||
(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)
|
||
(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)))
|
||
|
||
(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
|
||
;; non-nil, article names are not equalized before sorting.
|
||
(let ((subject (or subject
|
||
(gnus-uu-reginize-string (gnus-summary-article-subject))))
|
||
list-of-subjects)
|
||
(save-excursion
|
||
(when subject
|
||
;; Collect all subjects matching subject.
|
||
(let ((case-fold-search t)
|
||
(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-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)
|
||
(push (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
|
||
list-of-subjects
|
||
(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
|
||
;; sorting to find out what sequence the articles are supposed to be
|
||
;; decoded in. Returns the list of expanded strings.
|
||
(let ((out-list string-list)
|
||
string)
|
||
(save-excursion
|
||
(set-buffer (gnus-get-buffer-create gnus-uu-output-buffer-name))
|
||
(buffer-disable-undo)
|
||
(while string-list
|
||
(erase-buffer)
|
||
(insert (caar string-list))
|
||
;; Translate multiple spaces to one space.
|
||
(goto-char (point-min))
|
||
(while (re-search-forward "[ \t]+" nil t)
|
||
(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)))
|
||
;; Expand numbers.
|
||
(goto-char (point-min))
|
||
(while (re-search-forward "[0-9]+" nil t)
|
||
(ignore-errors
|
||
(replace-match
|
||
(format "%06d"
|
||
(string-to-number (buffer-substring
|
||
(match-beginning 0) (match-end 0)))))))
|
||
(setq string (buffer-substring 1 (point-max)))
|
||
(setcar (car string-list) string)
|
||
(setq string-list (cdr string-list))))
|
||
out-list))
|
||
|
||
|
||
;; `gnus-uu-grab-articles' is the general multi-article treatment
|
||
;; function. It takes a list of articles to be grabbed and a function
|
||
;; 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
|
||
;; 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
|
||
;; 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 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
|
||
|
||
(defvar gnus-uu-has-been-grabbed nil)
|
||
|
||
(defun gnus-uu-unmark-list-of-grabbed (&optional dont-unmark-last-article)
|
||
(let (art)
|
||
(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)))
|
||
(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))))))
|
||
|
||
;; This function takes a list of articles and a function to apply to
|
||
;; 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
|
||
&optional sloppy limit no-errors)
|
||
(let ((state 'first)
|
||
(gnus-asynchronous nil)
|
||
(gnus-inhibit-treatment t)
|
||
has-been-begin article result-file result-files process-state
|
||
gnus-summary-display-article-function
|
||
gnus-article-prepare-hook gnus-display-mime-function
|
||
article-series files)
|
||
|
||
(while (and articles
|
||
(not (memq 'error process-state))
|
||
(or sloppy
|
||
(not (memq 'end process-state))))
|
||
|
||
(setq article (pop articles))
|
||
(when (vectorp (gnus-summary-article-header article))
|
||
(push article article-series)
|
||
|
||
(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)))
|
||
(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)))
|
||
(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)
|
||
(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
|
||
(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))
|
||
(gnus-message 2 "No begin part at the beginning")
|
||
(sleep-for 2))
|
||
(setq state 'middle))))
|
||
|
||
;; When there are no result-files, then something must be wrong.
|
||
(if result-files
|
||
(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))))
|
||
|
||
;; The original article buffer is hosed, shoot it down.
|
||
(gnus-kill-buffer gnus-original-article-buffer)
|
||
(setq gnus-current-article nil)
|
||
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* ((header (gnus-summary-article-header article))
|
||
(subject (and header (mail-header-subject header)))
|
||
(part nil))
|
||
(if subject
|
||
(while (string-match "[0-9]+/[0-9]+\\|[0-9]+[ \t]+of[ \t]+[0-9]+"
|
||
subject)
|
||
(setq part (match-string 0 subject))
|
||
(setq subject (substring subject (match-end 0)))))
|
||
(or part
|
||
(while (string-match "\\([0-9]+\\)[^0-9]+\\([0-9]+\\)" subject)
|
||
(setq part (match-string 0 subject))
|
||
(setq subject (substring subject (match-end 0)))))
|
||
(or part "")))
|
||
|
||
(defun gnus-uu-uudecode-sentinel (process event)
|
||
(delete-process (get-process process)))
|
||
|
||
(defun gnus-uu-uustrip-article (process-buffer in-state)
|
||
;; Uudecodes a file asynchronously.
|
||
(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))
|
||
|
||
;; 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))))
|
||
|
||
(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))
|
||
|
||
(if (not (looking-at gnus-uu-begin-string))
|
||
(setq state (list 'middle))
|
||
;; This is the beginning of a uuencoded article.
|
||
;; We replace certain characters that could make things messy.
|
||
(setq gnus-uu-file-name
|
||
(gnus-map-function
|
||
mm-file-name-rewrite-functions
|
||
(file-name-nondirectory (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)
|
||
(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*"
|
||
(gnus-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)
|
||
(push 'end state)
|
||
(goto-char (point-max))
|
||
(re-search-backward gnus-uu-body-line nil t))
|
||
|
||
(forward-line 1)
|
||
|
||
(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)))
|
||
(gnus-run-hooks 'gnus-uu-pre-uudecode-hook)
|
||
|
||
;; 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.
|
||
(ignore-errors
|
||
(process-send-eof gnus-uu-uudecode-process))
|
||
(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 (if (= (length files) 1) (car files) files) state)
|
||
state))))
|
||
|
||
(defvar gnus-uu-unshar-warning
|
||
"*** WARNING ***
|
||
|
||
Shell archives are an archaic method of bundling files for distribution
|
||
across computer networks. During the unpacking process, arbitrary commands
|
||
are executed on your system, and all kinds of nasty things can happen.
|
||
Please examine the archive very carefully before you instruct Emacs to
|
||
unpack it. You can browse the archive buffer using \\[scroll-other-window].
|
||
|
||
If you are unsure what to do, please answer \"no\"."
|
||
"Text of warning message displayed by `gnus-uu-unshar-article'.
|
||
Make sure that this text consists only of few text lines. Otherwise,
|
||
Gnus might fail to display all of it.")
|
||
|
||
|
||
;; This function is used by `gnus-uu-grab-articles' to treat
|
||
;; a shared article.
|
||
(defun gnus-uu-unshar-article (process-buffer in-state)
|
||
(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))
|
||
(save-window-excursion
|
||
(save-excursion
|
||
(switch-to-buffer (current-buffer))
|
||
(delete-other-windows)
|
||
(let ((buffer (get-buffer-create (generate-new-buffer-name
|
||
"*Warning*"))))
|
||
(unless
|
||
(unwind-protect
|
||
(with-current-buffer buffer
|
||
(insert (substitute-command-keys
|
||
gnus-uu-unshar-warning))
|
||
(goto-char (point-min))
|
||
(display-buffer buffer)
|
||
(yes-or-no-p "This is a shell archive, unshar it? "))
|
||
(kill-buffer buffer))
|
||
(setq state (list 'error))))))
|
||
(unless (memq 'error state)
|
||
(beginning-of-line)
|
||
(setq start-char (point))
|
||
(call-process-region
|
||
start-char (point-max) shell-file-name nil
|
||
(gnus-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.
|
||
(defun gnus-uu-find-name-in-shar ()
|
||
(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))))
|
||
(goto-char oldpoint)
|
||
res))
|
||
|
||
;; `gnus-uu-choose-action' chooses what action to perform given the name
|
||
;; and `gnus-uu-file-action-list'. Returns either nil if no action is
|
||
;; 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
|
||
(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)
|
||
""))))))
|
||
(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)))))
|
||
action))
|
||
|
||
(defun gnus-uu-treat-archive (file-path)
|
||
;; Unpacks an archive. Returns t if unpacking is successful.
|
||
(let ((did-unpack t)
|
||
action command dir)
|
||
(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))
|
||
|
||
(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))
|
||
|
||
(setq command (format "cd %s ; %s" dir (gnus-uu-command action file-path)))
|
||
|
||
(save-excursion
|
||
(set-buffer (gnus-get-buffer-create gnus-uu-output-buffer-name))
|
||
(erase-buffer))
|
||
|
||
(gnus-message 5 "Unpacking: %s..." (gnus-uu-command action file-path))
|
||
|
||
(if (eq 0 (call-process shell-file-name nil
|
||
(gnus-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))
|
||
|
||
did-unpack))
|
||
|
||
(defun gnus-uu-dir-files (dir)
|
||
(let ((dirs (directory-files dir t "[^/][^\\.][^\\.]?$"))
|
||
files file)
|
||
(while dirs
|
||
(if (file-directory-p (setq file (car dirs)))
|
||
(setq files (append files (gnus-uu-dir-files file)))
|
||
(push file files))
|
||
(setq dirs (cdr dirs)))
|
||
files))
|
||
|
||
(defun gnus-uu-unpack-files (files &optional ignore)
|
||
;; 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)))
|
||
(setq files (cdr files)))
|
||
(if did-unpack
|
||
(gnus-uu-unpack-files ofiles (append did-unpack ignore))
|
||
ofiles)))
|
||
|
||
(defun gnus-uu-ls-r (dir)
|
||
(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)))))
|
||
(setq files (cdr files)))
|
||
ofiles))
|
||
|
||
;; Various stuff
|
||
|
||
(defun gnus-uu-directory-files (dir &optional full)
|
||
(let (files out file)
|
||
(setq files (directory-files dir full))
|
||
(while files
|
||
(setq file (car files))
|
||
(setq files (cdr files))
|
||
(unless (member (file-name-nondirectory file) '("." ".."))
|
||
(push file out)))
|
||
(setq out (nreverse out))
|
||
out))
|
||
|
||
(defun gnus-uu-check-correct-stripped-uucode (start end)
|
||
(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
|
||
(when (looking-at "\n")
|
||
(replace-match ""))
|
||
(forward-line 1))))
|
||
|
||
(while (not (eobp))
|
||
(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)))
|
||
(setq found t)
|
||
(beginning-of-line)
|
||
(setq beg (point))
|
||
(end-of-line)
|
||
(when (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)
|
||
(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)))
|
||
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)
|
||
(when (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
|
||
(mm-make-temp-file (concat gnus-uu-tmp-dir "gnus") '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))))
|
||
|
||
|
||
;; Kills the temporary uu buffers, kills any processes, etc.
|
||
(defun gnus-uu-clean-up ()
|
||
(let (buf)
|
||
(and gnus-uu-uudecode-process
|
||
(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))))
|
||
|
||
;; 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.
|
||
(defun gnus-uu-command (action file)
|
||
(let ((quoted-file (mm-quote-arg file)))
|
||
(if (string-match "%s" action)
|
||
(format action quoted-file)
|
||
(concat action " " quoted-file))))
|
||
|
||
(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)
|
||
(condition-case err
|
||
(delete-file file)
|
||
(error (gnus-message 3 "Deleting file %s failed... %s" file err))))))
|
||
(condition-case err
|
||
(delete-directory dir)
|
||
(error (gnus-message 3 "Deleting directory %s failed... %s" file err))))
|
||
(gnus-message 7 "")))
|
||
|
||
;; Initializing
|
||
|
||
(add-hook 'gnus-exit-group-hook 'gnus-uu-clean-up)
|
||
(add-hook 'gnus-exit-group-hook 'gnus-uu-delete-work-dir)
|
||
|
||
|
||
|
||
;;;
|
||
;;; uuencoded posting
|
||
;;;
|
||
|
||
;; 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"
|
||
;; 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
|
||
"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")))
|
||
|
||
(defcustom 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)
|
||
|
||
(defcustom 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)
|
||
|
||
(defcustom 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...) The default is nil."
|
||
:group 'gnus-extract-post
|
||
:type 'boolean)
|
||
|
||
(defcustom 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)
|
||
|
||
(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)
|
||
|
||
(defun gnus-uu-post-news ()
|
||
"Compose an article and post an encoded file."
|
||
(interactive)
|
||
(setq gnus-uu-post-inserted-file-name nil)
|
||
(setq gnus-uu-winconf-post-news (current-window-configuration))
|
||
|
||
(gnus-summary-post-news)
|
||
|
||
(let ((map (make-sparse-keymap)))
|
||
(set-keymap-parent map (current-local-map))
|
||
(use-local-map map))
|
||
;;(local-set-key "\C-c\C-c" 'gnus-summary-edit-article-done)
|
||
(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)))))
|
||
|
||
(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
|
||
(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))
|
||
|
||
;; 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))
|
||
|
||
;; Encodes with base64 and adds MIME headers
|
||
(defun gnus-uu-post-encode-mime (path file-name)
|
||
(when (eq 0 (call-process shell-file-name nil t nil shell-command-switch
|
||
(format "%s %s -o %s" "mmencode" path file-name)))
|
||
(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)
|
||
file-name))
|
||
(insert (format "Content-Transfer-Encoding: %s\n\n" encoding))
|
||
(save-restriction
|
||
(set-buffer gnus-message-buffer)
|
||
(goto-char (point-min))
|
||
(re-search-forward (concat "^" (regexp-quote mail-header-separator) "$"))
|
||
(forward-line -1)
|
||
(narrow-to-region (point-min) (point))
|
||
(unless (mail-fetch-field "mime-version")
|
||
(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)
|
||
(eq 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)
|
||
|
||
(let (file-name)
|
||
|
||
(if gnus-uu-post-inserted-file-name
|
||
(setq file-name gnus-uu-post-inserted-file-name)
|
||
(setq file-name (gnus-uu-post-insert-binary)))
|
||
|
||
(gnus-uu-post-encoded file-name gnus-uu-post-threaded))
|
||
(setq gnus-uu-post-inserted-file-name nil)
|
||
(when 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.
|
||
(defun gnus-uu-post-insert-binary ()
|
||
(let ((uuencode-buffer-name "*uuencode buffer*")
|
||
file-path uubuf 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))
|
||
|
||
(goto-char (point-max))
|
||
(insert (format "\n%s\n" gnus-uu-post-binary-separator))
|
||
|
||
;; #### Unix-specific?
|
||
(when (string-match "^~/" file-path)
|
||
(setq file-path (concat "$HOME" (substring file-path 1))))
|
||
;; #### Unix-specific?
|
||
(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
|
||
(gnus-get-buffer-create uuencode-buffer-name)))
|
||
(erase-buffer)
|
||
(funcall gnus-uu-post-encode-method file-path file-name))
|
||
(insert-buffer-substring uubuf)
|
||
(error "Encoding unsuccessful"))
|
||
(kill-buffer uubuf))
|
||
file-name))
|
||
|
||
;; Posts the article and all of the encoded file.
|
||
(defun gnus-uu-post-encoded (file-name &optional threaded)
|
||
(let ((send-buffer-name "*uuencode send buffer*")
|
||
(encoded-buffer-name "*encoded buffer*")
|
||
(top-string "[ cut here %s (%s %d/%d) %s gnus-uu ]")
|
||
(separator (concat mail-header-separator "\n\n"))
|
||
uubuf length parts header i end beg
|
||
beg-line minlen post-buf whole-len beg-binary end-binary)
|
||
|
||
(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"))
|
||
(beginning-of-line)
|
||
(forward-line 1)
|
||
(setq beg-binary (point))
|
||
(setq end-binary (point-max))
|
||
|
||
(save-excursion
|
||
(set-buffer (setq uubuf (gnus-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 (point-min) (point-max)))
|
||
(setq parts (/ length gnus-uu-post-length))
|
||
(unless (< (% length gnus-uu-post-length) 4)
|
||
(incf parts)))
|
||
|
||
(when gnus-uu-post-separate-description
|
||
(forward-line -1))
|
||
(delete-region (point) (point-max))
|
||
|
||
(goto-char (point-min))
|
||
(re-search-forward
|
||
(concat "^" (regexp-quote mail-header-separator) "$") nil t)
|
||
(beginning-of-line)
|
||
(setq header (buffer-substring (point-min) (point)))
|
||
|
||
(goto-char (point-min))
|
||
(when gnus-uu-post-separate-description
|
||
(when (re-search-forward "^Subject: " nil t)
|
||
(end-of-line)
|
||
(insert (format " (0/%d)" parts)))
|
||
(save-excursion
|
||
(message-send))
|
||
(setq gnus-uu-post-message-id (message-fetch-field "message-id")))
|
||
|
||
(save-excursion
|
||
(setq i 1)
|
||
(setq beg 1)
|
||
(while (not (> i parts))
|
||
(set-buffer (gnus-get-buffer-create send-buffer-name))
|
||
(erase-buffer)
|
||
(insert header)
|
||
(when (and threaded gnus-uu-post-message-id)
|
||
(insert "References: " gnus-uu-post-message-id "\n"))
|
||
(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
|
||
(format top-string
|
||
(make-string minlen ?-)
|
||
file-name i parts
|
||
(make-string
|
||
(if (= 0 (% whole-len 2)) (1- minlen) minlen) ?-)))
|
||
|
||
(goto-char (point-min))
|
||
(when (re-search-forward "^Subject: " nil t)
|
||
(end-of-line)
|
||
(insert (format " (%d/%d)" i parts)))
|
||
|
||
(goto-char (point-max))
|
||
(save-excursion
|
||
(set-buffer uubuf)
|
||
(goto-char beg)
|
||
(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))
|
||
(setq end (point)))
|
||
(insert-buffer-substring uubuf beg end)
|
||
(insert beg-line "\n")
|
||
(setq beg end)
|
||
(incf i)
|
||
(goto-char (point-min))
|
||
(re-search-forward
|
||
(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))
|
||
(insert beg-line)
|
||
(insert "\n")
|
||
(let (message-sent-message-via)
|
||
(save-excursion
|
||
(message-send))
|
||
(setq gnus-uu-post-message-id
|
||
(concat (message-fetch-field "references") " "
|
||
(message-fetch-field "message-id"))))))
|
||
|
||
(gnus-kill-buffer send-buffer-name)
|
||
(gnus-kill-buffer encoded-buffer-name)
|
||
|
||
(when (not gnus-uu-post-separate-description)
|
||
(set-buffer-modified-p nil)
|
||
(when (fboundp 'bury-buffer)
|
||
(bury-buffer)))))
|
||
|
||
(provide 'gnus-uu)
|
||
|
||
;;; arch-tag: 05312384-0a83-4720-9a58-b3160b888853
|
||
;;; gnus-uu.el ends here
|