cgit.sxemacs.org Git - gnus/blob - lisp/nndraft.el

   1 ;;; nndraft.el --- draft article access for Gnus
   2
   3 ;; Copyright (C) 1995-2013 Free Software Foundation, Inc.
   4
   5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   6 ;; Keywords: news
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software: you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation, either version 3 of the License, or
  13 ;; (at your option) any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 ;;; Commentary:
  24
  25 ;;; Code:
  26
  27 ;; For Emacs <22.2 and XEmacs.
  28 (eval-and-compile
  29   (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
  30
  31 (require 'nnheader)
  32 (require 'nnmail)
  33 (require 'gnus-start)
  34 (require 'gnus-group)
  35 (require 'nnmh)
  36 (require 'nnoo)
  37 (require 'mm-util)
  38 (eval-when-compile (require 'cl))
  39
  40 ;; The nnoo-import at the end, I think.
  41 (declare-function nndraft-request-list "nndraft" (&rest args) t)
  42
  43 (nnoo-declare nndraft
  44   nnmh)
  45
  46 (defvoo nndraft-directory (nnheader-concat gnus-directory "drafts/")
  47   "Where nndraft will store its files."
  48   nnmh-directory)
  49
  50 (defvar nndraft-required-headers '(Date)
  51   "*Headers to be generated when saving a draft message.
  52 The headers in this variable and the ones in `message-required-headers'
  53 are generated if and only if they are also in `message-draft-headers'.")
  54
  55 \f
  56
  57 (defvoo nndraft-current-group "" nil nnmh-current-group)
  58 (defvoo nndraft-get-new-mail nil nil nnmh-get-new-mail)
  59 (defvoo nndraft-current-directory nil nil nnmh-current-directory)
  60
  61 (defconst nndraft-version "nndraft 1.0")
  62 (defvoo nndraft-status-string "" nil nnmh-status-string)
  63
  64 \f
  65
  66 ;;; Interface functions.
  67
  68 (nnoo-define-basics nndraft)
  69
  70 (deffoo nndraft-open-server (server &optional defs)
  71   (nnoo-change-server 'nndraft server defs)
  72   (cond
  73    ((not (file-exists-p nndraft-directory))
  74     (nndraft-close-server)
  75     (nnheader-report 'nndraft "No such file or directory: %s"
  76                      nndraft-directory))
  77    ((not (file-directory-p (file-truename nndraft-directory)))
  78     (nndraft-close-server)
  79     (nnheader-report 'nndraft "Not a directory: %s" nndraft-directory))
  80    (t
  81     (nnheader-report 'nndraft "Opened server %s using directory %s"
  82                      server nndraft-directory)
  83     t)))
  84
  85 (deffoo nndraft-retrieve-headers (articles &optional group server fetch-old)
  86   (nndraft-possibly-change-group group)
  87   (with-current-buffer nntp-server-buffer
  88     (erase-buffer)
  89     (let (article lines chars)
  90       ;; We don't support fetching by Message-ID.
  91       (if (stringp (car articles))
  92           'headers
  93         (while articles
  94           (narrow-to-region (point) (point))
  95           (when (nndraft-request-article
  96                  (setq article (pop articles)) group server (current-buffer))
  97             (goto-char (point-min))
  98             (if (search-forward "\n\n" nil t)
  99                 (forward-line -1)
 100               (goto-char (point-max)))
 101             (setq lines (count-lines (point) (point-max))
 102                   chars (- (point-max) (point)))
 103             (delete-region (point) (point-max))
 104             (goto-char (point-min))
 105             (insert (format "221 %d Article retrieved.\n" article))
 106             (insert (format "Lines: %d\nChars: %d\n" lines chars))
 107             (widen)
 108             (goto-char (point-max))
 109             (insert ".\n")))
 110
 111         (nnheader-fold-continuation-lines)
 112         'headers))))
 113
 114 (deffoo nndraft-request-article (id &optional group server buffer)
 115   (nndraft-possibly-change-group group)
 116   (when (numberp id)
 117     ;; We get the newest file of the auto-saved file and the
 118     ;; "real" file.
 119     (let* ((file (nndraft-article-filename id))
 120            (auto (nndraft-auto-save-file-name file))
 121            (newest (if (file-newer-than-file-p file auto) file auto))
 122            (nntp-server-buffer (or buffer nntp-server-buffer)))
 123       (when (and (file-exists-p newest)
 124                  (let ((nnmail-file-coding-system
 125                         (if (file-newer-than-file-p file auto)
 126                             (if (member group '("drafts" "delayed"))
 127                                 message-draft-coding-system
 128                               mm-text-coding-system)
 129                           mm-auto-save-coding-system)))
 130                    (nnmail-find-file newest)))
 131         (with-current-buffer nntp-server-buffer
 132           (goto-char (point-min))
 133           ;; If there's a mail header separator in this file,
 134           ;; we remove it.
 135           (when (re-search-forward
 136                  (concat "^" (regexp-quote mail-header-separator) "$") nil t)
 137             (replace-match "" t t)))
 138         t))))
 139
 140 (deffoo nndraft-request-restore-buffer (article &optional group server)
 141   "Request a new buffer that is restored to the state of ARTICLE."
 142   (nndraft-possibly-change-group group)
 143   (when (nndraft-request-article article group server (current-buffer))
 144     (message-remove-header "xref")
 145     (message-remove-header "lines")
 146     ;; Articles in nndraft:queue are considered as sent messages.  The
 147     ;; Date field should be the time when they are sent.
 148     ;;(message-remove-header "date")
 149     t))
 150
 151 (deffoo nndraft-request-update-info (group info &optional server)
 152   (nndraft-possibly-change-group group)
 153   (gnus-info-set-read
 154    info
 155    (gnus-update-read-articles (gnus-group-prefixed-name group '(nndraft ""))
 156                               (nndraft-articles) t))
 157   (let ((marks (nth 3 info)))
 158     (when marks
 159       ;; Nix out all marks except the `unsend'-able article marks.
 160       (setcar (nthcdr 3 info)
 161               (if (assq 'unsend marks)
 162                   (list (assq 'unsend marks))
 163                 nil))))
 164   t)
 165
 166 (defun nndraft-generate-headers ()
 167   (save-excursion
 168     (message-generate-headers
 169      (message-headers-to-generate
 170       nndraft-required-headers message-draft-headers nil))))
 171
 172 (defun nndraft-update-unread-articles ()
 173   "Update groups' unread articles in the group buffer."
 174   (nndraft-request-list)
 175   (with-current-buffer gnus-group-buffer
 176     (let* ((groups (mapcar (lambda (elem)
 177                              (gnus-group-prefixed-name (car elem)
 178                                                        (list 'nndraft "")))
 179                            (nnmail-get-active)))
 180            (gnus-group-marked (copy-sequence groups))
 181            ;; Don't send delayed articles.
 182            (gnus-get-new-news-hook nil)
 183            (inhibit-read-only t))
 184       (gnus-group-get-new-news-this-group nil t)
 185       (save-excursion
 186         (dolist (group groups)
 187           (unless (and gnus-permanently-visible-groups
 188                        (string-match gnus-permanently-visible-groups
 189                                      group))
 190             (gnus-group-goto-group group)
 191             (when (zerop (gnus-group-group-unread))
 192               (gnus-delete-line))))))))
 193
 194 (deffoo nndraft-request-associate-buffer (group)
 195   "Associate the current buffer with some article in the draft group."
 196   (nndraft-open-server "")
 197   (nndraft-request-group group)
 198   (nndraft-possibly-change-group group)
 199   (let ((gnus-verbose-backends nil)
 200         (buf (current-buffer))
 201         article file)
 202     (with-temp-buffer
 203       (insert-buffer-substring buf)
 204       (setq article (nndraft-request-accept-article
 205                      group (nnoo-current-server 'nndraft) t 'noinsert)
 206             file (nndraft-article-filename article)))
 207     (setq buffer-file-name (expand-file-name file)
 208           buffer-auto-save-file-name (make-auto-save-file-name))
 209     (clear-visited-file-modtime)
 210     (let ((hook (if (boundp 'write-contents-functions)
 211                     'write-contents-functions
 212                   'write-contents-hooks)))
 213       (gnus-make-local-hook hook)
 214       (add-hook hook 'nndraft-generate-headers nil t))
 215     (gnus-make-local-hook 'after-save-hook)
 216     (add-hook 'after-save-hook 'nndraft-update-unread-articles nil t)
 217     (message-add-action '(nndraft-update-unread-articles)
 218                         'exit 'postpone 'kill)
 219     article))
 220
 221 (deffoo nndraft-request-group (group &optional server dont-check info)
 222   (nndraft-possibly-change-group group)
 223   (unless dont-check
 224     (let* ((pathname (nnmail-group-pathname group nndraft-directory))
 225            (file-name-coding-system nnmail-pathname-coding-system)
 226            dir file)
 227       (nnheader-re-read-dir pathname)
 228       (setq dir (mapcar (lambda (name) (string-to-number (substring name 1)))
 229                         (ignore-errors (directory-files
 230                                         pathname nil "^#[0-9]+#$" t))))
 231       (dolist (n dir)
 232         (unless (file-exists-p
 233                  (setq file (expand-file-name (int-to-string n) pathname)))
 234           (rename-file (nndraft-auto-save-file-name file) file)))))
 235   (nnoo-parent-function 'nndraft
 236                         'nnmh-request-group
 237                         (list group server dont-check)))
 238
 239 (deffoo nndraft-request-move-article (article group server accept-form
 240                                       &optional last move-is-internal)
 241   (nndraft-possibly-change-group group)
 242   (let ((buf (get-buffer-create " *nndraft move*"))
 243         result)
 244     (and
 245      (nndraft-request-article article group server)
 246      (with-current-buffer buf
 247        (erase-buffer)
 248        (insert-buffer-substring nntp-server-buffer)
 249        (setq result (eval accept-form))
 250        (kill-buffer (current-buffer))
 251        result)
 252      (null (nndraft-request-expire-articles (list article) group server 'force))
 253      result)))
 254
 255 (deffoo nndraft-request-expire-articles (articles group &optional server force)
 256   (nndraft-possibly-change-group group)
 257   (let* ((nnmh-allow-delete-final t)
 258          (nnmail-expiry-target 'delete)
 259          ;; FIXME: If we want to move a draft message to an expiry group,
 260          ;; there are things to have to improve:
 261          ;; - Remove a header separator.
 262          ;; - Encode it, including attachments, into a MIME message.
 263          ;;(nnmail-expiry-target
 264          ;; (or (gnus-group-find-parameter
 265          ;;      (gnus-group-prefixed-name group (list 'nndraft server))
 266          ;;      'expiry-target t)
 267          ;;     nnmail-expiry-target))
 268          (res (nnoo-parent-function 'nndraft
 269                                     'nnmh-request-expire-articles
 270                                     (list articles group server force)))
 271          article)
 272     ;; Delete all the "state" files of articles that have been expired.
 273     (while articles
 274       (unless (memq (setq article (pop articles)) res)
 275         (let ((auto (nndraft-auto-save-file-name
 276                      (nndraft-article-filename article))))
 277           (when (file-exists-p auto)
 278             (funcall nnmail-delete-file-function auto)))
 279         (dolist (backup
 280                  (let ((kept-new-versions 1)
 281                        (kept-old-versions 0))
 282                    (find-backup-file-name
 283                     (nndraft-article-filename article))))
 284           (when (file-exists-p backup)
 285             (funcall nnmail-delete-file-function backup)))))
 286     res))
 287
 288 (deffoo nndraft-request-accept-article (group &optional server last noinsert)
 289   (nndraft-possibly-change-group group)
 290   (let ((gnus-verbose-backends nil))
 291     (nnoo-parent-function 'nndraft 'nnmh-request-accept-article
 292                           (list group server last noinsert))))
 293
 294 (deffoo nndraft-request-replace-article (article group buffer)
 295   (nndraft-possibly-change-group group)
 296   (let ((nnmail-file-coding-system
 297          (if (member group '("drafts" "delayed"))
 298              message-draft-coding-system
 299            mm-text-coding-system)))
 300     (nnoo-parent-function 'nndraft 'nnmh-request-replace-article
 301                           (list article group buffer))))
 302
 303 (deffoo nndraft-request-create-group (group &optional server args)
 304   (nndraft-possibly-change-group group)
 305   (if (file-exists-p nndraft-current-directory)
 306       (if (file-directory-p nndraft-current-directory)
 307           t
 308         nil)
 309     (condition-case ()
 310         (progn
 311           (gnus-make-directory nndraft-current-directory)
 312           t)
 313       (file-error nil))))
 314
 315 \f
 316 ;;; Low-Level Interface
 317
 318 (defun nndraft-possibly-change-group (group)
 319   (when (and group
 320              (not (equal group nndraft-current-group)))
 321     (nndraft-open-server "")
 322     (setq nndraft-current-group group)
 323     (setq nndraft-current-directory
 324           (nnheader-concat nndraft-directory group))))
 325
 326 (defun nndraft-article-filename (article &rest args)
 327   (apply 'concat
 328          (file-name-as-directory nndraft-current-directory)
 329          (int-to-string article)
 330          args))
 331
 332 (defun nndraft-auto-save-file-name (file)
 333   (save-excursion
 334     (prog1
 335         (progn
 336           (set-buffer (get-buffer-create " *draft tmp*"))
 337           (setq buffer-file-name file)
 338           (make-auto-save-file-name))
 339       (kill-buffer (current-buffer)))))
 340
 341 (defun nndraft-articles ()
 342   "Return the list of messages in the group."
 343   (gnus-make-directory nndraft-current-directory)
 344   (sort
 345    (mapcar 'string-to-number
 346            (directory-files nndraft-current-directory nil "\\`[0-9]+\\'" t))
 347    '<))
 348
 349 (nnoo-import nndraft
 350   (nnmh
 351    nnmh-retrieve-headers
 352    nnmh-request-group
 353    nnmh-close-group
 354    nnmh-request-list))
 355
 356 (provide 'nndraft)
 357
 358 ;;; nndraft.el ends here