xemacs-beta: lisp/gnus/nnheader.el comparison

comparison lisp/gnus/nnheader.el @ 98:0d2f883870bc r20-1b1

Import from CVS: tag r20-1b1

author	cvs
date	Mon, 13 Aug 2007 09:13:56 +0200
parents	131b0175ea99
children	360340f9fd5f

comparison

equal deleted inserted replaced

-:498bf5da1c90
+:0d2f883870bc
 ;;; nnheader.el --- header access macros for Gnus and its backends
-;; Copyright (C) 1987,88,89,90,93,94,95,96 Free Software Foundation, Inc.
+;; Copyright (C) 1987,88,89,90,93,94,95,96,97 Free Software Foundation, Inc.
 ;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
 ;; 	Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
 ;; Keywords: news
 ;; uses it for xrefs.)
 ;;; Code:
 (require 'mail-utils)
-(eval-when-compile (require 'cl))
 (defvar nnheader-max-head-length 4096
 "*Max length of the head of articles.")
+(defvar nnheader-head-chop-length 2048
+"*Length of each read operation when trying to fetch HEAD headers.")
 (defvar nnheader-file-name-translation-alist nil
 "*Alist that says how to translate characters in file names.
 For instance, if \":\" is illegal as a file character in file names
 on your system, you could say something like:
 \(setq nnheader-file-name-translation-alist '((?: . ?_)))")
+(eval-and-compile
+(autoload 'nnmail-message-id "nnmail")
+(autoload 'mail-position-on-field "sendmail")
+(autoload 'message-remove-header "message")
+(autoload 'cancel-function-timers "timers"))
 ;;; Header access macros.
 (defmacro mail-header-number (header)
 "Return article number in HEADER."
 `(aref ,header 0))
 (defun make-mail-header (&optional init)
 "Create a new mail header structure initialized with INIT."
 (make-vector 9 init))
+(defun make-full-mail-header (&optional number subject from date id
+					references chars lines xref)
+"Create a new mail header structure initialized with the parameters given."
+(vector number subject from date id references chars lines xref))
+;; fake message-ids: generation and detection
+(defvar nnheader-fake-message-id 1)
+(defsubst nnheader-generate-fake-message-id ()
+(concat "fake+none+" (int-to-string (incf nnheader-fake-message-id))))
+(defsubst nnheader-fake-message-id-p (id)
+(save-match-data			; regular message-id's are <.*>
+(string-match "\\`fake\\+none\\+[0-9]+\\'" id)))
 ;; Parsing headers and NOV lines.
 (defsubst nnheader-header-value ()
 (buffer-substring (match-end 0) (gnus-point-at-eol)))
-(defvar nnheader-newsgroup-none-id 1)
 (defun nnheader-parse-head (&optional naked)
 (let ((case-fold-search t)
 	(cur (current-buffer))
 	(buffer-read-only nil)
-	end ref in-reply-to lines p)
+	in-reply-to lines p)
 (goto-char (point-min))
 (when naked
 (insert "\n"))
-;; Search to the beginning of the next header. Error messages
+;; Search to the beginning of the next header.  Error messages
 ;; do not begin with 2 or 3.
 (prog1
 	(when (or naked (re-search-forward "^[23][0-9]+ " nil t))
 	  ;; This implementation of this function, with nine
 	  ;; search-forwards instead of the one re-search-forward and
 	     (goto-char p)
 	     (if (search-forward "\nmessage-id: " nil t)
 		 (nnheader-header-value)
 	       ;; If there was no message-id, we just fake one to make
 	       ;; subsequent routines simpler.
-	       (concat "none+"
+	       (nnheader-generate-fake-message-id)))
-		       (int-to-string
-			(incf nnheader-newsgroup-none-id)))))
 	   ;; References.
 	   (progn
 	     (goto-char p)
 	     (if (search-forward "\nreferences: " nil t)
 		 (nnheader-header-value)
 		  (nnheader-header-value)))))
 (when naked
 	(goto-char (point-min))
 	(delete-char 1)))))
+(defmacro nnheader-nov-skip-field ()
+'(search-forward "\t" eol 'move))
+(defmacro nnheader-nov-field ()
+'(buffer-substring (point) (if (nnheader-nov-skip-field) (1- (point)) eol)))
+(defmacro nnheader-nov-read-integer ()
+'(prog1
+(if (= (following-char) ?\t)
+	   0
+	 (let ((num (ignore-errors (read (current-buffer)))))
+	   (if (numberp num) num 0)))
+(or (eobp) (forward-char 1))))
+;; (defvar nnheader-none-counter 0)
+(defun nnheader-parse-nov ()
+(let ((eol (gnus-point-at-eol)))
+(vector
+(nnheader-nov-read-integer)	; number
+(nnheader-nov-field)		; subject
+(nnheader-nov-field)		; from
+(nnheader-nov-field)		; date
+(or (nnheader-nov-field)
+	 (nnheader-generate-fake-message-id)) ; id
+(nnheader-nov-field)		; refs
+(nnheader-nov-read-integer)	; chars
+(nnheader-nov-read-integer)	; lines
+(if (= (following-char) ?\n)
+	 nil
+(nnheader-nov-field))		; misc
+)))
 (defun nnheader-insert-nov (header)
 (princ (mail-header-number header) (current-buffer))
 (insert
 "\t"
 (or (mail-header-subject header) "(none)") "\t"
 (or (mail-header-from header) "(nobody)") "\t"
 (or (mail-header-date header) "") "\t"
 (or (mail-header-id header)
-(nnmail-message-id)) "\t"
+(nnmail-message-id))
+"\t"
 (or (mail-header-references header) "") "\t")
 (princ (or (mail-header-chars header) 0) (current-buffer))
 (insert "\t")
 (princ (or (mail-header-lines header) 0) (current-buffer))
 (insert "\t")
 (when (mail-header-xref header)
 (insert "Xref: " (mail-header-xref header) "\t"))
 (insert "\n"))
 (defun nnheader-insert-article-line (article)
 (goto-char (point-min))
 (search-forward "\n\n" nil 'move)
 (delete-region (point) (point-max))
 (forward-char -1)
 (insert "."))
+(defun nnheader-nov-delete-outside-range (beg end)
+"Delete all NOV lines that lie outside the BEG to END range."
+;; First we find the first wanted line.
+(nnheader-find-nov-line beg)
+(delete-region (point-min) (point))
+;; Then we find the last wanted line.
+(when (nnheader-find-nov-line end)
+(forward-line 1))
+(delete-region (point) (point-max)))
+(defun nnheader-find-nov-line (article)
+"Put point at the NOV line that start with ARTICLE.
+If ARTICLE doesn't exist, put point where that line
+would have been.  The function will return non-nil if
+the line could be found."
+;; This function basically does a binary search.
+(let ((max (point-max))
+	(min (goto-char (point-min)))
+	(cur (current-buffer))
+	(prev (point-min))
+	num found)
+(while (not found)
+(goto-char (/ (+ max min) 2))
+(beginning-of-line)
+(if (or (= (point) prev)
+	      (eobp))
+	  (setq found t)
+	(setq prev (point))
+	(cond ((> (setq num (read cur)) article)
+	       (setq max (point)))
+	      ((< num article)
+	       (setq min (point)))
+	      (t
+	       (setq found 'yes)))))
+;; We may be at the first line.
+(when (and (not num)
+	       (not (eobp)))
+(setq num (read cur)))
+;; Now we may have found the article we're looking for, or we
+;; may be somewhere near it.
+(when (and (not (eq found 'yes))
+	       (not (eq num article)))
+(setq found (point))
+(while (and (< (point) max)
+		  (or (not (numberp num))
+		      (< num article)))
+	(forward-line 1)
+	(setq found (point))
+	(or (eobp)
+	    (= (setq num (read cur)) article)))
+(unless (eq num article)
+	(goto-char found)))
+(beginning-of-line)
+(eq num article)))
 ;; Various cruft the backends and Gnus need to communicate.
 (defvar nntp-server-buffer nil)
 (defvar gnus-verbose-backends 7
 "*A number that says how talkative the Gnus backends should be.")
 (defvar nnheader-callback-function nil)
 (defun nnheader-init-server-buffer ()
 "Initialize the Gnus-backend communication buffer."
 (save-excursion
-(setq nntp-server-buffer (get-buffer-create " *nntpd*"))
+(unless (gnus-buffer-live-p nntp-server-buffer)
+(setq nntp-server-buffer (get-buffer-create " *nntpd*")))
 (set-buffer nntp-server-buffer)
 (buffer-disable-undo (current-buffer))
 (erase-buffer)
 (kill-all-local-variables)
 (setq case-fold-search t)		;Should ignore case.
 t))
 ;;; Various functions the backends use.
 (defun nnheader-file-error (file)
 "Return a string that says what is wrong with FILE."
 (defun nnheader-insert-head (file)
 "Insert the head of the article."
 (when (file-exists-p file)
 (if (eq nnheader-max-head-length t)
 	;; Just read the entire file.
-	(nnheader-insert-file-contents-literally file)
+	(nnheader-insert-file-contents file)
 ;; Read 1K blocks until we find a separator.
 (let ((beg 0)
-	    format-alist
+	    format-alist)
-	    (chop 1024))
+	(while (and (eq nnheader-head-chop-length
-	(while (and (eq chop (nth 1 (insert-file-contents
+			(nth 1 (nnheader-insert-file-contents
-				     file nil beg (incf beg chop))))
+				file nil beg
-		    (prog1 (not (search-forward "\n\n" nil t))
+				(incf beg nnheader-head-chop-length))))
+		    (prog1 (not (search-forward "\n\n" nil t))
 		      (goto-char (point-max)))
 		    (or (null nnheader-max-head-length)
 			(< beg nnheader-max-head-length))))))
 t))
 (goto-char (point-min))
 (while (looking-at "[A-Z][^ \t]+:.*\n\\([ \t].*\n\\)*\\|From .*\n")
 (goto-char (match-end 0)))
 (prog1
 	(eobp)
 (widen))))
 (defun nnheader-insert-references (references message-id)
 "Insert a References header based on REFERENCES and MESSAGE-ID."
 (if (and (not references) (not message-id))
-()	; This is illegal, but not all articles have Message-IDs.
+()				; This is illegal, but not all articles have Message-IDs.
 (mail-position-on-field "References")
 (let ((begin (save-excursion (beginning-of-line) (point)))
 	  (fill-column 78)
 	  (fill-prefix "\t"))
-(if references (insert references))
+(when references
-(if (and references message-id) (insert " "))
+	(insert references))
-(if message-id (insert message-id))
+(when (and references message-id)
+	(insert " "))
+(when message-id
+	(insert message-id))
 ;; Fold long References lines to conform to RFC1036 (sort of).
 ;; The region must end with a newline to fill the region
 ;; without inserting extra newline.
 (fill-region-as-paragraph begin (1+ (point))))))
 (if (search-forward "\n\n" nil t)
 (1- (point))
 (point-max)))
 (goto-char (point-min)))
-(defun nnheader-set-temp-buffer (name)
+(defun nnheader-set-temp-buffer (name &optional noerase)
 "Set-buffer to an empty (possibly new) buffer called NAME with undo disabled."
 (set-buffer (get-buffer-create name))
 (buffer-disable-undo (current-buffer))
-(erase-buffer)
+(unless noerase
+(erase-buffer))
 (current-buffer))
 (defmacro nnheader-temp-write (file &rest forms)
-"Create a new buffer, evaluate FORM there, and write the buffer to FILE."
+"Create a new buffer, evaluate FORMS there, and write the buffer to FILE.
-`(save-excursion
+Return the value of FORMS.
-(let ((nnheader-temp-file ,file)
+If FILE is nil, just evaluate FORMS and don't save anything.
-	   (nnheader-temp-cur-buffer
+If FILE is t, return the buffer contents as a string."
-	    (nnheader-set-temp-buffer
+(let ((temp-file (make-symbol "temp-file"))
-	     (generate-new-buffer-name " *nnheader temp*"))))
+	(temp-buffer (make-symbol "temp-buffer"))
-(when (and nnheader-temp-file
+	(temp-results (make-symbol "temp-results")))
-		  (not (file-directory-p (file-name-directory
+`(save-excursion
-					  nnheader-temp-file))))
+(let* ((,temp-file ,file)
-	 (make-directory (file-name-directory nnheader-temp-file) t))
+	      (default-major-mode 'fundamental-mode)
-(unwind-protect
+	      (,temp-buffer
-	   (prog1
+	       (set-buffer
-	       (progn
+		(get-buffer-create
-		 ,@forms)
+		 (generate-new-buffer-name " *nnheader temp*"))))
-	     (when nnheader-temp-file
+	      ,temp-results)
-	       (set-buffer nnheader-temp-cur-buffer)
+	 (unwind-protect
-	       (write-region (point-min) (point-max)
+	     (progn
-			     nnheader-temp-file nil 'nomesg)))
+	       (setq ,temp-results (progn ,@forms))
-	 (when (buffer-name nnheader-temp-cur-buffer)
+	       (cond
-	   (kill-buffer nnheader-temp-cur-buffer))))))
+		;; Don't save anything.
+		((null ,temp-file)
+		 ,temp-results)
+		;; Return the buffer contents.
+		((eq ,temp-file t)
+		 (set-buffer ,temp-buffer)
+		 (buffer-string))
+		;; Save a file.
+		(t
+		 (set-buffer ,temp-buffer)
+		 ;; Make sure the directory where this file is
+		 ;; to be saved exists.
+		 (when (not (file-directory-p
+			     (file-name-directory ,temp-file)))
+		   (make-directory (file-name-directory ,temp-file) t))
+		 ;; Save the file.
+		 (write-region (point-min) (point-max)
+			       ,temp-file nil 'nomesg)
+		 ,temp-results)))
+	   ;; Kill the buffer.
+	   (when (buffer-name ,temp-buffer)
+	     (kill-buffer ,temp-buffer)))))))
 (put 'nnheader-temp-write 'lisp-indent-function 1)
-(put 'nnheader-temp-write 'lisp-indent-hook 1)
 (put 'nnheader-temp-write 'edebug-form-spec '(form body))
 (defvar jka-compr-compression-info-list)
 (defvar nnheader-numerical-files
 (if (boundp 'jka-compr-compression-info-list)
 	  (nnheader-directory-files-safe
 	   dir nil nnheader-numerical-short-files t)))
 (defun nnheader-fold-continuation-lines ()
 "Fold continuation lines in the current buffer."
-(goto-char (point-min))
+(nnheader-replace-regexp "\\(\r?\n[ \t]+\\)+" " "))
-(while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t)
-(replace-match " " t t)))
 (defun nnheader-translate-file-chars (file)
 (if (null nnheader-file-name-translation-alist)
 ;; No translation is necessary.
 file
 	   (car args)
 	 (apply 'format args)))
 nil)
 (defun nnheader-get-report (backend)
-(message "%s" (symbol-value (intern (format "%s-status-string" backend)))))
+"Get the most recent report from BACKEND."
+(condition-case ()
+(message "%s" (symbol-value (intern (format "%s-status-string"
+						  backend))))
+(error (message ""))))
 (defun nnheader-insert (format &rest args)
-"Clear the communicaton buffer and insert FORMAT and ARGS into the buffer.
+"Clear the communication buffer and insert FORMAT and ARGS into the buffer.
 If FORMAT isn't a format string, it and all ARGS will be inserted
 without formatting."
 (save-excursion
 (set-buffer nntp-server-buffer)
 (erase-buffer)
 (when (and (file-exists-p file)
 	     (file-readable-p file)
 	     (file-regular-p file))
 (save-excursion
 (nnheader-set-temp-buffer " *mail-file-mbox-p*")
-(nnheader-insert-file-contents-literally file)
+(nnheader-insert-file-contents file)
 (goto-char (point-min))
 (prog1
 	  (looking-at message-unix-mail-delimiter)
 	(kill-buffer (current-buffer))))))
 (let ((string (substring string 0))	;Copy string.
 	(len (length string))
 	(idx 0))
 ;; Replace all occurrences of FROM with TO.
 (while (< idx len)
-(if (= (aref string idx) from)
+(when (= (aref string idx) from)
-	  (aset string idx to))
+	(aset string idx to))
 (setq idx (1+ idx)))
 string))
 (defun nnheader-file-to-group (file &optional top)
 "Return a group name based on FILE and TOP."
 (defun nnheader-functionp (form)
 "Return non-nil if FORM is funcallable."
 (or (and (symbolp form) (fboundp form))
 (and (listp form) (eq (car form) 'lambda))))
-(defun nnheader-concat (dir file)
+(defun nnheader-concat (dir &rest files)
 "Concat DIR as directory to FILE."
-(concat (file-name-as-directory dir) file))
+(apply 'concat (file-name-as-directory dir) files))
 (defun nnheader-ms-strip-cr ()
 "Strip ^M from the end of all lines."
 (save-excursion
 (goto-char (point-min))
 (defun nnheader-file-size (file)
 "Return the file size of FILE or 0."
 (or (nth 7 (file-attributes file)) 0))
-(defun nnheader-find-etc-directory (package)
+(defun nnheader-find-etc-directory (package &optional file)
-"Go through the path and find the \".../etc/PACKAGE\" directory."
+"Go through the path and find the \".../etc/PACKAGE\" directory.
+If FILE, find the \".../etc/PACKAGE\" file instead."
 (let ((path load-path)
 	dir result)
 ;; We try to find the dir by looking at the load path,
 ;; stripping away the last component and adding "etc/".
 (while path
 (if (and (car path)
 	       (file-exists-p
 		(setq dir (concat
 			   (file-name-directory
 			    (directory-file-name (car path)))
-			   "etc/" package "/")))
+			   "etc/" package
-	       (file-directory-p dir))
+			   (if file "" "/"))))
+	       (or file (file-directory-p dir)))
 	  (setq result dir
 		path nil)
 	(setq path (cdr path))))
 result))
 (defvar ange-ftp-path-format)
 (defvar efs-path-regexp)
 (defun nnheader-re-read-dir (path)
 "Re-read directory PATH if PATH is on a remote system."
 (if (and (fboundp 'efs-re-read-dir) (boundp 'efs-path-regexp))
-	(when (string-match efs-path-regexp path)
+(when (string-match efs-path-regexp path)
-	  (efs-re-read-dir path))
+	(efs-re-read-dir path))
-(if (and (fboundp 'ange-ftp-re-read-dir) (boundp 'ange-ftp-path-format))
+(when (and (fboundp 'ange-ftp-re-read-dir) (boundp 'ange-ftp-path-format))
 (when (string-match (car ange-ftp-path-format) path)
 	(ange-ftp-re-read-dir path)))))
+(defun nnheader-insert-file-contents (filename &optional visit beg end replace)
+"Like `insert-file-contents', q.v., but only reads in the file.
+A buffer may be modified in several ways after reading into the buffer due
+to advanced Emacs features, such as file-name-handlers, format decoding,
+find-file-hooks, etc.
+This function ensures that none of these modifications will take place."
+(let ((format-alist nil)
+	(auto-mode-alist (nnheader-auto-mode-alist))
+	(default-major-mode 'fundamental-mode)
+(after-insert-file-functions nil))
+(insert-file-contents filename visit beg end replace)))
+(defun nnheader-find-file-noselect (&rest args)
+(let ((format-alist nil)
+	(auto-mode-alist (nnheader-auto-mode-alist))
+	(default-major-mode 'fundamental-mode)
+	(enable-local-variables nil)
+(after-insert-file-functions nil))
+(apply 'find-file-noselect args)))
+(defun nnheader-auto-mode-alist ()
+"Return an `auto-mode-alist' with only the .gz (etc) thingies."
+(let ((alist auto-mode-alist)
+	out)
+(while alist
+(when (listp (cdar alist))
+	(push (car alist) out))
+(pop alist))
+(nreverse out)))
+(defun nnheader-directory-regular-files (dir)
+"Return a list of all regular files in DIR."
+(let ((files (directory-files dir t))
+	out)
+(while files
+(when (file-regular-p (car files))
+	(push (car files) out))
+(pop files))
+(nreverse out)))
+(defmacro nnheader-skeleton-replace (from &optional to regexp)
+`(let ((new (generate-new-buffer " *nnheader replace*"))
+	 (cur (current-buffer))
+	 (start (point-min)))
+(set-buffer new)
+(buffer-disable-undo (current-buffer))
+(set-buffer cur)
+(goto-char (point-min))
+(while (,(if regexp 're-search-forward 'search-forward)
+	     ,from nil t)
+(insert-buffer-substring
+	cur start (prog1 (match-beginning 0) (set-buffer new)))
+(goto-char (point-max))
+,(when to `(insert ,to))
+(set-buffer cur)
+(setq start (point)))
+(insert-buffer-substring
+cur start (prog1 (point-max) (set-buffer new)))
+(copy-to-buffer cur (point-min) (point-max))
+(kill-buffer (current-buffer))
+(set-buffer cur)))
+(defun nnheader-replace-string (from to)
+"Do a fast replacement of FROM to TO from point to point-max."
+(nnheader-skeleton-replace from to))
+(defun nnheader-replace-regexp (from to)
+"Do a fast regexp replacement of FROM to TO from point to point-max."
+(nnheader-skeleton-replace from to t))
+(defun nnheader-strip-cr ()
+"Strip all \r's from the current buffer."
+(nnheader-skeleton-replace "\r"))
 (fset 'nnheader-run-at-time 'run-at-time)
 (fset 'nnheader-cancel-timer 'cancel-timer)
-(fset 'nnheader-find-file-noselect 'find-file-noselect)
+(fset 'nnheader-cancel-function-timers 'cancel-function-timers)
-(fset 'nnheader-insert-file-contents-literally
-'insert-file-contents-literally)
 (when (string-match "XEmacs\\|Lucid" emacs-version)
 (require 'nnheaderxm))
 (run-hooks 'nnheader-load-hook)

Mercurial > hg > xemacs-beta

comparison lisp/gnus/nnheader.el @ 98:0d2f883870bc r20-1b1