annotate lisp/nnmh.el @ 14609:a8eeafa7c4af

Update some doc string. Call `add-minor-mode'. (follow-windows-start-end-cache, follow-cache-command-list): New variables. (follow-cache-valid-p, follow-invalidate-cache): New functions. (follow-windows-start-end, follow-post-command-hook, follow-generic-filter): Cache support added. (follow-avoid-tail-recenter): Problem with minibuffer-only frames corrected. (follow-windows-aligned-p): Minor change.

�     1 ;;; nnmh.el --- mhspool access for Gnus
�     2 
�     3 ;; Copyright (C) 1995 Free Software Foundation, Inc.
�     4 
�     5 ;; Author: Lars Magne Ingebrigtsen <[e-mail]>
�     6 ;; 	Masanobu UMEDA <[e-mail]>
�     7 ;; Keywords: news, mail
�     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 the
�    23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
�    24 ;; Boston, MA 02111-1307, USA.
�    25 
�    26 ;;; Commentary:
�    27 
�    28 ;; Based on nnspool.el by Masanobu UMEDA <[e-mail]>.
�    29 ;; For an overview of what the interface functions do, please see the
�    30 ;; Gnus sources.  
�    31 
�    32 ;;; Code:
�    33 
�    34 (require 'nnheader)
�    35 (require 'rmail)
�    36 (require 'nnmail)
�    37 (require 'gnus)
�    38 
�    39 (defvar nnmh-directory "~/Mail/"
�    40   "*Mail spool directory.")
�    41 
�    42 (defvar nnmh-get-new-mail t
�    43   "*If non-nil, nnmh will check the incoming mail file and split the mail.")
�    44 
�    45 (defvar nnmh-prepare-save-mail-hook nil
�    46   "*Hook run narrowed to an article before saving.")
�    47 
�    48 (defvar nnmh-be-safe nil
�    49   "*If non-nil, nnmh will check all articles to make sure whether they are new or not.")
�    50 
�    51 
�    52 
�    53 (defconst nnmh-version "nnmh 1.0"
�    54   "nnmh version.")
�    55 
�    56 (defvar nnmh-current-directory nil
�    57   "Current news group directory.")
�    58 
�    59 (defvar nnmh-status-string "")
�    60 (defvar nnmh-group-alist nil)
�    61 
�    62 
�    63 
�    64 (defvar nnmh-current-server nil)
�    65 (defvar nnmh-server-alist nil)
�    66 (defvar nnmh-server-variables 
�    67   (list
�    68    (list 'nnmh-directory nnmh-directory)
�    69    (list 'nnmh-get-new-mail nnmh-get-new-mail)
�    70    '(nnmh-current-directory nil)
�    71    '(nnmh-status-string "")
�    72    '(nnmh-group-alist)))
�    73 
�    74 
�    75 
�    76 ;;; Interface functions.
�    77 
�    78 (defun nnmh-retrieve-headers (sequence &optional newsgroup server)
�    79   (save-excursion
�    80     (set-buffer nntp-server-buffer)
�    81     (erase-buffer)
�    82     (let* ((file nil)
�    83 	   (number (length sequence))
�    84 	   (large (and (numberp nnmail-large-newsgroup)
�    85 		       (> number nnmail-large-newsgroup)))
�    86 	   (count 0)
�    87 	   beg article)
�    88       (nnmh-possibly-change-directory newsgroup)
�    89       (if (stringp (car sequence))
�    90 	  'headers
�    91 	(while sequence
�    92 	  (setq article (car sequence))
�    93 	  (setq file
�    94 		(concat nnmh-current-directory (int-to-string article)))
�    95 	  (if (and (file-exists-p file)
�    96 		   (not (file-directory-p file)))
�    97 	      (progn
�    98 		(insert (format "221 %d Article retrieved.\n" article))
�    99 		(setq beg (point))
�   100 		(nnheader-insert-head file)
�   101 		(goto-char beg)
�   102 		(if (search-forward "\n\n" nil t)
�   103 		    (forward-char -1)
�   104 		  (goto-char (point-max))
�   105 		  (insert "\n\n"))
�   106 		(insert ".\n")
�   107 		(delete-region (point) (point-max))))
�   108 	  (setq sequence (cdr sequence))
�   109 	  (setq count (1+ count))
�   110 
�   111 	  (and large
�   112 	       (zerop (% count 20))
�   113 	       (message "nnmh: Receiving headers... %d%%"
�   114 			(/ (* count 100) number))))
�   115 
�   116 	(and large (message "nnmh: Receiving headers...done"))
�   117 
�   118 	;; Fold continuation lines.
�   119 	(goto-char (point-min))
�   120 	(while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t)
�   121 	  (replace-match " " t t))
�   122 	'headers))))
�   123 
�   124 (defun nnmh-open-server (server &optional defs)
�   125   (nnheader-init-server-buffer)
�   126   (if (equal server nnmh-current-server)
�   127       t
�   128     (if nnmh-current-server
�   129 	(setq nnmh-server-alist 
�   130 	      (cons (list nnmh-current-server
�   131 			  (nnheader-save-variables nnmh-server-variables))
�   132 		    nnmh-server-alist)))
�   133     (let ((state (assoc server nnmh-server-alist)))
�   134       (if state 
�   135 	  (progn
�   136 	    (nnheader-restore-variables (nth 1 state))
�   137 	    (setq nnmh-server-alist (delq state nnmh-server-alist)))
�   138 	(nnheader-set-init-variables nnmh-server-variables defs)))
�   139     (setq nnmh-current-server server)))
�   140 
�   141 (defun nnmh-close-server (&optional server)
�   142   t)
�   143 
�   144 (defun nnmh-server-opened (&optional server)
�   145   (and (equal server nnmh-current-server)
�   146        nntp-server-buffer
�   147        (buffer-name nntp-server-buffer)))
�   148 
�   149 (defun nnmh-status-message (&optional server)
�   150   nnmh-status-string)
�   151 
�   152 (defun nnmh-request-article (id &optional newsgroup server buffer)
�   153   (nnmh-possibly-change-directory newsgroup)
�   154   (let ((file (if (stringp id)
�   155 		  nil
�   156 		(concat nnmh-current-directory (int-to-string id))))
�   157 	(nntp-server-buffer (or buffer nntp-server-buffer)))
�   158     (and (stringp file)
�   159 	 (file-exists-p file)
�   160 	 (not (file-directory-p file))
�   161 	 (save-excursion (nnmail-find-file file)))))
�   162 
�   163 (defun nnmh-request-group (group &optional server dont-check)
�   164   (and nnmh-get-new-mail (or dont-check (nnmh-get-new-mail group)))
�   165   (let ((pathname (nnmh-article-pathname group nnmh-directory))
�   166 	dir)
�   167     (if (file-directory-p pathname)
�   168 	(progn
�   169 	  (setq nnmh-current-directory pathname)
�   170 	  (and nnmh-get-new-mail 
�   171 	       nnmh-be-safe
�   172 	       (nnmh-update-gnus-unreads group))
�   173 	  (or dont-check
�   174 	      (progn
�   175 		(setq dir 
�   176 		      (sort
�   177 		       (mapcar
�   178 			(function
�   179 			 (lambda (name)
�   180 			   (string-to-int name)))
�   181 			(directory-files pathname nil "^[0-9]+$" t))
�   182 		       '<))
�   183 		(save-excursion
�   184 		  (set-buffer nntp-server-buffer)
�   185 		  (erase-buffer)
�   186 		  (if dir
�   187 		      (insert (format "211 %d %d %d %s\n" (length dir) 
�   188 				      (car dir)
�   189 				      (progn (while (cdr dir)
�   190 					       (setq dir (cdr dir)))
�   191 					     (car dir))
�   192 				      group))
�   193 		    (insert (format "211 0 1 0 %s\n" group))))))
�   194 	  t)
�   195       (setq nnmh-status-string "No such group")
�   196       nil)))
�   197 
�   198 (defun nnmh-request-list (&optional server dir)
�   199   (or dir
�   200       (save-excursion
�   201 	(set-buffer nntp-server-buffer)
�   202 	(erase-buffer)
�   203 	(setq dir (file-truename (file-name-as-directory nnmh-directory)))))
�   204   (setq dir (expand-file-name dir))
�   205   ;; Recurse down all directories.
�   206   (let ((dirs (and (file-readable-p dir)
�   207 		   (> (nth 1 (file-attributes (file-chase-links dir))) 2)
�   208 		   (directory-files dir t nil t))))
�   209     (while dirs 
�   210       (if (and (not (string-match "/\\.\\.?$" (car dirs)))
�   211 	       (file-directory-p (car dirs))
�   212 	       (file-readable-p (car dirs)))
�   213 	  (nnmh-request-list nil (car dirs)))
�   214       (setq dirs (cdr dirs))))
�   215   ;; For each directory, generate an active file line.
�   216   (if (not (string= (expand-file-name nnmh-directory) dir))
�   217       (let ((files (mapcar
�   218 		    (lambda (name) (string-to-int name))
�   219 		    (directory-files dir nil "^[0-9]+$" t))))
�   220 	(if (null files)
�   221 	    ()
�   222 	  (save-excursion
�   223 	    (set-buffer nntp-server-buffer)
�   224 	    (goto-char (point-max))
�   225 	    (insert 
�   226 	     (format 
�   227 	      "%s %d %d y\n" 
�   228 	      (progn
�   229 		(string-match 
�   230 		 (file-truename (file-name-as-directory 
�   231 				 (expand-file-name nnmh-directory))) dir)
�   232 		(nnmail-replace-chars-in-string
�   233 		 (substring dir (match-end 0)) ?/ ?.))
�   234 	      (apply (function max) files) 
�   235 	      (apply (function min) files)))))))
�   236   (setq nnmh-group-alist (nnmail-get-active))
�   237   (and server nnmh-get-new-mail (nnmh-get-new-mail))
�   238   t)
�   239 
�   240 (defun nnmh-request-newgroups (date &optional server)
�   241   (nnmh-request-list server))
�   242 
�   243 (defun nnmh-request-post (&optional server)
�   244   (mail-send-and-exit nil))
�   245 
�   246 (defalias 'nnmh-request-post-buffer 'nnmail-request-post-buffer)
�   247 
�   248 (defun nnmh-request-expire-articles (articles newsgroup &optional server force)
�   249   (nnmh-possibly-change-directory newsgroup)
�   250   (let* ((days (or (and nnmail-expiry-wait-function
�   251 			(funcall nnmail-expiry-wait-function newsgroup))
�   252 		   nnmail-expiry-wait))
�   253 	 (active-articles 
�   254 	  (mapcar
�   255 	   (function
�   256 	    (lambda (name)
�   257 	      (string-to-int name)))
�   258 	   (directory-files nnmh-current-directory nil "^[0-9]+$" t)))
�   259 	 (max-article (and active-articles (apply 'max active-articles)))
�   260 	 (is-old t)
�   261 	 article rest mod-time)
�   262     (nnmail-activate 'nnmh)
�   263 
�   264     (while (and articles is-old)
�   265       (setq article (concat nnmh-current-directory 
�   266 			    (int-to-string (car articles))))
�   267       (if (setq mod-time (nth 5 (file-attributes article)))
�   268 	  (if (and (or (not nnmail-keep-last-article)
�   269 		       (not max-article)
�   270 		       (not (= (car articles) max-article)))
�   271 		   (not (equal mod-time '(0 0)))
�   272 		   (or force
�   273 		       (setq is-old
�   274 			     (> (nnmail-days-between
�   275 				 (current-time-string)
�   276 				 (current-time-string mod-time))
�   277 				days))))
�   278 	      (progn
�   279 		(and gnus-verbose-backends 
�   280 		     (message "Deleting article %s..." article))
�   281 		(condition-case ()
�   282 		    (delete-file article)
�   283 		  (file-error
�   284 		   (setq rest (cons (car articles) rest)))))
�   285 	    (setq rest (cons (car articles) rest))))
�   286       (setq articles (cdr articles)))
�   287     (message "")
�   288     (nconc rest articles)))
�   289 
�   290 (defun nnmh-close-group (group &optional server)
�   291   t)
�   292 
�   293 (defun nnmh-request-move-article 
�   294   (article group server accept-form &optional last)
�   295   (let ((buf (get-buffer-create " *nnmh move*"))
�   296 	result)
�   297     (and 
�   298      (nnmh-request-article article group server)
�   299      (save-excursion
�   300        (set-buffer buf)
�   301        (insert-buffer-substring nntp-server-buffer)
�   302        (setq result (eval accept-form))
�   303        (kill-buffer (current-buffer))
�   304        result)
�   305      (condition-case ()
�   306 	 (delete-file (concat nnmh-current-directory 
�   307 			      (int-to-string article)))
�   308        (file-error nil)))
�   309     result))
�   310 
�   311 (defun nnmh-request-accept-article (group &optional last)
�   312   (if (stringp group)
�   313       (and 
�   314        (nnmail-activate 'nnmh)
�   315        ;; We trick the choosing function into believing that only one
�   316        ;; group is available.  
�   317        (let ((nnmail-split-methods (list (list group ""))))
�   318 	 (car (nnmh-save-mail))))
�   319     (and
�   320      (nnmail-activate 'nnmh)
�   321      (car (nnmh-save-mail)))))
�   322 
�   323 (defun nnmh-request-replace-article (article group buffer)
�   324   (nnmh-possibly-change-directory group)
�   325   (save-excursion
�   326     (set-buffer buffer)
�   327     (nnmh-possibly-create-directory group)
�   328     (condition-case ()
�   329 	(progn
�   330 	  (write-region (point-min) (point-max)
�   331 			(concat nnmh-current-directory (int-to-string article))
�   332 			nil (if gnus-verbose-backends nil 'nomesg))
�   333 	  t)
�   334       (error nil))))
�   335 
�   336 
�   337 ;;; Internal functions.
�   338 
�   339 (defun nnmh-possibly-change-directory (newsgroup)
�   340   (if newsgroup
�   341       (let ((pathname (nnmh-article-pathname newsgroup nnmh-directory)))
�   342 	(if (file-directory-p pathname)
�   343 	    (setq nnmh-current-directory pathname)
�   344 	  (error "No such newsgroup: %s" newsgroup)))))
�   345 
�   346 (defun nnmh-possibly-create-directory (group)
�   347   (let (dir dirs)
�   348     (setq dir (nnmh-article-pathname group nnmh-directory))
�   349     (while (not (file-directory-p dir))
�   350       (setq dirs (cons dir dirs))
�   351       (setq dir (file-name-directory (directory-file-name dir))))
�   352     (while dirs
�   353       (if (make-directory (directory-file-name (car dirs)))
�   354 	  (error "Could not create directory %s" (car dirs)))
�   355       (and gnus-verbose-backends 
�   356 	   (message "Creating mail directory %s" (car dirs)))
�   357       (setq dirs (cdr dirs)))))
�   358 	     
�   359 (defun nnmh-save-mail ()
�   360   "Called narrowed to an article."
�   361   (let ((group-art (nreverse (nnmail-article-group 'nnmh-active-number))))
�   362     (nnmail-insert-lines)
�   363     (nnmail-insert-xref group-art)
�   364     (run-hooks 'nnmh-prepare-save-mail-hook)
�   365     (goto-char (point-min))
�   366     (while (looking-at "From ")
�   367       (replace-match "X-From-Line: ")
�   368       (forward-line 1))
�   369     ;; We save the article in all the newsgroups it belongs in.
�   370     (let ((ga group-art)
�   371 	  first)
�   372       (while ga
�   373 	(nnmh-possibly-create-directory (car (car ga)))
�   374 	(let ((file (concat (nnmh-article-pathname 
�   375 			     (car (car ga)) nnmh-directory) 
�   376 			    (int-to-string (cdr (car ga))))))
�   377 	  (if first
�   378 	      ;; It was already saved, so we just make a hard link.
�   379 	      (add-name-to-file first file t)
�   380 	    ;; Save the article.
�   381 	    (write-region (point-min) (point-max) file nil nil)
�   382 	    (setq first file)))
�   383 	(setq ga (cdr ga))))
�   384     group-art))
�   385 
�   386 (defun nnmh-active-number (group)
�   387   "Compute the next article number in GROUP."
�   388   (let ((active (car (cdr (assoc group nnmh-group-alist)))))
�   389     ;; The group wasn't known to nnmh, so we just create an active
�   390     ;; entry for it.   
�   391     (or active
�   392 	(progn
�   393 	  (setq active (cons 1 0))
�   394 	  (setq nnmh-group-alist (cons (list group active) nnmh-group-alist))))
�   395     (setcdr active (1+ (cdr active)))
�   396     (while (file-exists-p
�   397 	    (concat (nnmh-article-pathname group nnmh-directory)
�   398 		    (int-to-string (cdr active))))
�   399       (setcdr active (1+ (cdr active))))
�   400     (cdr active)))
�   401 
�   402 (defun nnmh-article-pathname (group mail-dir)
�   403   "Make pathname for GROUP."
�   404   (let ((mail-dir (file-name-as-directory (expand-file-name mail-dir))))
�   405     (if (file-directory-p (concat mail-dir group))
�   406 	(concat mail-dir group "/")
�   407       (concat mail-dir (nnmail-replace-chars-in-string group ?. ?/) "/"))))
�   408 
�   409 (defun nnmh-get-new-mail (&optional group)
�   410   "Read new incoming mail."
�   411   (let* ((spools (nnmail-get-spool-files group))
�   412 	 (group-in group)
�   413 	 incoming incomings)
�   414     (if (or (not nnmh-get-new-mail) (not nnmail-spool-file))
�   415 	()
�   416       ;; We first activate all the groups.
�   417       (or nnmh-group-alist
�   418 	  (nnmh-request-list))
�   419       ;; The we go through all the existing spool files and split the
�   420       ;; mail from each.
�   421       (while spools
�   422 	(and
�   423 	 (file-exists-p (car spools))
�   424 	 (> (nth 7 (file-attributes (car spools))) 0)
�   425 	 (progn
�   426 	   (and gnus-verbose-backends 
�   427 		(message "nnmh: Reading incoming mail..."))
�   428 	   (if (not (setq incoming 
�   429 			  (nnmail-move-inbox 
�   430 			   (car spools) 
�   431 			   (concat (file-name-as-directory nnmh-directory)
�   432 				   "Incoming"))))
�   433 	       ()
�   434 	     (setq incomings (cons incoming incomings))
�   435 	     (setq group (nnmail-get-split-group (car spools) group-in))
�   436 	     (nnmail-split-incoming incoming 'nnmh-save-mail nil group))))
�   437 	(setq spools (cdr spools)))
�   438       ;; If we did indeed read any incoming spools, we save all info. 
�   439       (if incoming 
�   440 	  (message "nnmh: Reading incoming mail...done"))
�   441       (while incomings
�   442 	(setq incoming (car incomings))
�   443 	(and nnmail-delete-incoming
�   444 	     (file-exists-p incoming)
�   445 	     (file-writable-p incoming)
�   446 	     (delete-file incoming))
�   447 	(setq incomings (cdr incomings))))))
�   448       
�   449 
�   450 (defun nnmh-update-gnus-unreads (group)
�   451   ;; Go through the .nnmh-articles file and compare with the actual
�   452   ;; articles in this folder. The articles that are "new" will be
�   453   ;; marked as unread by Gnus.
�   454   (let* ((dir nnmh-current-directory)
�   455 	 (files (sort (mapcar (function (lambda (name) (string-to-int name)))
�   456 			      (directory-files nnmh-current-directory 
�   457 					       nil "^[0-9]+$" t)) '<))
�   458 	 (nnmh-file (concat dir ".nnmh-articles"))
�   459 	 new articles)
�   460     ;; Load the .nnmh-articles file.
�   461     (if (file-exists-p nnmh-file)
�   462 	(setq articles 
�   463 	      (let (nnmh-newsgroup-articles)
�   464 		(condition-case nil (load nnmh-file nil t t) (error nil))
�   465 		nnmh-newsgroup-articles)))
�   466     ;; Add all new articles to the `new' list.
�   467     (let ((art files))
�   468       (while art
�   469 	(if (not (assq (car art) articles)) (setq new (cons (car art) new)))
�   470 	(setq art (cdr art))))
�   471     ;; Remove all deleted articles.
�   472     (let ((art articles))
�   473       (while art
�   474 	(if (not (memq (car (car art)) files))
�   475 	    (setq articles (delq (car art) articles)))
�   476 	(setq art (cdr art))))
�   477     ;; Check whether the highest-numbered articles really are the ones
�   478     ;; that Gnus thinks they are by looking at the time-stamps.
�   479     (let ((art articles))
�   480       (while (and art 
�   481 		  (not (equal 
�   482 			(nth 5 (file-attributes 
�   483 				(concat dir (int-to-string (car (car art))))))
�   484 			(cdr (car art)))))
�   485 	(setq articles (delq (car art) articles))
�   486 	(setq new (cons (car (car art)) new))
�   487 	(setq art (cdr art))))
�   488     ;; Go through all the new articles and add them, and their
�   489     ;; time-stamps to the list.
�   490     (let ((n new))
�   491       (while n
�   492 	(setq articles 
�   493 	      (cons (cons 
�   494 		     (car n)
�   495 		     (nth 5 (file-attributes 
�   496 			     (concat dir (int-to-string (car n))))))
�   497 		    articles))
�   498 	(setq n (cdr n))))
�   499     ;; Make Gnus mark all new articles as unread.
�   500     (or (zerop (length new))
�   501 	(gnus-make-articles-unread 
�   502 	 (gnus-group-prefixed-name group (list 'nnmh ""))
�   503 	 (setq new (sort new '<))))
�   504     ;; Sort the article list with highest numbers first.
�   505     (setq articles (sort articles (lambda (art1 art2) 
�   506 				    (> (car art1) (car art2)))))
�   507     ;; Finally write this list back to the .nnmh-articles file.
�   508     (save-excursion
�   509       (set-buffer (get-buffer-create "*nnmh out*"))
�   510       (insert ";; Gnus article active file for " group "\n\n")
�   511       (insert "(setq nnmh-newsgroup-articles '")
�   512       (insert (prin1-to-string articles) ")\n")
�   513       (write-region (point-min) (point-max) nnmh-file nil 'nomesg)
�   514       (kill-buffer (current-buffer)))))
�   515 
�   516 (provide 'nnmh)
�   517 
�   518 ;;; nnmh.el ends here