X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-soup.el;h=6862001c4b5bf31046a7c77560175257c7fc5192;hb=b74fac078f05fa78c65ef6ac22a644331120f096;hp=7b7b50ed66e5fef83f89a89279f654842aab0a8b;hpb=b426e91aa147782523fb56cedb1232df6c323fa5;p=elisp%2Fgnus.git- diff --git a/lisp/gnus-soup.el b/lisp/gnus-soup.el index 7b7b50e..6862001 100644 --- a/lisp/gnus-soup.el +++ b/lisp/gnus-soup.el @@ -1,5 +1,7 @@ ;;; gnus-soup.el --- SOUP packet writing support for Gnus -;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc. + +;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2002, 2003, 2004, +;; 2005 Free Software Foundation, Inc. ;; Author: Per Abrahamsen ;; Lars Magne Ingebrigtsen @@ -19,8 +21,8 @@ ;; 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., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. ;;; Commentary: @@ -67,9 +69,9 @@ The SOUP packet file name will be inserted at the %s.") ;;; Internal Variables: -(defvar gnus-soup-encoding-type ?n +(defvar gnus-soup-encoding-type ?u "*Soup encoding type. -`n' is news format, `m' is Unix mbox format, and `M' is MMDF mailbox +`u' is USENET news format, `m' is Unix mbox format, and `M' is MMDF mailbox format.") (defvar gnus-soup-index-type ?c @@ -140,25 +142,23 @@ move those articles instead." (buffer-disable-undo tmp-buf) (save-excursion (while articles - ;; Find the header of the article. - (set-buffer gnus-summary-buffer) - (when (setq headers (gnus-summary-article-header (car articles))) - ;; Put the article in a buffer. - (set-buffer tmp-buf) - (when (gnus-request-article-this-buffer - (car articles) gnus-newsgroup-name) - (save-restriction - (message-narrow-to-head) - (message-remove-header gnus-soup-ignored-headers t)) - (gnus-soup-store gnus-soup-directory prefix headers - gnus-soup-encoding-type - gnus-soup-index-type) - (gnus-soup-area-set-number - area (1+ (or (gnus-soup-area-number area) 0))))) - ;; Mark article as read. - (set-buffer gnus-summary-buffer) + ;; Put the article in a buffer. + (set-buffer tmp-buf) + (when (gnus-request-article-this-buffer + (car articles) gnus-newsgroup-name) + (setq headers (nnheader-parse-head t)) + (save-restriction + (message-narrow-to-head) + (message-remove-header gnus-soup-ignored-headers t)) + (gnus-soup-store gnus-soup-directory prefix headers + gnus-soup-encoding-type + gnus-soup-index-type) + (gnus-soup-area-set-number + area (1+ (or (gnus-soup-area-number area) 0))) + ;; Mark article as read. + (set-buffer gnus-summary-buffer) + (gnus-summary-mark-as-read (car articles) gnus-souped-mark)) (gnus-summary-remove-process-mark (car articles)) - (gnus-summary-mark-as-read (car articles) gnus-souped-mark) (setq articles (cdr articles))) (kill-buffer tmp-buf)) (gnus-soup-save-areas) @@ -168,11 +168,11 @@ move those articles instead." "Make a SOUP packet from the SOUP areas." (interactive) (gnus-soup-read-areas) - (unless (file-exists-p gnus-soup-directory) - (message "No such directory: %s" gnus-soup-directory)) - (when (null (directory-files gnus-soup-directory nil "\\.MSG$")) - (message "No files to pack.")) - (gnus-soup-pack gnus-soup-directory gnus-soup-packer)) + (if (file-exists-p gnus-soup-directory) + (if (directory-files gnus-soup-directory nil "\\.MSG$") + (gnus-soup-pack gnus-soup-directory gnus-soup-packer) + (message "No files to pack.")) + (message "No such directory: %s" gnus-soup-directory))) (defun gnus-group-brew-soup (n) "Make a soup packet from the current group. @@ -247,7 +247,8 @@ Note -- this function hasn't been implemented yet." ;; a soup header. (setq head-line (cond - ((= gnus-soup-encoding-type ?n) + ((or (= gnus-soup-encoding-type ?u) + (= gnus-soup-encoding-type ?n)) ;;Gnus back compatibility. (format "#! rnews %d\n" (buffer-size))) ((= gnus-soup-encoding-type ?m) (while (search-forward "\nFrom " nil t) @@ -277,7 +278,7 @@ Note -- this function hasn't been implemented yet." If NOT-ALL, don't pack ticked articles." (let ((gnus-expert-user t) (gnus-large-newsgroup nil) - (entry (gnus-gethash group gnus-newsrc-hashtb))) + (entry (gnus-group-entry group))) (when (or (null entry) (eq (car entry) t) (and (car entry) @@ -337,7 +338,9 @@ If NOT-ALL, don't pack ticked articles." (while (setq prefix (pop prefixes)) (erase-buffer) (insert (format "(setq gnus-soup-prev-prefix %d)\n" (cdr prefix))) - (gnus-write-buffer (concat (car prefix) gnus-soup-prefix-file)))))) + (gnus-write-buffer-as-coding-system + nnheader-text-coding-system + (concat (car prefix) gnus-soup-prefix-file)))))) (defun gnus-soup-pack (dir packer) (let* ((files (mapconcat 'identity @@ -347,17 +350,17 @@ If NOT-ALL, don't pack ticked articles." (packer (if (< (string-match "%s" packer) (string-match "%d" packer)) (format packer files - (string-to-int (gnus-soup-unique-prefix dir))) + (string-to-number (gnus-soup-unique-prefix dir))) (format packer - (string-to-int (gnus-soup-unique-prefix dir)) + (string-to-number (gnus-soup-unique-prefix dir)) files))) (dir (expand-file-name dir))) (gnus-make-directory dir) (setq gnus-soup-areas nil) (gnus-message 4 "Packing %s..." packer) - (if (zerop (call-process shell-file-name - nil nil nil shell-command-switch - (concat "cd " dir " ; " packer))) + (if (eq 0 (call-process shell-file-name + nil nil nil shell-command-switch + (concat "cd " dir " ; " packer))) (progn (call-process shell-file-name nil nil nil shell-command-switch (concat "cd " dir " ; rm " files)) @@ -383,7 +386,7 @@ though the two last may be nil if they are missing." (and (eq (preceding-char) ?\t) (gnus-soup-field)) (and (eq (preceding-char) ?\t) - (string-to-int (gnus-soup-field)))) + (string-to-number (gnus-soup-field)))) areas) (when (eq (preceding-char) ?\t) (beginning-of-line 2))) @@ -494,10 +497,10 @@ Return whether the unpacking was successful." (gnus-make-directory dir) (gnus-message 4 "Unpacking: %s" (format unpacker packet)) (prog1 - (zerop (call-process - shell-file-name nil nil nil shell-command-switch - (format "cd %s ; %s" (expand-file-name dir) - (format unpacker packet)))) + (eq 0 (call-process + shell-file-name nil nil nil shell-command-switch + (format "cd %s ; %s" (expand-file-name dir) + (format unpacker packet)))) (gnus-message 4 "Unpacking...done"))) (defun gnus-soup-send-packet (packet) @@ -515,9 +518,12 @@ Return whether the unpacking was successful." (tmp-buf (gnus-get-buffer-create " *soup send*")) beg end) (cond - ((/= (gnus-soup-encoding-format - (gnus-soup-reply-encoding (car replies))) - ?n) + ((and (/= (gnus-soup-encoding-format + (gnus-soup-reply-encoding (car replies))) + ?u) + (/= (gnus-soup-encoding-format + (gnus-soup-reply-encoding (car replies))) + ?n)) ;; Gnus back compatibility. (error "Unsupported encoding")) ((null msg-buf) t) @@ -530,30 +536,40 @@ Return whether the unpacking was successful." (error "Bad header")) (forward-line 1) (setq beg (point) - end (+ (point) (string-to-int + end (+ (point) (string-to-number (buffer-substring (match-beginning 1) (match-end 1))))) (switch-to-buffer tmp-buf) (erase-buffer) + (set-buffer-multibyte nil) (insert-buffer-substring msg-buf beg end) - (goto-char (point-min)) - (search-forward "\n\n") - (forward-char -1) - (insert mail-header-separator) - (setq message-user-agent (gnus-extended-version)) (cond ((string= (gnus-soup-reply-kind (car replies)) "news") (gnus-message 5 "Sending news message to %s..." (mail-fetch-field "newsgroups")) (sit-for 1) (let ((message-syntax-checks - 'dont-check-for-anything-just-trust-me)) - (funcall message-send-news-function))) + 'dont-check-for-anything-just-trust-me) + (method (if (functionp message-post-method) + (funcall message-post-method) + message-post-method)) + result) + (run-hooks 'message-send-news-hook) + (gnus-open-server method) + (message "Sending news via %s..." + (gnus-server-string method)) + (unless (let ((mail-header-separator "")) + (gnus-request-post method)) + (message "Couldn't send message via news: %s" + (nnheader-get-report (car method)))))) ((string= (gnus-soup-reply-kind (car replies)) "mail") (gnus-message 5 "Sending mail to %s..." (mail-fetch-field "to")) (sit-for 1) - (message-send-mail)) + (let ((mail-header-separator "")) + (mm-with-unibyte-current-buffer + (funcall (or message-send-mail-real-function + message-send-mail-function))))) (t (error "Unknown reply kind"))) (set-buffer msg-buf)