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

   1 ;;; nnmail.el --- mail mbox access for Gnus
   2
   3 ;; Copyright (C) 1994 Free Software Foundation, Inc.
   4
   5 ;; Author: Lars Ingebrigtsen <larsi@ifi.uio.no>
   6 ;;      Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
   7 ;; Keywords: news
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to
  23 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  24
  25 ;;; Commentary:
  26
  27 ;;; Code:
  28
  29 (require 'nnheader)
  30 (require 'rmail)
  31
  32 (defvar nnmail-split-methods
  33   '(("mail.misc" ""))
  34   "nnmail will split incoming mail into the groups detailed in this variable.")
  35
  36 (defvar nnmail-mbox-file (expand-file-name "~/mbox")
  37   "The name of the mail box file in the users home directory.")
  38
  39 (defvar nnmail-active-file (expand-file-name "~/.mbox-active")
  40   "The name of the active file for the mail box.")
  41
  42 (defvar nnmail-expiry-wait 7
  43   "Articles that are older than `nnmail-expiry-wait' days will be expired.")
  44
  45 ;; Quote fix by Sudish Joseph <joseph@cis.ohio-state.edu>.
  46 (defvar nnmail-expiry-wait-function nil
  47   "Variable that holds funtion to specify how old articles should be before they are expired.
  48   The function will be called with the name of the group that the
  49 expiry is to be performed in, and it should return an integer that
  50 says how many days an article can be stored before it is considered
  51 'old'.
  52
  53 Eg.:
  54
  55 (setq nnmail-expiry-wait-function
  56   (function
  57     (lambda (newsgroup)
  58       (cond ((string-match \"private\" newsgroup) 31)
  59             ((string-match \"junk\" newsgroup) 1)
  60             (t 7)))))")
  61
  62 (defvar nnmail-spool-file
  63   (or (getenv "MAIL")
  64       (concat "/usr/spool/mail/" (user-login-name))))
  65
  66 (defvar nnmail-read-incoming-hook nil
  67   "Hook that will be run after the incoming mail has been transferred.
  68 The incoming mail is moved from `nnmail-spool-file' (which normally is
  69 something like \"/usr/spool/mail/$user\") to the user's home
  70 directory. This hook is called after the incoming mail box has been
  71 emptied, and can be used to call any mail box programs you have
  72 running (\"xwatch\", etc.)
  73
  74 Eg.
  75
  76 (add-hook 'nnmail-read-incoming-hook
  77           (function
  78            (lambda ()
  79              (start-process \"mailsend\" nil
  80                             \"/local/bin/mailsend\" \"read\" \"mbox\"))))")
  81
  82 (defvar nnmail-large-newsgroup 50
  83   "*The number of the articles which indicates a large newsgroup.
  84 If the number of the articles is greater than the value, verbose
  85 messages will be shown to indicate the current status.")
  86
  87 \f
  88
  89 (defconst nnmail-version "nnmail 0.1"
  90   "nnmail version.")
  91
  92 (defvar nnmail-current-group nil
  93   "Current nnmail news group directory.")
  94
  95 (defconst nnmail-mbox-buffer "*nnmail mbox buffer*")
  96
  97 (defvar nnmail-active-alist nil)
  98
  99 (defvar nnmail-status-string "")
 100
 101 ;;; Interface functions
 102
 103 (defun nnmail-retrieve-headers (sequence &optional newsgroup server)
 104   "Retrieve the headers for the articles in SEQUENCE.
 105 Newsgroup must be selected before calling this function."
 106   (save-excursion
 107     (set-buffer nntp-server-buffer)
 108     (erase-buffer)
 109     (let ((file nil)
 110           (number (length sequence))
 111           (count 0)
 112           beg article art-string start stop)
 113       (nnmail-possibly-change-newsgroup newsgroup)
 114       (while sequence
 115         (setq article (car sequence))
 116         (setq art-string (nnmail-article-string article))
 117         (set-buffer nnmail-mbox-buffer)
 118         (if (or (search-forward art-string nil t)
 119                 (progn (goto-char 1)
 120                        (search-forward art-string nil t)))
 121             (progn
 122               (setq start
 123                     (save-excursion
 124                       (re-search-backward
 125                        (concat "^" rmail-unix-mail-delimiter) nil t)
 126                       (point)))
 127               (search-forward "\n\n" nil t)
 128               (setq stop (1- (point)))
 129               (set-buffer nntp-server-buffer)
 130               (insert (format "221 %d Article retrieved.\n" article))
 131               (setq beg (point))
 132               (insert-buffer-substring nnmail-mbox-buffer start stop)
 133               (goto-char (point-max))
 134               (insert ".\n")))
 135         (setq sequence (cdr sequence))
 136         (setq count (1+ count))
 137         (and (numberp nnmail-large-newsgroup)
 138              (> number nnmail-large-newsgroup)
 139              (zerop (% count 20))
 140              (message "NNMAIL: Receiving headers... %d%%"
 141                       (/ (* count 100) number))))
 142
 143       (and (numberp nnmail-large-newsgroup)
 144            (> number nnmail-large-newsgroup)
 145            (message "NNMAIL: Receiving headers... done"))
 146
 147       ;; Fold continuation lines.
 148       (goto-char 1)
 149       (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t)
 150         (replace-match " " t t))
 151       'headers)))
 152
 153 (defun nnmail-open-server (host &optional service)
 154   "Open mbox backend."
 155   (setq nnmail-status-string "")
 156   (nnmail-open-server-internal host service))
 157
 158 (defun nnmail-close-server (&optional server)
 159   "Close news server."
 160   (nnmail-close-server-internal))
 161
 162 (fset 'nnmail-request-quit (symbol-function 'nnmail-close-server))
 163
 164 (defun nnmail-server-opened (&optional server)
 165   "Return server process status, T or NIL.
 166 If the stream is opened, return T, otherwise return NIL."
 167   (and nntp-server-buffer
 168        (get-buffer nntp-server-buffer)))
 169
 170 (defun nnmail-status-message ()
 171   "Return server status response as string."
 172   nnmail-status-string)
 173
 174 (defun nnmail-request-article (article &optional newsgroup server buffer)
 175   "Select ARTICLE by number."
 176   (nnmail-possibly-change-newsgroup newsgroup)
 177   (if (stringp article)
 178       nil
 179     (save-excursion
 180       (set-buffer nnmail-mbox-buffer)
 181       (goto-char 1)
 182       (if (search-forward (nnmail-article-string article) nil t)
 183           (let (start stop)
 184             (re-search-backward (concat "^" rmail-unix-mail-delimiter) nil t)
 185             (setq start (point))
 186             (forward-line 1)
 187             (or (and (re-search-forward
 188                       (concat "^" rmail-unix-mail-delimiter) nil t)
 189                      (forward-line -1))
 190                 (goto-char (point-max)))
 191             (setq stop (point))
 192             (let ((nntp-server-buffer (or buffer nntp-server-buffer)))
 193               (set-buffer nntp-server-buffer)
 194               (erase-buffer)
 195               (insert-buffer-substring nnmail-mbox-buffer start stop)
 196               t))))))
 197
 198 (defun nnmail-request-group (group &optional server dont-check)
 199   "Select news GROUP."
 200   (if (nnmail-possibly-change-newsgroup group)
 201       (if dont-check
 202           t
 203         (nnmail-get-new-mail)
 204         (save-excursion
 205           (set-buffer nntp-server-buffer)
 206           (erase-buffer)
 207           (let ((active (assoc group nnmail-active-alist)))
 208             (insert (format "211 %d %d %d %s\n"
 209                             (1+ (- (cdr (car (cdr active)))
 210                                    (car (car (cdr active)))))
 211                             (car (car (cdr active)))
 212                             (cdr (car (cdr active)))
 213                             (car active))))
 214           t))))
 215
 216 (defun nnmail-request-list (&optional server)
 217   "List active newsgoups."
 218   (nnmail-find-file nnmail-active-file))
 219
 220 (defun nnmail-request-list-newsgroups (&optional server)
 221   "List newsgroups (defined in NNTP2)."
 222   (setq nntp-status-string "NNMAIL: LIST NEWSGROUPS is not implemented.")
 223   nil)
 224
 225 (defun nnmail-request-post (&optional server)
 226   "Post a new news in current buffer."
 227   (mail-send-and-exit nil))
 228
 229 (defun nnmail-request-post-buffer (method header article-buffer group info)
 230   (let ((method-address (nth 1 (nth 4 info)))
 231         from subject date to reply-to message-of
 232         references message-id sender follow-to)
 233     (setq method-address
 234           (if (and (stringp method-address)
 235                    (string= method-address ""))
 236               nil method-address))
 237     (save-excursion
 238       (set-buffer (get-buffer-create "*mail*"))
 239       (mail-mode)
 240       (local-set-key "\C-c\C-c" 'gnus-mail-send-and-exit)
 241       (local-set-key "\C-c\C-y" 'gnus-mail-yank-original)
 242       (if (and (buffer-modified-p)
 243                (> (buffer-size) 0)
 244                (not (y-or-n-p "Unsent mail being composed; erase it? ")))
 245           ()
 246         (erase-buffer)
 247         (if (eq method 'post)
 248             (mail-setup method-address nil nil nil nil nil)
 249           (save-excursion
 250             (set-buffer article-buffer)
 251             (goto-char (point-min))
 252             (narrow-to-region (point-min)
 253                               (progn (search-forward "\n\n") (point)))
 254             (set-text-properties (point-min) (point-max) nil)
 255             (if (and (boundp 'gnus-followup-to-function)
 256                      gnus-followup-to-function)
 257                 (setq follow-to (funcall gnus-followup-to-function group)))
 258             (setq from (header-from header))
 259             (setq date (header-date header))
 260             (and from
 261                  (let ((stop-pos
 262                         (string-match "  *at \\|  *@ \\| *(\\| *<" from)))
 263                    (setq message-of
 264                          (concat (if stop-pos (substring from 0 stop-pos) from)
 265                                  "'s message of " date))))
 266             (setq sender (mail-fetch-field "sender"))
 267             (setq subject (header-subject header))
 268             (or (string-match "^[Rr][Ee]:" subject)
 269                 (setq subject (concat "Re: " subject)))
 270             (setq reply-to (mail-fetch-field "reply-to"))
 271             (setq references (header-references header))
 272             (setq message-id (header-id header))
 273             (widen))
 274           (setq news-reply-yank-from from)
 275           (setq news-reply-yank-message-id message-id)
 276           (mail-setup (or follow-to method-address sender reply-to from)
 277                       subject message-of nil article-buffer nil)
 278           ;; Fold long references line to follow RFC1036.
 279           (mail-position-on-field "References")
 280           (let ((begin (- (point) (length "References: ")))
 281                 (fill-column 78)
 282                 (fill-prefix "\t"))
 283             (if references (insert references))
 284             (if (and references message-id) (insert " "))
 285             (if message-id (insert message-id))
 286             ;; The region must end with a newline to fill the region
 287             ;; without inserting extra newline.
 288             (fill-region-as-paragraph begin (1+ (point))))
 289           ))
 290       (current-buffer))))
 291
 292 (defun nnmail-request-expire-articles (articles newsgroup &optional server)
 293   "Expire all articles in the ARTICLES list in group GROUP.
 294 The list of unexpired articles will be returned (ie. all articles that
 295 were too fresh to be expired)."
 296   (nnmail-possibly-change-newsgroup newsgroup)
 297   (let* ((days (or (and nnmail-expiry-wait-function
 298                         (funcall nnmail-expiry-wait-function newsgroup))
 299                    nnmail-expiry-wait))
 300          (cur-time (current-time))
 301          (day-sec (* 24 60 60 days))
 302          (day-time (list nil nil))
 303          mod-time article rest)
 304     (setcar day-time (/ day-sec 65536))
 305     (setcar (cdr day-time) (- day-sec (* (car day-time) 65536)))
 306     (if (< (car (cdr cur-time)) (car (cdr day-time)))
 307         (progn
 308           (setcar day-time (+ 1 (- (car cur-time) (car day-time))))
 309           (setcar (cdr day-time) (- (+ 65536 (car (cdr cur-time)))
 310                                     (car (cdr day-time)))))
 311       (setcar day-time (- (car cur-time) (car day-time)))
 312       (setcar (cdr day-time) (- (car (cdr cur-time)) (car (cdr day-time)))))
 313     (save-excursion
 314       (set-buffer nnmail-mbox-buffer)
 315       (while articles
 316         (goto-char 1)
 317         (if (and (search-forward (nnmail-article-string (car articles)) nil t)
 318                  (setq mod-time (read (current-buffer)))
 319                  (or (< (car mod-time) (car day-time))
 320                      (and (= (car mod-time) (car day-time))
 321                           (< (car (cdr mod-time)) (car (cdr day-time))))))
 322             (progn
 323               (message "Deleting: %s" article)
 324               (nnmail-delete-mail))
 325           (setq rest (cons (car articles) rest)))
 326         (setq articles (cdr articles)))
 327       (save-buffer)
 328       rest)))
 329
 330 (defun nnmail-request-move-article (article group server accept-form)
 331   (let ((buf (get-buffer-create " *nnmail move*"))
 332         result)
 333     (and
 334      (nnmail-request-article article group server)
 335      (save-excursion
 336        (set-buffer buf)
 337        (insert-buffer-substring nntp-server-buffer)
 338        (goto-char (point-min))
 339        (if (re-search-forward
 340             "^X-Gnus-Newsgroup:"
 341             (save-excursion (search-forward "\n\n" nil t) (point)) t)
 342            (delete-region (progn (beginning-of-line) (point))
 343                           (progn (forward-line 1) (point))))
 344        (setq result (eval accept-form))
 345        (kill-buffer (current-buffer))
 346        result)
 347      (save-excursion
 348        (set-buffer nnmail-mbox-buffer)
 349        (goto-char 1)
 350        (if (search-forward (nnmail-article-string article) nil t)
 351            (nnmail-delete-mail))
 352        (save-buffer)))
 353     result))
 354
 355 (defun nnmail-request-accept-article (group)
 356   (let ((buf (current-buffer))
 357         result beg)
 358     (and
 359      (nnmail-get-active)
 360      (save-excursion
 361        (set-buffer nnmail-mbox-buffer)
 362        (setq beg (goto-char (point-max)))
 363        (insert-buffer-substring buf)
 364        (goto-char beg)
 365        (if (stringp group)
 366            (progn
 367              (search-forward "\n\n" nil t)
 368              (forward-line -1)
 369              (setq result (nnmail-insert-newsgroup-line group beg (point))))
 370          (setq result (nnmail-choose-mail beg (point-max))))
 371        (save-buffer)
 372        result)
 373      (nnmail-save-active))
 374     (debug)
 375     result))
 376
 377 \f
 378 ;;; Low-Level Interface
 379
 380 (defun nnmail-delete-mail ()
 381   (re-search-backward (concat "^" rmail-unix-mail-delimiter) nil t)
 382   (delete-region
 383    (point)
 384    (progn
 385      (forward-line 1)
 386      (or (and (re-search-forward
 387                (concat "^" rmail-unix-mail-delimiter) nil t)
 388               (forward-line -1)
 389               (point))
 390          (point-max)))))
 391
 392 (defun nnmail-open-server-internal (host &optional service)
 393   "Open connection to news server on HOST by SERVICE (default is nntp)."
 394   (save-excursion
 395     (if (not (string-equal host (system-name)))
 396         (error "NNMAIL: cannot talk to %s." host))
 397     ;; Initialize communication buffer.
 398     (setq nntp-server-buffer (get-buffer-create " *nntpd*"))
 399     (set-buffer nntp-server-buffer)
 400     (buffer-disable-undo (current-buffer))
 401     (erase-buffer)
 402     (kill-all-local-variables)
 403     (setq case-fold-search t)           ;Should ignore case.
 404     t))
 405
 406 (defun nnmail-close-server-internal ()
 407   "Close connection to news server."
 408   nil)
 409
 410 (defun nnmail-find-file (file)
 411   "Insert FILE in server buffer safely."
 412   (save-excursion
 413     (set-buffer nntp-server-buffer)
 414     (erase-buffer)
 415     (condition-case ()
 416         (progn (insert-file-contents file) t)
 417       (file-error nil))))
 418
 419 (defun nnmail-possibly-change-newsgroup (newsgroup)
 420   (if (not (get-buffer nnmail-mbox-buffer))
 421       (save-excursion
 422         (set-buffer (setq nnmail-mbox-buffer
 423                           (find-file-noselect nnmail-mbox-file)))
 424         (buffer-disable-undo (current-buffer))))
 425   (if (not nnmail-active-alist)
 426       (nnmail-get-active))
 427   (if newsgroup
 428       (if (assoc newsgroup nnmail-active-alist)
 429           (setq nnmail-current-group newsgroup))))
 430
 431 ;; Most of this function was taken from rmail.el
 432 (defun nnmail-move-inbox ()
 433   (let ((inbox (expand-file-name nnmail-spool-file))
 434         tofile errors)
 435     (setq tofile (make-temp-name
 436                   (expand-file-name (concat nnmail-mbox-file "-Incoming"))))
 437     (unwind-protect
 438         (save-excursion
 439           (setq errors (generate-new-buffer " *nnmail loss*"))
 440           (buffer-disable-undo errors)
 441           (call-process
 442            (expand-file-name "movemail" exec-directory)
 443            nil errors nil inbox tofile)
 444           (if (not (buffer-modified-p errors))
 445               ;; No output => movemail won
 446               nil
 447             (set-buffer errors)
 448             (subst-char-in-region (point-min) (point-max) ?\n ?\  )
 449             (goto-char (point-max))
 450             (skip-chars-backward " \t")
 451             (delete-region (point) (point-max))
 452             (goto-char (point-min))
 453             (if (looking-at "movemail: ")
 454                 (delete-region (point-min) (match-end 0)))
 455             (error (concat "movemail: "
 456                            (buffer-substring (point-min)
 457                                              (point-max)))))))
 458     tofile))
 459
 460 (defun nnmail-article-string (article)
 461   (concat "\nX-Gnus-Newsgroup: " nnmail-current-group ":"
 462           (int-to-string article) " ("))
 463
 464 (defun nnmail-choose-mail (beg end)
 465   (let (result)
 466     (save-excursion
 467       (goto-char end)
 468       (let ((methods nnmail-split-methods)
 469             found)
 470         (while (and (not found) methods)
 471           (if (re-search-backward (car (cdr (car methods))) beg t)
 472               (progn
 473                 (setq result (nnmail-insert-newsgroup-line
 474                               (car (car methods)) beg end))
 475                 (setq found t))
 476             (setq methods (cdr methods))))
 477         (if (not found)
 478             (setq result (nnmail-insert-newsgroup-line
 479                           (car (car nnmail-split-methods)) beg end)))))
 480     result))
 481
 482 (defun nnmail-insert-newsgroup-line (group beg end)
 483   (let ((active (car (cdr (assoc group nnmail-active-alist))))
 484         (time (current-time)))
 485     (if (not active)
 486         (progn
 487           (setq nnmail-active-alist
 488                 (cons (list group (cons 1 0)) nnmail-active-alist))
 489           (setq active (car (cdr (car nnmail-active-alist))))))
 490     (setcdr active (1+ (cdr active)))
 491     (insert (format "X-Gnus-Newsgroup: %s:%d (%d %d)\n" group (cdr active)
 492                     (car time) (car (cdr time))))
 493     (cons group (cdr active))))
 494
 495 (defun nnmail-split-region (beg end)
 496   (goto-char beg)
 497   (let ((delim (concat "^" rmail-unix-mail-delimiter))
 498         start stop)
 499     (while (re-search-forward delim nil t)
 500       (setq start (point))
 501       (search-forward "\n\n" nil t)
 502       (save-excursion
 503         (forward-char -1)
 504         (if (not (save-excursion (re-search-backward "^Lines:" start t)))
 505             (insert
 506              (format "Lines: %d\n"
 507                      (count-lines
 508                       (point)
 509                       (or (re-search-forward rmail-unix-mail-delimiter nil t)
 510                           (point-max)))))))
 511       (setq stop (1- (point)))
 512       (if (not (search-backward "X-Gnus-Newsgroup: " start t))
 513           (nnmail-choose-mail start stop)))))
 514
 515 (defun nnmail-read-mbox ()
 516   (if (and nnmail-mbox-buffer
 517            (get-buffer nnmail-mbox-buffer)
 518            (buffer-name nnmail-mbox-buffer)
 519            (save-excursion
 520              (set-buffer nnmail-mbox-buffer)
 521              (= (buffer-size) (nth 7 (file-attributes nnmail-mbox-file)))))
 522       ()
 523     (save-excursion
 524       (set-buffer (setq nnmail-mbox-buffer
 525                         (find-file-noselect nnmail-mbox-file)))
 526       (buffer-disable-undo (current-buffer))
 527       (nnmail-split-region (point-min) (point-max)))))
 528
 529 (defun nnmail-split-incoming (incoming)
 530   (save-excursion
 531     (set-buffer nnmail-mbox-buffer)
 532     (goto-char (point-max))
 533     (let ((start (point)))
 534       (insert-file-contents incoming)
 535       (nnmail-split-region start (point-max)))))
 536
 537 (defun nnmail-get-active ()
 538   (let ((methods nnmail-split-methods))
 539     (setq nnmail-active-alist nil)
 540     (if (nnmail-request-list)
 541         (save-excursion
 542           (set-buffer (get-buffer-create " *nntpd*"))
 543           (goto-char 1)
 544           (while (re-search-forward
 545                   "^\\([^ \t]+\\)[ \t]+\\([0-9]+\\)[ \t]+\\([0-9]+\\)" nil t)
 546             (setq nnmail-active-alist
 547                   (cons (list (buffer-substring (match-beginning 1)
 548                                                 (match-end 1))
 549                               (cons (string-to-int
 550                                      (buffer-substring (match-beginning 3)
 551                                                        (match-end 3)))
 552                                     (string-to-int
 553                                      (buffer-substring (match-beginning 2)
 554                                                        (match-end 2)))))
 555                         nnmail-active-alist)))))
 556     (while methods
 557       (if (not (assoc (car (car methods)) nnmail-active-alist))
 558           (setq nnmail-active-alist
 559                 (cons (list (car (car methods)) (cons 1 0))
 560                       nnmail-active-alist)))
 561       (setq methods (cdr methods)))
 562     t))
 563
 564 (defun nnmail-save-active ()
 565   (let ((groups nnmail-active-alist)
 566         group)
 567     (save-excursion
 568       (set-buffer (get-buffer-create " *nnmail*"))
 569       (buffer-disable-undo (current-buffer))
 570       (erase-buffer)
 571       (while groups
 572         (setq group (car groups))
 573         (insert (format "%s %d %d y\n" (car group) (cdr (car (cdr group)) )
 574                         (car (car (cdr group)))))
 575         (setq groups (cdr groups)))
 576       (write-region 1 (point-max) (expand-file-name nnmail-active-file) nil
 577                     'nomesg)
 578       (kill-buffer (current-buffer)))))
 579
 580 (defun nnmail-get-new-mail ()
 581   (let (incoming)
 582     (nnmail-get-active)
 583     (nnmail-read-mbox)
 584     (if (and (file-exists-p nnmail-spool-file)
 585              (> (nth 7 (file-attributes nnmail-spool-file)) 0))
 586         (progn
 587           (setq incoming (nnmail-move-inbox))
 588           (nnmail-split-incoming incoming)
 589           (run-hooks 'nnmail-read-incoming-hook)))
 590     (and (buffer-modified-p nnmail-mbox-buffer)
 591          (save-excursion
 592            (nnmail-save-active)
 593            (set-buffer nnmail-mbox-buffer)
 594            (save-buffer)))
 595 ;    (if incoming
 596 ;       (delete-file incoming))
 597     ))
 598
 599 (provide 'nnmail)
 600
 601 ;;; nnmail.el ends here