* gnus-clfns.el (coerce, copy-list, merge, string, subseq): Comment out those

[elisp/gnus.git-] / lisp / nnheader.el

diff --git a/lisp/nnheader.el b/lisp/nnheader.el
index 7f271f8..da24c44 100644 (file)
--- a/lisp/nnheader.el
+++ b/lisp/nnheader.el
@@ -1,7 +1,7 @@
 ;;; nnheader.el --- header access macros for Semi-gnus and its backends
 
 ;; Copyright (C) 1987, 1988, 1989, 1990, 1993, 1994, 1995, 1996,
 ;;; nnheader.el --- header access macros for Semi-gnus and its backends
 
 ;; Copyright (C) 1987, 1988, 1989, 1990, 1993, 1994, 1995, 1996,

-;;        1997, 1998, 2000, 2001, 2002
+;;        1997, 1998, 2000, 2001, 2002, 2003

 ;;        Free Software Foundation, Inc.
 
 ;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
 ;;        Free Software Foundation, Inc.
 
 ;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>

@@ -36,7 +36,7 @@
 
 ;; Requiring `gnus-util' at compile time creates a circular
 ;; dependency between nnheader.el and gnus-util.el.
 
 ;; Requiring `gnus-util' at compile time creates a circular
 ;; dependency between nnheader.el and gnus-util.el.

-;(eval-when-compile (require 'gnus-util))
+;;(eval-when-compile (require 'gnus-util))

 
 (require 'mail-utils)
 
 
 (require 'mail-utils)
 

@@ -79,6 +79,14 @@ Integer values will in effect be rounded up to the nearest multiple of
 (defvar nnheader-head-chop-length 2048
   "*Length of each read operation when trying to fetch HEAD headers.")
 
 (defvar nnheader-head-chop-length 2048
   "*Length of each read operation when trying to fetch HEAD headers.")
 

+(defvar nnheader-read-timeout
+  (if (string-match "windows-nt\\|os/2\\|emx\\|cygwin"
+                   (symbol-name system-type))
+      1.0
+    0.1)
+  "How long nntp should wait between checking for the end of output.
+Shorter values mean quicker response, but is more CPU intensive.")
+

 (defvar nnheader-file-name-translation-alist
   (let ((case-fold-search t))
     (cond
 (defvar nnheader-file-name-translation-alist
   (let ((case-fold-search t))
     (cond

@@ -108,27 +116,9 @@ This variable is a substitute for `mm-text-coding-system'.")
   "Text coding system for write.
 This variable is a substitute for `mm-text-coding-system-for-write'.")
 
   "Text coding system for write.
 This variable is a substitute for `mm-text-coding-system-for-write'.")
 

-;; Define `emacs-mule' coding system for XEmacs.
-(and
- (featurep 'xemacs)
- (featurep 'mule)
- (not (find-coding-system 'emacs-mule))
- (let ((ccl (if (fboundp 'ccl-compile-write-multibyte-character)
-               '(1
-                 (loop
-                  (read-multibyte-character r0 r1)
-                  (write-multibyte-character r0 r1)
-                  (repeat)))
-             '(1 (loop (read r0) (write-repeat r0))))))
-   (define-ccl-program emacs-mule-codec ccl)
-   (make-coding-system 'emacs-mule 'ccl
-                      "FSF Emacs internal format used in buffer and string."
-                      '(decode emacs-mule-codec
-                        encode emacs-mule-codec))))
-

 (defvar nnheader-auto-save-coding-system
   (cond
 (defvar nnheader-auto-save-coding-system
   (cond

-   ((boundp 'MULE) '*internal*)
+   ((boundp 'MULE) '*junet*)

    ((not (fboundp 'find-coding-system)) nil)
    ((find-coding-system 'emacs-mule)
     (if (memq system-type '(windows-nt ms-dos ms-windows))
    ((not (fboundp 'find-coding-system)) nil)
    ((find-coding-system 'emacs-mule)
     (if (memq system-type '(windows-nt ms-dos ms-windows))

@@ -138,6 +128,10 @@ This variable is a substitute for `mm-text-coding-system-for-write'.")
    (t nil))
   "Coding system of auto save file.")
 
    (t nil))
   "Coding system of auto save file.")
 

+(defvar nnheader-directory-separator-character
+  (string-to-char (substring (file-name-as-directory ".") -1))
+  "*A character used to a directory separator.")
+

 (eval-and-compile
   (autoload 'nnmail-message-id "nnmail")
   (autoload 'mail-position-on-field "sendmail")
 (eval-and-compile
   (autoload 'nnmail-message-id "nnmail")
   (autoload 'mail-position-on-field "sendmail")

@@ -618,6 +612,11 @@ given, the return value will not contain the last newline."
 
 ;; Parsing headers and NOV lines.
 
 
 ;; Parsing headers and NOV lines.
 

+(defsubst nnheader-remove-cr-followed-by-lf ()
+  (goto-char (point-max))
+  (while (search-backward "\r\n" nil t)
+    (delete-char 1)))
+

 (defsubst nnheader-header-value ()
   (let ((pt (point)))
     (prog2
 (defsubst nnheader-header-value ()
   (let ((pt (point)))
     (prog2

@@ -625,116 +624,126 @@ given, the return value will not contain the last newline."
        (buffer-substring (point) (std11-field-end))
       (goto-char pt))))
 
        (buffer-substring (point) (std11-field-end))
       (goto-char pt))))
 

-(defun nnheader-parse-head (&optional naked)
+(defun nnheader-parse-naked-head (&optional number)
+  ;; This function unfolds continuation lines in this buffer
+  ;; destructively.  When this side effect is unwanted, use
+  ;; `nnheader-parse-head' instead of this function.

   (let ((case-fold-search t)
   (let ((case-fold-search t)

-       (cur (current-buffer))

        (buffer-read-only nil)
        (buffer-read-only nil)

-       in-reply-to lines p ref)
-    (goto-char (point-min))
-    (when naked
-      (insert "\n"))
-    ;; Search to the beginning of the next header.  Error messages
-    ;; do not begin with 2 or 3.
+       (cur (current-buffer))
+       (p (point-min))
+       in-reply-to lines ref)
+    (nnheader-remove-cr-followed-by-lf)
+    (ietf-drums-unfold-fws)
+    (subst-char-in-region (point-min) (point-max) ?\t ? )
+    (goto-char p)
+    (insert "\n")

     (prog1
     (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
-         ;; a case (which basically was the old function) is actually
-         ;; about twice as fast, even though it looks messier.  You
-         ;; can't have everything, I guess.  Speed and elegance
-         ;; don't always go hand in hand.
-         (make-full-mail-header
-          ;; Number.
-          (if naked
-              (progn
-                (setq p (point-min))
-                0)
-            (prog1
-                (read cur)
-              (end-of-line)
-              (setq p (point))
-              (narrow-to-region (point)
-                                (or (and (search-forward "\n.\n" nil t)
-                                         (- (point) 2))
-                                    (point)))))
-          ;; Subject.
-          (progn
-            (goto-char p)
-            (if (search-forward "\nsubject:" nil t)
-                (nnheader-header-value) "(none)"))
-          ;; From.
-          (progn
-            (goto-char p)
-            (if (search-forward "\nfrom:" nil t)
-                (nnheader-header-value) "(nobody)"))
-          ;; Date.
-          (progn
-            (goto-char p)
-            (if (search-forward "\ndate:" nil t)
-                (nnheader-header-value) ""))
-          ;; Message-ID.
-          (progn
-            (goto-char p)
-            (if (search-forward "\nmessage-id:" nil t)
-                (buffer-substring
-                 (1- (or (search-forward "<" (gnus-point-at-eol) t)
-                         (point)))
-                 (or (search-forward ">" (gnus-point-at-eol) t) (point)))
-              ;; If there was no message-id, we just fake one to make
-              ;; subsequent routines simpler.
-              (nnheader-generate-fake-message-id)))
-          ;; References.
-          (progn
-            (goto-char p)
-            (if (search-forward "\nreferences:" nil t)
-                (nnheader-header-value)
-              ;; Get the references from the in-reply-to header if there
-              ;; were no references and the in-reply-to header looks
-              ;; promising.
-              (if (and (search-forward "\nin-reply-to:" nil t)
-                       (setq in-reply-to (nnheader-header-value))
-                       (string-match "<[^\n>]+>" in-reply-to))
-                  (let (ref2)
-                    (setq ref (substring in-reply-to (match-beginning 0)
-                                         (match-end 0)))
-                    (while (string-match "<[^\n>]+>"
-                                         in-reply-to (match-end 0))
-                      (setq ref2 (substring in-reply-to (match-beginning 0)
-                                            (match-end 0)))
-                      (when (> (length ref2) (length ref))
-                        (setq ref ref2)))
-                    ref)
-                nil)))
-          ;; Chars.
-          0
-          ;; Lines.
-          (progn
-            (goto-char p)
-            (if (search-forward "\nlines: " nil t)
-                (if (numberp (setq lines (read cur)))
-                    lines 0)
-              0))
-          ;; Xref.
-          (progn
-            (goto-char p)
-            (and (search-forward "\nxref:" nil t)
-                 (nnheader-header-value)))
-
-          ;; Extra.
-          (when nnmail-extra-headers
-            (let ((extra nnmail-extra-headers)
-                  out)
-              (while extra
-                (goto-char p)
-                (when (search-forward
-                       (concat "\n" (symbol-name (car extra)) ":") nil t)
-                  (push (cons (car extra) (nnheader-header-value))
-                        out))
-                (pop extra))
-              out))))
-      (when naked
-       (goto-char (point-min))
-       (delete-char 1)))))
+       ;; This implementation of this function, with nine
+       ;; search-forwards instead of the one re-search-forward and a
+       ;; case (which basically was the old function) is actually
+       ;; about twice as fast, even though it looks messier.  You
+       ;; can't have everything, I guess.  Speed and elegance don't
+       ;; always go hand in hand.
+       (make-full-mail-header
+        ;; Number.
+        (or number 0)
+        ;; Subject.
+        (progn
+          (goto-char p)
+          (if (search-forward "\nsubject:" nil t)
+              (nnheader-header-value) "(none)"))
+        ;; From.
+        (progn
+          (goto-char p)
+          (if (search-forward "\nfrom:" nil t)
+              (nnheader-header-value) "(nobody)"))
+        ;; Date.
+        (progn
+          (goto-char p)
+          (if (search-forward "\ndate:" nil t)
+              (nnheader-header-value) ""))
+        ;; Message-ID.
+        (progn
+          (goto-char p)
+          (if (search-forward "\nmessage-id:" nil t)
+              (buffer-substring
+               (1- (or (search-forward "<" (gnus-point-at-eol) t)
+                       (point)))
+               (or (search-forward ">" (gnus-point-at-eol) t) (point)))
+            ;; If there was no message-id, we just fake one to make
+            ;; subsequent routines simpler.
+            (nnheader-generate-fake-message-id)))
+        ;; References.
+        (progn
+          (goto-char p)
+          (if (search-forward "\nreferences:" nil t)
+              (nnheader-header-value)
+            ;; Get the references from the in-reply-to header if
+            ;; there were no references and the in-reply-to header
+            ;; looks promising.
+            (if (and (search-forward "\nin-reply-to:" nil t)
+                     (setq in-reply-to (nnheader-header-value))
+                     (string-match "<[^\n>]+>" in-reply-to))
+                (let (ref2)
+                  (setq ref (substring in-reply-to (match-beginning 0)
+                                       (match-end 0)))
+                  (while (string-match "<[^\n>]+>"
+                                       in-reply-to (match-end 0))
+                    (setq ref2 (substring in-reply-to (match-beginning 0)
+                                          (match-end 0)))
+                    (when (> (length ref2) (length ref))
+                      (setq ref ref2)))
+                  ref)
+              nil)))
+        ;; Chars.
+        0
+        ;; Lines.
+        (progn
+          (goto-char p)
+          (if (search-forward "\nlines: " nil t)
+              (if (numberp (setq lines (read cur)))
+                  lines 0)
+            0))
+        ;; Xref.
+        (progn
+          (goto-char p)
+          (and (search-forward "\nxref:" nil t)
+               (nnheader-header-value)))
+        ;; Extra.
+        (when nnmail-extra-headers
+          (let ((extra nnmail-extra-headers)
+                out)
+            (while extra
+              (goto-char p)
+              (when (search-forward
+                     (concat "\n" (symbol-name (car extra)) ":") nil t)
+                (push (cons (car extra) (nnheader-header-value))
+                      out))
+              (pop extra))
+            out)))
+      (goto-char p)
+      (delete-char 1))))
+
+(defun nnheader-parse-head (&optional naked)
+  (let ((cur (current-buffer)) num beg end)
+    (when (if naked
+             (setq num 0
+                   beg (point-min)
+                   end (point-max))
+           (goto-char (point-min))
+           ;; Search to the beginning of the next header.  Error
+           ;; messages do not begin with 2 or 3.
+           (when (re-search-forward "^[23][0-9]+ " nil t)
+             (end-of-line)
+             (setq num (read cur)
+                   beg (point)
+                   end (if (search-forward "\n.\n" nil t)
+                           (- (point) 2)
+                         (point)))))
+      (with-temp-buffer
+       (insert-buffer-substring cur beg end)
+       (nnheader-parse-naked-head num)))))

 
 (defmacro nnheader-nov-skip-field ()
   '(search-forward "\t" eol 'move))
 
 (defmacro nnheader-nov-skip-field ()
   '(search-forward "\t" eol 'move))

@@ -879,7 +888,7 @@ the line could be found."
        (prev (point-min))
        num found)
     (while (not found)
        (prev (point-min))
        num found)
     (while (not found)

-      (goto-char (/ (+ max min) 2))
+      (goto-char (+ min (/ (- max min) 2)))

       (beginning-of-line)
       (if (or (= (point) prev)
              (eobp))
       (beginning-of-line)
       (if (or (= (point) prev)
              (eobp))

@@ -887,8 +896,7 @@ the line could be found."
        (setq prev (point))
        (while (and (not (numberp (setq num (read cur))))
                    (not (eobp)))
        (setq prev (point))
        (while (and (not (numberp (setq num (read cur))))
                    (not (eobp)))

-         (delete-region (progn (beginning-of-line) (point))
-                        (progn (forward-line 1) (point))))
+         (gnus-delete-line))

        (cond ((> num article)
               (setq max (point)))
              ((< num article)
        (cond ((> num article)
               (setq max (point)))
              ((< num article)

@@ -1175,7 +1183,7 @@ list of headers that match SEQUENCE (see `nntp-retrieve-headers')."
       ;; This is invalid, but not all articles have Message-IDs.
       ()
     (mail-position-on-field "References")
       ;; This is invalid, but not all articles have Message-IDs.
       ()
     (mail-position-on-field "References")

-    (let ((begin (save-excursion (beginning-of-line) (point)))
+    (let ((begin (gnus-point-at-bol))

          (fill-column 78)
          (fill-prefix "\t"))
       (when references
          (fill-column 78)
          (fill-prefix "\t"))
       (when references

@@ -1209,6 +1217,12 @@ list of headers that match SEQUENCE (see `nntp-retrieve-headers')."
      (point-max)))
   (goto-char (point-min)))
 
      (point-max)))
   (goto-char (point-min)))
 

+(defun nnheader-remove-body ()
+  "Remove the body from an article in this current buffer."
+  (goto-char (point-min))
+  (when (re-search-forward "\n\r?\n" nil t)
+    (delete-region (point) (point-max))))
+

 (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))
 (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))

@@ -1231,7 +1245,7 @@ list of headers that match SEQUENCE (see `nntp-retrieve-headers')."
   "Regexp that matches numerical file names.")
 
 (defvar nnheader-numerical-full-files (concat "/" nnheader-numerical-files)
   "Regexp that matches numerical file names.")
 
 (defvar nnheader-numerical-full-files (concat "/" nnheader-numerical-files)

-  "Regexp that matches numerical full file paths.")
+  "Regexp that matches numerical full file names.")

 
 (defsubst nnheader-file-to-number (file)
   "Take a FILE name and return the article number."
 
 (defsubst nnheader-file-to-number (file)
   "Take a FILE name and return the article number."

@@ -1296,7 +1310,8 @@ If FULL, translate everything."
        ;; We translate -- but only the file name.  We leave the directory
        ;; alone.
        (if (and (featurep 'xemacs)
        ;; We translate -- but only the file name.  We leave the directory
        ;; alone.
        (if (and (featurep 'xemacs)

-                (memq system-type '(cygwin32 win32 w32 mswindows windows-nt)))
+                (memq system-type '(cygwin32 win32 w32 mswindows windows-nt
+                                             cygwin)))

            ;; This is needed on NT and stuff, because
            ;; file-name-nondirectory is not enough to split
            ;; file names, containing ':', e.g.
            ;; This is needed on NT and stuff, because
            ;; file-name-nondirectory is not enough to split
            ;; file names, containing ':', e.g.

@@ -1394,7 +1409,7 @@ without formatting."
                     (expand-file-name
                      (file-name-as-directory top))))
        (error "")))
                     (expand-file-name
                      (file-name-as-directory top))))
        (error "")))

-   ?/ ?.))
+   nnheader-directory-separator-character ?.))

 
 (defun nnheader-message (level &rest args)
   "Message if the Gnus backends are talkative."
 
 (defun nnheader-message (level &rest args)
   "Message if the Gnus backends are talkative."

@@ -1409,10 +1424,10 @@ without formatting."
       (<= level gnus-verbose-backends)))
 
 (defvar nnheader-pathname-coding-system 'binary
       (<= level gnus-verbose-backends)))
 
 (defvar nnheader-pathname-coding-system 'binary

-  "*Coding system for pathname.")
+  "*Coding system for file name.")

 
 (defun nnheader-group-pathname (group dir &optional file)
 
 (defun nnheader-group-pathname (group dir &optional file)

-  "Make pathname for GROUP."
+  "Make file name for GROUP."

   (concat
    (let ((dir (file-name-as-directory (expand-file-name dir))))
      ;; If this directory exists, we use it directly.
   (concat
    (let ((dir (file-name-as-directory (expand-file-name dir))))
      ;; If this directory exists, we use it directly.

@@ -1440,16 +1455,16 @@ without formatting."
 (defun nnheader-ms-strip-cr ()
   "Strip ^M from the end of all lines."
   (save-excursion
 (defun nnheader-ms-strip-cr ()
   "Strip ^M from the end of all lines."
   (save-excursion

-    (goto-char (point-min))
-    (while (re-search-forward "\r$" nil t)
-      (delete-backward-char 1))))
+    (nnheader-remove-cr-followed-by-lf)))

 
 (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 &optional file)
 
 (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 &optional file)

-  "Go through the path and find the \".../etc/PACKAGE\" directory.
+  "Go through `load-path' and find the \"../etc/PACKAGE\" directory.
+This function will look in the parent directory of each `load-path'
+entry, and look for the \"etc\" directory there.

 If FILE, find the \".../etc/PACKAGE\" file instead."
   (let ((path load-path)
        dir result)
 If FILE, find the \".../etc/PACKAGE\" file instead."
   (let ((path load-path)
        dir result)

@@ -1503,21 +1518,22 @@ find-file-hooks, etc.
 (defun nnheader-insert-nov-file (file first)
   (let ((size (nth 7 (file-attributes file)))
        (cutoff (* 32 1024)))
 (defun nnheader-insert-nov-file (file first)
   (let ((size (nth 7 (file-attributes file)))
        (cutoff (* 32 1024)))

-    (if (< size cutoff)
-       ;; If the file is small, we just load it.
-       (nnheader-insert-file-contents file)
-      ;; We start on the assumption that FIRST is pretty recent.  If
-      ;; not, we just insert the rest of the file as well.
-      (let (current)
-       (nnheader-insert-file-contents file nil (- size cutoff) size)
-       (goto-char (point-min))
-       (delete-region (point) (or (search-forward "\n" nil 'move) (point)))
-       (setq current (ignore-errors (read (current-buffer))))
-       (if (and (numberp current)
-                (< current first))
-           t
-         (delete-region (point-min) (point-max))
-         (nnheader-insert-file-contents file))))))
+    (when size
+      (if (< size cutoff)
+          ;; If the file is small, we just load it.
+          (nnheader-insert-file-contents file)
+        ;; We start on the assumption that FIRST is pretty recent.  If
+        ;; not, we just insert the rest of the file as well.
+        (let (current)
+          (nnheader-insert-file-contents file nil (- size cutoff) size)
+          (goto-char (point-min))
+          (delete-region (point) (or (search-forward "\n" nil 'move) (point)))
+          (setq current (ignore-errors (read (current-buffer))))
+          (if (and (numberp current)
+                   (< current first))
+              t
+            (delete-region (point-min) (point-max))
+            (nnheader-insert-file-contents file)))))))

 
 (defun nnheader-find-file-noselect (&rest args)
   (let ((format-alist nil)
 
 (defun nnheader-find-file-noselect (&rest args)
   (let ((format-alist nil)

@@ -1621,6 +1637,14 @@ find-file-hooks, etc.
        standard-output
       (call-process shell-file-name nil t nil shell-command-switch command))))
 
        standard-output
       (call-process shell-file-name nil t nil shell-command-switch command))))
 

+(defun nnheader-accept-process-output (process)
+  (accept-process-output
+   process
+   (truncate nnheader-read-timeout)
+   (truncate (* (- nnheader-read-timeout
+                  (truncate nnheader-read-timeout))
+               1000))))
+

 (when (featurep 'xemacs)
   (require 'nnheaderxm))
 
 (when (featurep 'xemacs)
   (require 'nnheaderxm))