comparison lisp/gnus/nnmh.el @ 24357:15fc6acbae7a

Upgrading to Gnus 5.7; see ChangeLog

24356:a5a611ef40f6

;;; nnmh.el --- mhspool access for Gnus
;; Copyright (C) 1995,96,97 Free Software Foundation, Inc.

;; Author: Lars Magne Ingebrigtsen <[e-mail]>
;; 	Masanobu UMEDA <[e-mail]>
;; Keywords: news, mail

;; This file is part of GNU Emacs.

(defvoo nnmh-current-directory nil
  "Current news group directory.")

(defvoo nnmh-status-string "")
(defvoo nnmh-group-alist nil)



;;; Interface functions.

    (let* ((file nil)
	   (number (length articles))
	   (large (and (numberp nnmail-large-newsgroup)
		       (> number nnmail-large-newsgroup)))
	   (count 0)
	   ;; 1997/8/12 by MORIOKA Tomohiko
	   (file-name-coding-system 'binary) ; for Emacs 20
	   (pathname-coding-system 'binary)  ; for XEmacs/mule
	   beg article)
      (nnmh-possibly-change-directory newsgroup server)
      ;; We don't support fetching by Message-ID.
      (if (stringp (car articles))
	  'headers

	    (delete-region (point) (point-max)))
	  (setq count (1+ count))

	  (and large
	       (zerop (% count 20))
	       (message "nnmh: Receiving headers... %d%%"
			(/ (* count 100) number))))

	(when large
	  (message "nnmh: Receiving headers...done"))

	(nnheader-fold-continuation-lines)
	'headers))))

(deffoo nnmh-open-server (server &optional defs)

(deffoo nnmh-request-article (id &optional newsgroup server buffer)
  (nnmh-possibly-change-directory newsgroup server)
  (let ((file (if (stringp id)
		  nil
		(concat nnmh-current-directory (int-to-string id))))
	;; 1997/8/12 by MORIOKA Tomohiko
	(file-name-coding-system 'binary) ; for Emacs 20
	(pathname-coding-system 'binary)  ; for XEmacs/mule
	(nntp-server-buffer (or buffer nntp-server-buffer)))
    (and (stringp file)
	 (file-exists-p file)
	 (not (file-directory-p file))
	 (save-excursion (nnmail-find-file file))
	 (string-to-int (file-name-nondirectory file)))))

(deffoo nnmh-request-group (group &optional server dont-check)
  (let ((pathname (nnmail-group-pathname group nnmh-directory))
	;; 1997/8/12 by MORIOKA Tomohiko
	(file-name-coding-system 'binary) ; for Emacs 20
	(pathname-coding-system 'binary)  ; for XEmacs/mule.
	dir)
    (cond
     ((not (file-directory-p pathname))
      (nnheader-report
       'nnmh "Can't select group (no such directory): %s" group))

(deffoo nnmh-request-scan (&optional group server)
  (nnmail-get-new-mail 'nnmh nil nnmh-directory group))

(deffoo nnmh-request-list (&optional server dir)
  (nnheader-insert "")
  (let ((file-name-coding-system 'binary)
	(pathname-coding-system 'binary)
	(nnmh-toplev
	 (file-truename (or dir (file-name-as-directory nnmh-directory)))))
    (nnmh-request-list-1 nnmh-toplev))
  (setq nnmh-group-alist (nnmail-get-active))
  t)

(defvar nnmh-toplev)
(defun nnmh-request-list-1 (dir)
  (setq dir (expand-file-name dir))
  ;; Recurse down all directories.
  (let ((dirs (and (file-readable-p dir)
		   (> (nth 1 (file-attributes (file-chase-links dir))) 2)
		   (directory-files dir t nil t)))
	dir)
    ;; Recurse down directories.
    (while (setq dir (pop dirs))
      (when (and (not (member (file-name-nondirectory dir) '("." "..")))
		 (file-directory-p dir)
		 (file-readable-p dir))
	(nnmh-request-list-1 dir))))
  ;; For each directory, generate an active file line.
  (unless (string= (expand-file-name nnmh-toplev) dir)
    (let ((files (mapcar
		  (lambda (name) (string-to-int name))
		  (directory-files dir nil "^[0-9]+$" t))))

	       (regexp-quote
		(file-truename (file-name-as-directory
				(expand-file-name nnmh-toplev))))
	       dir)
	      (nnheader-replace-chars-in-string
	       (decode-coding-string (substring dir (match-end 0))
				     nnmail-pathname-coding-system)
	       ?/ ?.))
	    (apply 'max files)
	    (apply 'min files)))))))
  t)

  (nnmh-request-list server))

(deffoo nnmh-request-expire-articles (articles newsgroup
					       &optional server force)
  (nnmh-possibly-change-directory newsgroup server)
  (let* ((active-articles
	  (mapcar
	   (function
	    (lambda (name)
	      (string-to-int name)))
	   (directory-files nnmh-current-directory nil "^[0-9]+$" t)))
	 (is-old t)
	 article rest mod-time)
    (nnmail-activate 'nnmh)

    (while (and articles is-old)
      (setq article (concat nnmh-current-directory
			    (int-to-string (car articles))))
      (when (setq mod-time (nth 5 (file-attributes article)))

		 (nnheader-message 1 "Couldn't delete article %s in %s"
				   article newsgroup)
		 (push (car articles) rest))))
	  (push (car articles) rest)))
      (setq articles (cdr articles)))
    (message "")
    (nconc rest articles)))

(deffoo nnmh-close-group (group &optional server)
  t)

(deffoo nnmh-request-accept-article (group &optional server last noinsert)
  (nnmh-possibly-change-directory group server)
  (nnmail-check-syntax)
  (when nnmail-cache-accepted-message-ids
    (nnmail-cache-insert (nnmail-fetch-field "message-id")))
  (prog1
      (if (stringp group)
	  (and
	   (nnmail-activate 'nnmh)
	   (car (nnmh-save-mail
		 (list (cons group (nnmh-active-number group)))
		 noinsert)))
	(and
	 (nnmail-activate 'nnmh)
	 (let ((res (nnmail-article-group 'nnmh-active-number)))
	   (if (and (null res)
		    (yes-or-no-p "Moved to `junk' group; delete article? "))
	       'junk
	     (car (nnmh-save-mail res noinsert))))))
    (when (and last nnmail-cache-accepted-message-ids)
      (nnmail-cache-close))))

(deffoo nnmh-request-replace-article (article group buffer)
  (nnmh-possibly-change-directory group)

       (concat nnmh-current-directory (int-to-string article))
       nil (if (nnheader-be-verbose 5) nil 'nomesg))
      t)))

(deffoo nnmh-request-create-group (group &optional server args)
  (nnmail-activate 'nnmh)
  (unless (assoc group nnmh-group-alist)
    (let (active)
      (push (list group (setq active (cons 1 0)))
	    nnmh-group-alist)
      (nnmh-possibly-create-directory group)

  (when (and server
	     (not (nnmh-server-opened server)))
    (nnmh-open-server server))
  (when newsgroup
    (let ((pathname (nnmail-group-pathname newsgroup nnmh-directory))
	  ;; 1997/8/12 by MORIOKA Tomohiko
	  (file-name-coding-system 'binary) ; for Emacs 20
	  (pathname-coding-system 'binary)) ; for XEmacs/mule
      (if (file-directory-p pathname)
	  (setq nnmh-current-directory pathname)
	(error "No such newsgroup: %s" newsgroup)))))

(defun nnmh-possibly-create-directory (group)

(defun nnmh-active-number (group)
  "Compute the next article number in GROUP."
  (let ((active (cadr (assoc group nnmh-group-alist)))
	(dir (nnmail-group-pathname group nnmh-directory))
	;; 1997/8/14 by MORIOKA Tomohiko
	(file-name-coding-system 'binary) ; for Emacs 20
	(pathname-coding-system 'binary)) ; for XEmacs/mule
    (unless active
      ;; The group wasn't known to nnmh, so we just create an active
      ;; entry for it.
      (setq active (cons 1 0))
      (push (list group active) nnmh-group-alist)
      (unless (file-exists-p dir)
	(make-directory dir))
      ;; Find the highest number in the group.
      (let ((files (sort
		    (mapcar
		     (lambda (f)
		       (string-to-int f))

(defun nnmh-deletable-article-p (group article)
  "Say whether ARTICLE in GROUP can be deleted."
  (let ((path (concat nnmh-current-directory (int-to-string article))))
    ;; Writable.
    (and (file-writable-p path)
	 ;; We can never delete the last article in the group.
	 (not (eq (cdr (nth 1 (assoc group nnmh-group-alist)))
		  article)))))

(provide 'nnmh)

;;; nnmh.el ends here

24357:15fc6acbae7a

;;; nnmh.el --- mhspool access for Gnus
;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc.

;; Author: Lars Magne Ingebrigtsen <[e-mail]>
;; 	Masanobu UMEDA <[e-mail]>
;; Keywords: news, mail

;; This file is part of GNU Emacs.

(defvoo nnmh-current-directory nil
  "Current news group directory.")

(defvoo nnmh-status-string "")
(defvoo nnmh-group-alist nil)
(defvoo nnmh-allow-delete-final nil)



;;; Interface functions.

    (let* ((file nil)
	   (number (length articles))
	   (large (and (numberp nnmail-large-newsgroup)
		       (> number nnmail-large-newsgroup)))
	   (count 0)
	   (file-name-coding-system 'binary)
	   (pathname-coding-system 'binary)
	   beg article)
      (nnmh-possibly-change-directory newsgroup server)
      ;; We don't support fetching by Message-ID.
      (if (stringp (car articles))
	  'headers

	    (delete-region (point) (point-max)))
	  (setq count (1+ count))

	  (and large
	       (zerop (% count 20))
	       (nnheader-message 5 "nnmh: Receiving headers... %d%%"
			(/ (* count 100) number))))

	(when large
	  (nnheader-message 5 "nnmh: Receiving headers...done"))

	(nnheader-fold-continuation-lines)
	'headers))))

(deffoo nnmh-open-server (server &optional defs)

(deffoo nnmh-request-article (id &optional newsgroup server buffer)
  (nnmh-possibly-change-directory newsgroup server)
  (let ((file (if (stringp id)
		  nil
		(concat nnmh-current-directory (int-to-string id))))
	(pathname-coding-system 'binary)
	(file-name-coding-system 'binary)
	(nntp-server-buffer (or buffer nntp-server-buffer)))
    (and (stringp file)
	 (file-exists-p file)
	 (not (file-directory-p file))
	 (save-excursion (nnmail-find-file file))
	 (string-to-int (file-name-nondirectory file)))))

(deffoo nnmh-request-group (group &optional server dont-check)
  (nnheader-init-server-buffer)
  (nnmh-possibly-change-directory group server)
  (let ((pathname (nnmail-group-pathname group nnmh-directory))
	(pathname-coding-system 'binary)
	(file-name-coding-system 'binary)
	dir)
    (cond
     ((not (file-directory-p pathname))
      (nnheader-report
       'nnmh "Can't select group (no such directory): %s" group))

(deffoo nnmh-request-scan (&optional group server)
  (nnmail-get-new-mail 'nnmh nil nnmh-directory group))

(deffoo nnmh-request-list (&optional server dir)
  (nnheader-insert "")
  (nnmh-possibly-change-directory nil server)
  (let* ((pathname-coding-system 'binary)
	 (file-name-coding-system 'binary)
	 (nnmh-toplev
	  (file-truename (or dir (file-name-as-directory nnmh-directory)))))
    (nnmh-request-list-1 nnmh-toplev))
  (setq nnmh-group-alist (nnmail-get-active))
  t)

(defvar nnmh-toplev)
(defun nnmh-request-list-1 (dir)
  (setq dir (expand-file-name dir))
  ;; Recurse down all directories.
  (let ((dirs (and (file-readable-p dir)
		   (> (nth 1 (file-attributes (file-chase-links dir))) 2)
		   (nnheader-directory-files dir t nil t)))
	rdir)
    ;; Recurse down directories.
    (while (setq rdir (pop dirs))
      (when (and (file-directory-p rdir)
		 (file-readable-p rdir)
		 (not (equal (file-truename rdir)
			     (file-truename dir))))
	(nnmh-request-list-1 rdir))))
  ;; For each directory, generate an active file line.
  (unless (string= (expand-file-name nnmh-toplev) dir)
    (let ((files (mapcar
		  (lambda (name) (string-to-int name))
		  (directory-files dir nil "^[0-9]+$" t))))

	       (regexp-quote
		(file-truename (file-name-as-directory
				(expand-file-name nnmh-toplev))))
	       dir)
	      (nnheader-replace-chars-in-string
	       (gnus-decode-coding-string (substring dir (match-end 0))
					  nnmail-pathname-coding-system)
	       ?/ ?.))
	    (apply 'max files)
	    (apply 'min files)))))))
  t)

  (nnmh-request-list server))

(deffoo nnmh-request-expire-articles (articles newsgroup
					       &optional server force)
  (nnmh-possibly-change-directory newsgroup server)
  (let* ((is-old t)
	 article rest mod-time)
    (nnheader-init-server-buffer)

    (while (and articles is-old)
      (setq article (concat nnmh-current-directory
			    (int-to-string (car articles))))
      (when (setq mod-time (nth 5 (file-attributes article)))

		 (nnheader-message 1 "Couldn't delete article %s in %s"
				   article newsgroup)
		 (push (car articles) rest))))
	  (push (car articles) rest)))
      (setq articles (cdr articles)))
    (nnheader-message 5 "")
    (nconc rest articles)))

(deffoo nnmh-close-group (group &optional server)
  t)

(deffoo nnmh-request-accept-article (group &optional server last noinsert)
  (nnmh-possibly-change-directory group server)
  (nnmail-check-syntax)
  (when nnmail-cache-accepted-message-ids
    (nnmail-cache-insert (nnmail-fetch-field "message-id")))
  (nnheader-init-server-buffer)
  (prog1
      (if (stringp group)
	  (if noinsert
	      (nnmh-active-number group)
	    (car (nnmh-save-mail
		  (list (cons group (nnmh-active-number group)))
		  noinsert)))
	(let ((res (nnmail-article-group 'nnmh-active-number)))
	  (if (and (null res)
		   (yes-or-no-p "Moved to `junk' group; delete article? "))
	      'junk
	    (car (nnmh-save-mail res noinsert)))))
    (when (and last nnmail-cache-accepted-message-ids)
      (nnmail-cache-close))))

(deffoo nnmh-request-replace-article (article group buffer)
  (nnmh-possibly-change-directory group)

       (concat nnmh-current-directory (int-to-string article))
       nil (if (nnheader-be-verbose 5) nil 'nomesg))
      t)))

(deffoo nnmh-request-create-group (group &optional server args)
  (nnheader-init-server-buffer)
  (unless (assoc group nnmh-group-alist)
    (let (active)
      (push (list group (setq active (cons 1 0)))
	    nnmh-group-alist)
      (nnmh-possibly-create-directory group)

  (when (and server
	     (not (nnmh-server-opened server)))
    (nnmh-open-server server))
  (when newsgroup
    (let ((pathname (nnmail-group-pathname newsgroup nnmh-directory))
	  (file-name-coding-system 'binary)
	  (pathname-coding-system 'binary))
      (if (file-directory-p pathname)
	  (setq nnmh-current-directory pathname)
	(error "No such newsgroup: %s" newsgroup)))))

(defun nnmh-possibly-create-directory (group)

(defun nnmh-active-number (group)
  "Compute the next article number in GROUP."
  (let ((active (cadr (assoc group nnmh-group-alist)))
	(dir (nnmail-group-pathname group nnmh-directory))
	(file-name-coding-system 'binary)
	(pathname-coding-system 'binary))
    (unless active
      ;; The group wasn't known to nnmh, so we just create an active
      ;; entry for it.
      (setq active (cons 1 0))
      (push (list group active) nnmh-group-alist)
      (unless (file-exists-p dir)
	(gnus-make-directory dir))
      ;; Find the highest number in the group.
      (let ((files (sort
		    (mapcar
		     (lambda (f)
		       (string-to-int f))

(defun nnmh-deletable-article-p (group article)
  "Say whether ARTICLE in GROUP can be deleted."
  (let ((path (concat nnmh-current-directory (int-to-string article))))
    ;; Writable.
    (and (file-writable-p path)
	 (or
	  ;; We can never delete the last article in the group.
	  (not (eq (cdr (nth 1 (assoc group nnmh-group-alist)))
		   article))
	  ;; Well, we can.
	  nnmh-allow-delete-final))))

(provide 'nnmh)

;;; nnmh.el ends here