git.chise.org Git - elisp/gnus.git-/blob - lisp/nnheader.el

   1 ;;; nnheader.el --- header access macros for Semi-gnus and its backends
   2
   3 ;; Copyright (C) 1987, 1988, 1989, 1990, 1993, 1994, 1995, 1996,
   4 ;;        1997, 1998, 2000
   5 ;;        Free Software Foundation, Inc.
   6
   7 ;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
   8 ;;      Lars Magne Ingebrigtsen <larsi@gnus.org>
   9 ;;      MORIOKA Tomohiko <morioka@jaist.ac.jp>
  10 ;;      Katsumi Yamaoka <yamaoka@jpl.org>
  11 ;; Keywords: mail, news, MIME
  12
  13 ;; This file is part of GNU Emacs.
  14
  15 ;; GNU Emacs is free software; you can redistribute it and/or modify
  16 ;; it under the terms of the GNU General Public License as published by
  17 ;; the Free Software Foundation; either version 2, or (at your option)
  18 ;; any later version.
  19
  20 ;; GNU Emacs is distributed in the hope that it will be useful,
  21 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  22 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  23 ;; GNU General Public License for more details.
  24
  25 ;; You should have received a copy of the GNU General Public License
  26 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  27 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  28 ;; Boston, MA 02111-1307, USA.
  29
  30 ;;; Commentary:
  31
  32 ;;; Code:
  33
  34 (eval-when-compile (require 'cl))
  35 (eval-when-compile (require 'static))
  36
  37 (require 'mail-utils)
  38 (require 'mime)
  39
  40 (defvar nnheader-max-head-length 4096
  41   "*Max length of the head of articles.")
  42
  43 (defvar nnheader-head-chop-length 2048
  44   "*Length of each read operation when trying to fetch HEAD headers.")
  45
  46 (defvar nnheader-file-name-translation-alist nil
  47   "*Alist that says how to translate characters in file names.
  48 For instance, if \":\" is invalid as a file character in file names
  49 on your system, you could say something like:
  50
  51 \(setq nnheader-file-name-translation-alist '((?: . ?_)))")
  52
  53 (defvar nnheader-text-coding-system
  54   (if (memq system-type '(windows-nt ms-dos ms-windows))
  55       'raw-text-dos
  56     'raw-text)
  57   "Text-safe coding system (For removing ^M).
  58 This variable is a substitute for `mm-text-coding-system'.")
  59
  60 (defvar nnheader-text-coding-system-for-write nil
  61   "Text coding system for write.
  62 This variable is a substitute for `mm-text-coding-system-for-write'.")
  63
  64 (eval-and-compile
  65   (autoload 'nnmail-message-id "nnmail")
  66   (autoload 'mail-position-on-field "sendmail")
  67   (autoload 'message-remove-header "message")
  68   (autoload 'gnus-point-at-eol "gnus-util")
  69   (autoload 'gnus-delete-line "gnus-util")
  70   (autoload 'gnus-buffer-live-p "gnus-util"))
  71
  72 ;;; Header access macros.
  73
  74 ;; These macros may look very much like the ones in GNUS 4.1.  They
  75 ;; are, in a way, but you should note that the indices they use have
  76 ;; been changed from the internal GNUS format to the NOV format.  The
  77 ;; makes it possible to read headers from XOVER much faster.
  78 ;;
  79 ;; The format of a header is now:
  80 ;; [number subject from date id references chars lines xref extra]
  81 ;;
  82 ;; (That next-to-last entry is defined as "misc" in the NOV format,
  83 ;; but Gnus uses it for xrefs.)
  84
  85 (require 'mmgnus)
  86
  87 (defmacro mail-header-number (header)
  88   "Return article number in HEADER."
  89   `(mime-entity-location-internal ,header))
  90
  91 (defmacro mail-header-set-number (header number)
  92   "Set article number of HEADER to NUMBER."
  93   `(mime-entity-set-location-internal ,header ,number))
  94
  95 (defalias 'mail-header-subject 'mime-gnus-entity-subject-internal)
  96 (defalias 'mail-header-set-subject 'mime-gnus-entity-set-subject-internal)
  97
  98 (defalias 'mail-header-from 'mime-gnus-entity-from-internal)
  99 (defalias 'mail-header-set-from 'mime-gnus-entity-set-from-internal)
 100
 101 (defalias 'mail-header-date 'mime-gnus-entity-date-internal)
 102 (defalias 'mail-header-set-date 'mime-gnus-entity-set-date-internal)
 103
 104 (defalias 'mail-header-message-id 'mime-gnus-entity-id-internal)
 105 (defalias 'mail-header-id 'mime-gnus-entity-id-internal)
 106 (defalias 'mail-header-set-message-id 'mime-gnus-entity-set-id-internal)
 107 (defalias 'mail-header-set-id 'mime-gnus-entity-set-id-internal)
 108
 109 (defalias 'mail-header-references 'mime-gnus-entity-references-internal)
 110 (defalias 'mail-header-set-references
 111   'mime-gnus-entity-set-references-internal)
 112
 113 (defalias 'mail-header-chars 'mime-gnus-entity-chars-internal)
 114 (defalias 'mail-header-set-chars 'mime-gnus-entity-set-chars-internal)
 115
 116 (defalias 'mail-header-lines 'mime-gnus-entity-lines-internal)
 117 (defalias 'mail-header-set-lines 'mime-gnus-entity-set-lines-internal)
 118
 119 (defalias 'mail-header-xref 'mime-gnus-entity-xref-internal)
 120 (defalias 'mail-header-set-xref 'mime-gnus-entity-set-xref-internal)
 121
 122 (defalias 'nnheader-decode-subject
 123   (mime-find-field-decoder 'Subject 'nov))
 124 (defalias 'nnheader-decode-from
 125   (mime-find-field-decoder 'From 'nov))
 126
 127 (defalias 'mail-header-extra 'mime-gnus-entity-extra-internal)
 128 (defalias 'mail-header-set-extra 'mime-gnus-entity-set-extra-internal)
 129
 130 (defun nnheader-decode-field-body (field-body field-name
 131                                               &optional mode max-column)
 132   (mime-decode-field-body field-body
 133                           (if (stringp field-name)
 134                               (intern (capitalize field-name))
 135                             field-name)
 136                           mode max-column))
 137
 138 (defsubst make-full-mail-header (&optional number subject from date id
 139                                            references chars lines xref
 140                                            extra)
 141   "Create a new mail header structure initialized with the parameters given."
 142   (luna-make-entity (mm-expand-class-name 'gnus)
 143                     :location number
 144                     :subject (if subject
 145                                  (nnheader-decode-subject subject))
 146                     :from (if from
 147                               (nnheader-decode-from from))
 148                     :date date
 149                     :id id
 150                     :references references
 151                     :chars chars
 152                     :lines lines
 153                     :xref xref
 154                     :original-header (list (cons 'Subject subject)
 155                                            (cons 'From from))
 156                     :extra extra))
 157
 158 (defsubst make-full-mail-header-from-decoded-header
 159   (&optional number subject from date id references chars lines xref extra)
 160   "Create a new mail header structure initialized with the parameters given."
 161   (luna-make-entity (mm-expand-class-name 'gnus)
 162                     :location number
 163                     :subject subject
 164                     :from from
 165                     :date date
 166                     :id id
 167                     :references references
 168                     :chars chars
 169                     :lines lines
 170                     :xref xref
 171                     :extra extra))
 172
 173 (defsubst make-mail-header (&optional init)
 174   "Create a new mail header structure initialized with INIT."
 175   (make-full-mail-header init init init init init
 176                          init init init init init))
 177
 178 ;; fake message-ids: generation and detection
 179
 180 (defvar nnheader-fake-message-id 1)
 181
 182 (defsubst nnheader-generate-fake-message-id ()
 183   (concat "fake+none+" (int-to-string (incf nnheader-fake-message-id))))
 184
 185 (defsubst nnheader-fake-message-id-p (id)
 186   (save-match-data                      ; regular message-id's are <.*>
 187     (string-match "\\`fake\\+none\\+[0-9]+\\'" id)))
 188
 189 ;; Parsing headers and NOV lines.
 190
 191 (defsubst nnheader-header-value ()
 192   (buffer-substring (match-end 0) (gnus-point-at-eol)))
 193
 194 (defun nnheader-parse-head (&optional naked)
 195   (let ((case-fold-search t)
 196         (cur (current-buffer))
 197         (buffer-read-only nil)
 198         in-reply-to lines p ref)
 199     (goto-char (point-min))
 200     (when naked
 201       (insert "\n"))
 202     ;; Search to the beginning of the next header.  Error messages
 203     ;; do not begin with 2 or 3.
 204     (prog1
 205         (when (or naked (re-search-forward "^[23][0-9]+ " nil t))
 206           ;; This implementation of this function, with nine
 207           ;; search-forwards instead of the one re-search-forward and
 208           ;; a case (which basically was the old function) is actually
 209           ;; about twice as fast, even though it looks messier.  You
 210           ;; can't have everything, I guess.  Speed and elegance
 211           ;; don't always go hand in hand.
 212           (make-full-mail-header
 213            ;; Number.
 214            (if naked
 215                (progn
 216                  (setq p (point-min))
 217                  0)
 218              (prog1
 219                  (read cur)
 220                (end-of-line)
 221                (setq p (point))
 222                (narrow-to-region (point)
 223                                  (or (and (search-forward "\n.\n" nil t)
 224                                           (- (point) 2))
 225                                      (point)))))
 226            ;; Subject.
 227            (progn
 228              (goto-char p)
 229              (if (search-forward "\nsubject: " nil t)
 230                  (nnheader-header-value) "(none)"))
 231            ;; From.
 232            (progn
 233              (goto-char p)
 234              (if (search-forward "\nfrom: " nil t)
 235                  (nnheader-header-value) "(nobody)"))
 236            ;; Date.
 237            (progn
 238              (goto-char p)
 239              (if (search-forward "\ndate: " nil t)
 240                  (nnheader-header-value) ""))
 241            ;; Message-ID.
 242            (progn
 243              (goto-char p)
 244              (if (search-forward "\nmessage-id:" nil t)
 245                  (buffer-substring
 246                   (1- (or (search-forward "<" (gnus-point-at-eol) t)
 247                           (point)))
 248                   (or (search-forward ">" (gnus-point-at-eol) t) (point)))
 249                ;; If there was no message-id, we just fake one to make
 250                ;; subsequent routines simpler.
 251                (nnheader-generate-fake-message-id)))
 252            ;; References.
 253            (progn
 254              (goto-char p)
 255              (if (search-forward "\nreferences: " nil t)
 256                  (nnheader-header-value)
 257                ;; Get the references from the in-reply-to header if there
 258                ;; were no references and the in-reply-to header looks
 259                ;; promising.
 260                (if (and (search-forward "\nin-reply-to: " nil t)
 261                         (setq in-reply-to (nnheader-header-value))
 262                         (string-match "<[^\n>]+>" in-reply-to))
 263                    (let (ref2)
 264                      (setq ref (substring in-reply-to (match-beginning 0)
 265                                           (match-end 0)))
 266                      (while (string-match "<[^\n>]+>"
 267                                           in-reply-to (match-end 0))
 268                        (setq ref2 (substring in-reply-to (match-beginning 0)
 269                                              (match-end 0)))
 270                        (when (> (length ref2) (length ref))
 271                          (setq ref ref2)))
 272                      ref)
 273                  nil)))
 274            ;; Chars.
 275            0
 276            ;; Lines.
 277            (progn
 278              (goto-char p)
 279              (if (search-forward "\nlines: " nil t)
 280                  (if (numberp (setq lines (read cur)))
 281                      lines 0)
 282                0))
 283            ;; Xref.
 284            (progn
 285              (goto-char p)
 286              (and (search-forward "\nxref: " nil t)
 287                   (nnheader-header-value)))
 288
 289            ;; Extra.
 290            (when nnmail-extra-headers
 291              (let ((extra nnmail-extra-headers)
 292                    out)
 293                (while extra
 294                  (goto-char p)
 295                  (when (search-forward
 296                         (concat "\n" (symbol-name (car extra)) ": ") nil t)
 297                    (push (cons (car extra) (nnheader-header-value))
 298                          out))
 299                  (pop extra))
 300                out))))
 301       (when naked
 302         (goto-char (point-min))
 303         (delete-char 1)))))
 304
 305 (defmacro nnheader-nov-skip-field ()
 306   '(search-forward "\t" eol 'move))
 307
 308 (defmacro nnheader-nov-field ()
 309   '(buffer-substring (point) (if (nnheader-nov-skip-field) (1- (point)) eol)))
 310
 311 (defmacro nnheader-nov-read-integer ()
 312   '(prog1
 313        (if (eq (char-after) ?\t)
 314            0
 315          (let ((num (condition-case nil
 316                         (read (current-buffer))
 317                       (error nil))))
 318            (if (numberp num) num 0)))
 319      (unless (eobp)
 320        (search-forward "\t" eol 'move))))
 321
 322 (defmacro nnheader-nov-parse-extra ()
 323   '(let (out string)
 324      (while (not (memq (char-after) '(?\n nil)))
 325        (setq string (nnheader-nov-field))
 326        (when (string-match "^\\([^ :]+\\): " string)
 327          (push (cons (intern (match-string 1 string))
 328                      (substring string (match-end 0)))
 329                out)))
 330      out))
 331
 332 (defmacro nnheader-nov-read-message-id ()
 333   '(let ((id (nnheader-nov-field)))
 334      (if (string-match "^<[^>]+>$" id)
 335          id
 336        (nnheader-generate-fake-message-id))))
 337
 338 (defun nnheader-parse-nov ()
 339   (let ((eol (gnus-point-at-eol)))
 340     (make-full-mail-header
 341      (nnheader-nov-read-integer)        ; number
 342      (nnheader-nov-field)               ; subject
 343      (nnheader-nov-field)               ; from
 344      (nnheader-nov-field)               ; date
 345      (nnheader-nov-read-message-id)     ; id
 346      (nnheader-nov-field)               ; refs
 347      (nnheader-nov-read-integer)        ; chars
 348      (nnheader-nov-read-integer)        ; lines
 349      (if (eq (char-after) ?\n)
 350          nil
 351        (if (looking-at "Xref: ")
 352            (goto-char (match-end 0)))
 353        (nnheader-nov-field))            ; Xref
 354      (nnheader-nov-parse-extra))))      ; extra
 355
 356 (defun nnheader-insert-nov (header)
 357   (princ (mail-header-number header) (current-buffer))
 358   (let ((p (point)))
 359     (insert
 360      "\t"
 361      (or (mime-entity-fetch-field header 'Subject) "(none)") "\t"
 362      (or (mime-entity-fetch-field header 'From) "(nobody)") "\t"
 363      (or (mail-header-date header) "") "\t"
 364      (or (mail-header-id header)
 365          (nnmail-message-id))
 366      "\t"
 367      (or (mail-header-references header) "") "\t")
 368     (princ (or (mail-header-chars header) 0) (current-buffer))
 369     (insert "\t")
 370     (princ (or (mail-header-lines header) 0) (current-buffer))
 371     (insert "\t")
 372     (when (mail-header-xref header)
 373       (insert "Xref: " (mail-header-xref header)))
 374     (when (or (mail-header-xref header)
 375               (mail-header-extra header))
 376       (insert "\t"))
 377     (when (mail-header-extra header)
 378       (let ((extra (mail-header-extra header)))
 379         (while extra
 380           (insert (symbol-name (caar extra))
 381                   ": " (cdar extra) "\t")
 382           (pop extra))))
 383     (insert "\n")
 384     (backward-char 1)
 385     (while (search-backward "\n" p t)
 386       (delete-char 1))
 387     (forward-line 1)))
 388
 389 (defun nnheader-insert-header (header)
 390   (insert
 391    "Subject: " (or (mail-header-subject header) "(none)") "\n"
 392    "From: " (or (mail-header-from header) "(nobody)") "\n"
 393    "Date: " (or (mail-header-date header) "") "\n"
 394    "Message-ID: " (or (mail-header-id header) (nnmail-message-id)) "\n"
 395    "References: " (or (mail-header-references header) "") "\n"
 396    "Lines: ")
 397   (princ (or (mail-header-lines header) 0) (current-buffer))
 398   (insert "\n\n"))
 399
 400 (defun nnheader-insert-article-line (article)
 401   (goto-char (point-min))
 402   (insert "220 ")
 403   (princ article (current-buffer))
 404   (insert " Article retrieved.\n")
 405   (search-forward "\n\n" nil 'move)
 406   (delete-region (point) (point-max))
 407   (forward-char -1)
 408   (insert "."))
 409
 410 (defun nnheader-nov-delete-outside-range (beg end)
 411   "Delete all NOV lines that lie outside the BEG to END range."
 412   ;; First we find the first wanted line.
 413   (nnheader-find-nov-line beg)
 414   (delete-region (point-min) (point))
 415   ;; Then we find the last wanted line.
 416   (when (nnheader-find-nov-line end)
 417     (forward-line 1))
 418   (delete-region (point) (point-max)))
 419
 420 (defun nnheader-find-nov-line (article)
 421   "Put point at the NOV line that start with ARTICLE.
 422 If ARTICLE doesn't exist, put point where that line
 423 would have been.  The function will return non-nil if
 424 the line could be found."
 425   ;; This function basically does a binary search.
 426   (let ((max (point-max))
 427         (min (goto-char (point-min)))
 428         (cur (current-buffer))
 429         (prev (point-min))
 430         num found)
 431     (while (not found)
 432       (goto-char (/ (+ max min) 2))
 433       (beginning-of-line)
 434       (if (or (= (point) prev)
 435               (eobp))
 436           (setq found t)
 437         (setq prev (point))
 438         (while (and (not (numberp (setq num (read cur))))
 439                     (not (eobp)))
 440           (gnus-delete-line))
 441         (cond ((> num article)
 442                (setq max (point)))
 443               ((< num article)
 444                (setq min (point)))
 445               (t
 446                (setq found 'yes)))))
 447     ;; We may be at the first line.
 448     (when (and (not num)
 449                (not (eobp)))
 450       (setq num (read cur)))
 451     ;; Now we may have found the article we're looking for, or we
 452     ;; may be somewhere near it.
 453     (when (and (not (eq found 'yes))
 454                (not (eq num article)))
 455       (setq found (point))
 456       (while (and (< (point) max)
 457                   (or (not (numberp num))
 458                       (< num article)))
 459         (forward-line 1)
 460         (setq found (point))
 461         (or (eobp)
 462             (= (setq num (read cur)) article)))
 463       (unless (eq num article)
 464         (goto-char found)))
 465     (beginning-of-line)
 466     (eq num article)))
 467
 468 (defun nnheader-retrieve-headers-from-directory* (articles
 469                                                   directory dependencies
 470                                                   &optional
 471                                                   fetch-old force-new large
 472                                                   backend)
 473   (with-temp-buffer
 474     (let* ((file nil)
 475            (number (length articles))
 476            (count 0)
 477            (file-name-coding-system 'binary)
 478            (pathname-coding-system 'binary)
 479            (case-fold-search t)
 480            (cur (current-buffer))
 481            article
 482            headers header id end ref in-reply-to lines chars ctype)
 483       ;; We don't support fetching by Message-ID.
 484       (if (stringp (car articles))
 485           'headers
 486         (while articles
 487           (when (and (file-exists-p
 488                       (setq file (expand-file-name
 489                                   (int-to-string
 490                                    (setq article (pop articles)))
 491                                   directory)))
 492                      (not (file-directory-p file)))
 493             (erase-buffer)
 494             (nnheader-insert-head file)
 495             (save-restriction
 496               (std11-narrow-to-header)
 497               (setq
 498                header
 499                (make-full-mail-header
 500                 ;; Number.
 501                 article
 502                 ;; Subject.
 503                 (or (std11-fetch-field "Subject")
 504                     "(none)")
 505                 ;; From.
 506                 (or (std11-fetch-field "From")
 507                     "(nobody)")
 508                 ;; Date.
 509                 (or (std11-fetch-field "Date")
 510                     "")
 511                 ;; Message-ID.
 512                 (progn
 513                   (goto-char (point-min))
 514                   (setq id (if (re-search-forward
 515                                 "^Message-ID: *\\(<[^\n\t> ]+>\\)" nil t)
 516                                ;; We do it this way to make sure the Message-ID
 517                                ;; is (somewhat) syntactically valid.
 518                                (buffer-substring (match-beginning 1)
 519                                                  (match-end 1))
 520                              ;; If there was no message-id, we just fake one
 521                              ;; to make subsequent routines simpler.
 522                              (nnheader-generate-fake-message-id))))
 523                 ;; References.
 524                 (progn
 525                   (goto-char (point-min))
 526                   (if (search-forward "\nReferences: " nil t)
 527                       (progn
 528                         (setq end (point))
 529                         (prog1
 530                             (buffer-substring (match-end 0) (std11-field-end))
 531                           (setq ref
 532                                 (buffer-substring
 533                                  (progn
 534                                    ;; (end-of-line)
 535                                    (search-backward ">" end t)
 536                                    (1+ (point)))
 537                                  (progn
 538                                    (search-backward "<" end t)
 539                                    (point))))))
 540                     ;; Get the references from the in-reply-to header if there
 541                     ;; were no references and the in-reply-to header looks
 542                     ;; promising.
 543                     (if (and (search-forward "\nIn-Reply-To: " nil t)
 544                              (setq in-reply-to
 545                                    (buffer-substring (match-end 0)
 546                                                      (std11-field-end)))
 547                              (string-match "<[^>]+>" in-reply-to))
 548                         (let (ref2)
 549                           (setq ref (substring in-reply-to (match-beginning 0)
 550                                                (match-end 0)))
 551                           (while (string-match "<[^>]+>"
 552                                                in-reply-to (match-end 0))
 553                             (setq ref2
 554                                   (substring in-reply-to (match-beginning 0)
 555                                              (match-end 0)))
 556                             (when (> (length ref2) (length ref))
 557                               (setq ref ref2)))
 558                           ref)
 559                       (setq ref nil))))
 560                 ;; Chars.
 561                 (progn
 562                   (goto-char (point-min))
 563                   (if (search-forward "\nChars: " nil t)
 564                       (if (numberp (setq chars (ignore-errors (read cur))))
 565                           chars 0)
 566                     0))
 567                 ;; Lines.
 568                 (progn
 569                   (goto-char (point-min))
 570                   (if (search-forward "\nLines: " nil t)
 571                       (if (numberp (setq lines (ignore-errors (read cur))))
 572                           lines 0)
 573                     0))
 574                 ;; Xref.
 575                 (std11-fetch-field "Xref")
 576                 ))
 577               (goto-char (point-min))
 578               (if (setq ctype (std11-fetch-field "Content-Type"))
 579                   (mime-entity-set-content-type-internal
 580                    header (mime-parse-Content-Type ctype)))
 581               )
 582             (when (setq header
 583                         (gnus-dependencies-add-header
 584                          header dependencies force-new))
 585               (push header headers))
 586             )
 587           (setq count (1+ count))
 588
 589           (and large
 590                (zerop (% count 20))
 591                (nnheader-message 5 "%s: Receiving headers... %d%%"
 592                                  backend
 593                                  (/ (* count 100) number))))
 594
 595         (when large
 596           (nnheader-message 5 "%s: Receiving headers...done" backend))
 597
 598         headers))))
 599
 600 (defun nnheader-retrieve-headers-from-directory (articles
 601                                                  directory dependencies
 602                                                  &optional
 603                                                  fetch-old force-new large
 604                                                  backend)
 605   (cons 'header
 606         (nreverse (nnheader-retrieve-headers-from-directory*
 607                    articles directory dependencies
 608                    fetch-old force-new large backend))))
 609
 610 (defun nnheader-get-newsgroup-headers-xover* (sequence
 611                                               &optional
 612                                               force-new dependencies
 613                                               group)
 614   "Parse the news overview data in the server buffer, and return a
 615 list of headers that match SEQUENCE (see `nntp-retrieve-headers')."
 616   ;; Get the Xref when the users reads the articles since most/some
 617   ;; NNTP servers do not include Xrefs when using XOVER.
 618   ;; (setq gnus-article-internal-prepare-hook '(gnus-article-get-xrefs))
 619   (let ((cur nntp-server-buffer)
 620         number headers header)
 621     (save-excursion
 622       (set-buffer nntp-server-buffer)
 623       ;; Allow the user to mangle the headers before parsing them.
 624       (gnus-run-hooks 'gnus-parse-headers-hook)
 625       (goto-char (point-min))
 626       (while (not (eobp))
 627         (condition-case ()
 628             (while (and sequence (not (eobp)))
 629               (setq number (read cur))
 630               (while (and sequence
 631                           (< (car sequence) number))
 632                 (setq sequence (cdr sequence)))
 633               (and sequence
 634                    (eq number (car sequence))
 635                    (progn
 636                      (setq sequence (cdr sequence))
 637                      (setq header (inline
 638                                     (gnus-nov-parse-line
 639                                      number dependencies force-new))))
 640                    (push header headers))
 641               (forward-line 1))
 642           (error
 643            (gnus-error 4 "Strange nov line (%d)"
 644                        (count-lines (point-min) (point)))))
 645         (forward-line 1))
 646       ;; A common bug in inn is that if you have posted an article and
 647       ;; then retrieves the active file, it will answer correctly --
 648       ;; the new article is included.  However, a NOV entry for the
 649       ;; article may not have been generated yet, so this may fail.
 650       ;; We work around this problem by retrieving the last few
 651       ;; headers using HEAD.
 652       headers)))
 653
 654 ;; Various cruft the backends and Gnus need to communicate.
 655
 656 (defvar nntp-server-buffer nil)
 657 (defvar nntp-process-response nil)
 658 (defvar gnus-verbose-backends 7
 659   "*A number that says how talkative the Gnus backends should be.")
 660 (defvar gnus-nov-is-evil nil
 661   "If non-nil, Gnus backends will never output headers in the NOV format.")
 662 (defvar news-reply-yank-from nil)
 663 (defvar news-reply-yank-message-id nil)
 664
 665 (defvar nnheader-callback-function nil)
 666
 667 (defun nnheader-init-server-buffer ()
 668   "Initialize the Gnus-backend communication buffer."
 669   (save-excursion
 670     (unless (gnus-buffer-live-p nntp-server-buffer)
 671       (setq nntp-server-buffer (get-buffer-create " *nntpd*")))
 672     (set-buffer nntp-server-buffer)
 673     (erase-buffer)
 674     (kill-all-local-variables)
 675     (setq case-fold-search t)           ;Should ignore case.
 676     (set (make-local-variable 'nntp-process-response) nil)
 677     t))
 678
 679 ;;; Various functions the backends use.
 680
 681 (defun nnheader-file-error (file)
 682   "Return a string that says what is wrong with FILE."
 683   (format
 684    (cond
 685     ((not (file-exists-p file))
 686      "%s does not exist")
 687     ((file-directory-p file)
 688      "%s is a directory")
 689     ((not (file-readable-p file))
 690      "%s is not readable"))
 691    file))
 692
 693 (defun nnheader-insert-head (file)
 694   "Insert the head of the article."
 695   (when (file-exists-p file)
 696     (if (eq nnheader-max-head-length t)
 697         ;; Just read the entire file.
 698         (nnheader-insert-file-contents file)
 699       ;; Read 1K blocks until we find a separator.
 700       (let ((beg 0)
 701             format-alist)
 702         (while (and (eq nnheader-head-chop-length
 703                         (nth 1 (nnheader-insert-file-contents
 704                                 file nil beg
 705                                 (incf beg nnheader-head-chop-length))))
 706                     (prog1 (not (search-forward "\n\n" nil t))
 707                       (goto-char (point-max)))
 708                     (or (null nnheader-max-head-length)
 709                         (< beg nnheader-max-head-length))))))
 710     t))
 711
 712 (defun nnheader-article-p ()
 713   "Say whether the current buffer looks like an article."
 714   (goto-char (point-min))
 715   (if (not (search-forward "\n\n" nil t))
 716       nil
 717     (narrow-to-region (point-min) (1- (point)))
 718     (goto-char (point-min))
 719     (while (looking-at "[a-zA-Z][^ \t]+:.*\n\\([ \t].*\n\\)*\\|From .*\n")
 720       (goto-char (match-end 0)))
 721     (prog1
 722         (eobp)
 723       (widen))))
 724
 725 (defun nnheader-insert-references (references message-id)
 726   "Insert a References header based on REFERENCES and MESSAGE-ID."
 727   (if (and (not references) (not message-id))
 728       ;; This is invalid, but not all articles have Message-IDs.
 729       ()
 730     (mail-position-on-field "References")
 731     (let ((begin (save-excursion (beginning-of-line) (point)))
 732           (fill-column 78)
 733           (fill-prefix "\t"))
 734       (when references
 735         (insert references))
 736       (when (and references message-id)
 737         (insert " "))
 738       (when message-id
 739         (insert message-id))
 740       ;; Fold long References lines to conform to RFC1036 (sort of).
 741       ;; The region must end with a newline to fill the region
 742       ;; without inserting extra newline.
 743       (fill-region-as-paragraph begin (1+ (point))))))
 744
 745 (defun nnheader-replace-header (header new-value)
 746   "Remove HEADER and insert the NEW-VALUE."
 747   (save-excursion
 748     (save-restriction
 749       (nnheader-narrow-to-headers)
 750       (prog1
 751           (message-remove-header header)
 752         (goto-char (point-max))
 753         (insert header ": " new-value "\n")))))
 754
 755 (defun nnheader-narrow-to-headers ()
 756   "Narrow to the head of an article."
 757   (widen)
 758   (narrow-to-region
 759    (goto-char (point-min))
 760    (if (search-forward "\n\n" nil t)
 761        (1- (point))
 762      (point-max)))
 763   (goto-char (point-min)))
 764
 765 (defun nnheader-set-temp-buffer (name &optional noerase)
 766   "Set-buffer to an empty (possibly new) buffer called NAME with undo disabled."
 767   (set-buffer (get-buffer-create name))
 768   (buffer-disable-undo)
 769   (unless noerase
 770     (erase-buffer))
 771   (current-buffer))
 772
 773 (eval-when-compile (defvar jka-compr-compression-info-list))
 774 (defvar nnheader-numerical-files
 775   (if (boundp 'jka-compr-compression-info-list)
 776       (concat "\\([0-9]+\\)\\("
 777               (mapconcat (lambda (i) (aref i 0))
 778                          jka-compr-compression-info-list "\\|")
 779               "\\)?")
 780     "[0-9]+$")
 781   "Regexp that match numerical files.")
 782
 783 (defvar nnheader-numerical-short-files (concat "^" nnheader-numerical-files)
 784   "Regexp that matches numerical file names.")
 785
 786 (defvar nnheader-numerical-full-files (concat "/" nnheader-numerical-files)
 787   "Regexp that matches numerical full file paths.")
 788
 789 (defsubst nnheader-file-to-number (file)
 790   "Take a FILE name and return the article number."
 791   (if (string= nnheader-numerical-short-files "^[0-9]+$")
 792       (string-to-int file)
 793     (string-match nnheader-numerical-short-files file)
 794     (string-to-int (match-string 0 file))))
 795
 796 (defun nnheader-directory-files-safe (&rest args)
 797   ;; It has been reported numerous times that `directory-files'
 798   ;; fails with an alarming frequency on NFS mounted file systems.
 799   ;; This function executes that function twice and returns
 800   ;; the longest result.
 801   (let ((first (apply 'directory-files args))
 802         (second (apply 'directory-files args)))
 803     (if (> (length first) (length second))
 804         first
 805       second)))
 806
 807 (defun nnheader-directory-articles (dir)
 808   "Return a list of all article files in directory DIR."
 809   (mapcar 'nnheader-file-to-number
 810           (nnheader-directory-files-safe
 811            dir nil nnheader-numerical-short-files t)))
 812
 813 (defun nnheader-article-to-file-alist (dir)
 814   "Return an alist of article/file pairs in DIR."
 815   (mapcar (lambda (file) (cons (nnheader-file-to-number file) file))
 816           (nnheader-directory-files-safe
 817            dir nil nnheader-numerical-short-files t)))
 818
 819 (defun nnheader-fold-continuation-lines ()
 820   "Fold continuation lines in the current buffer."
 821   (nnheader-replace-regexp "\\(\r?\n[ \t]+\\)+" " "))
 822
 823 (defun nnheader-translate-file-chars (file &optional full)
 824   "Translate FILE into something that can be a file name.
 825 If FULL, translate everything."
 826   (if (null nnheader-file-name-translation-alist)
 827       ;; No translation is necessary.
 828       file
 829     (let* ((i 0)
 830            trans leaf path len)
 831       (if full
 832           ;; Do complete translation.
 833           (setq leaf (copy-sequence file)
 834                 path ""
 835                 i (if (and (< 1 (length leaf)) (eq ?: (aref leaf 1)))
 836                       2 0))
 837         ;; We translate -- but only the file name.  We leave the directory
 838         ;; alone.
 839         (if (memq system-type '(win32 w32 mswindows windows-nt))
 840             ;; This is needed on NT and stuff, because
 841             ;; file-name-nondirectory is not enough to split
 842             ;; file names, containing ':', e.g.
 843             ;; "d:\\Work\\News\\nntp+news.fido7.ru:fido7.ru.gnu.SCORE"
 844             ;;
 845             ;; we are trying to correctly split such names:
 846             ;; "d:file.name" -> "a:" "file.name"
 847             ;; "aaa:bbb.ccc" -> "" "aaa:bbb.ccc"
 848             ;; "d:aaa\\bbb:ccc"   -> "d:aaa\\" "bbb:ccc"
 849             ;; etc.
 850             ;; to translate then only the file name part.
 851             (progn
 852               (setq leaf file
 853                     path "")
 854               (if (string-match "\\(^\\w:\\|[/\\]\\)\\([^/\\]+\\)$" file)
 855                   (setq leaf (substring file (match-beginning 2))
 856                         path (substring file 0 (match-beginning 2)))))
 857           ;; Fall back on this.
 858           (setq leaf (file-name-nondirectory file)
 859                 path (file-name-directory file))))
 860       (setq len (length leaf))
 861       (while (< i len)
 862         (when (setq trans (cdr (assq (aref leaf i)
 863                                      nnheader-file-name-translation-alist)))
 864           (aset leaf i trans))
 865         (incf i))
 866       (concat path leaf))))
 867
 868 (defun nnheader-report (backend &rest args)
 869   "Report an error from the BACKEND.
 870 The first string in ARGS can be a format string."
 871   (set (intern (format "%s-status-string" backend))
 872        (if (< (length args) 2)
 873            (car args)
 874          (apply 'format args)))
 875   nil)
 876
 877 (defun nnheader-get-report (backend)
 878   "Get the most recent report from BACKEND."
 879   (condition-case ()
 880       (nnheader-message 5 "%s" (symbol-value (intern (format "%s-status-string"
 881                                                              backend))))
 882     (error (nnheader-message 5 ""))))
 883
 884 (defun nnheader-insert (format &rest args)
 885   "Clear the communication buffer and insert FORMAT and ARGS into the buffer.
 886 If FORMAT isn't a format string, it and all ARGS will be inserted
 887 without formatting."
 888   (save-excursion
 889     (set-buffer nntp-server-buffer)
 890     (erase-buffer)
 891     (if (string-match "%" format)
 892         (insert (apply 'format format args))
 893       (apply 'insert format args))
 894     t))
 895
 896 (static-if (fboundp 'subst-char-in-string)
 897     (defsubst nnheader-replace-chars-in-string (string from to)
 898       (subst-char-in-string from to string))
 899   (defun nnheader-replace-chars-in-string (string from to)
 900     "Replace characters in STRING from FROM to TO."
 901     (let ((string (substring string 0)) ;Copy string.
 902           (len (length string))
 903           (idx 0))
 904       ;; Replace all occurrences of FROM with TO.
 905       (while (< idx len)
 906         (when (= (aref string idx) from)
 907           (aset string idx to))
 908         (setq idx (1+ idx)))
 909       string)))
 910
 911 (defun nnheader-replace-duplicate-chars-in-string (string from to)
 912   "Replace characters in STRING from FROM to TO."
 913   (let ((string (substring string 0))   ;Copy string.
 914         (len (length string))
 915         (idx 0) prev i)
 916     ;; Replace all occurrences of FROM with TO.
 917     (while (< idx len)
 918       (setq i (aref string idx))
 919       (when (and (eq prev from) (= i from))
 920         (aset string (1- idx) to)
 921         (aset string idx to))
 922       (setq prev i)
 923       (setq idx (1+ idx)))
 924     string))
 925
 926 (defun nnheader-file-to-group (file &optional top)
 927   "Return a group name based on FILE and TOP."
 928   (nnheader-replace-chars-in-string
 929    (if (not top)
 930        file
 931      (condition-case ()
 932          (substring (expand-file-name file)
 933                     (length
 934                      (expand-file-name
 935                       (file-name-as-directory top))))
 936        (error "")))
 937    ?/ ?.))
 938
 939 (defun nnheader-message (level &rest args)
 940   "Message if the Gnus backends are talkative."
 941   (if (or (not (numberp gnus-verbose-backends))
 942           (<= level gnus-verbose-backends))
 943       (apply 'message args)
 944     (apply 'format args)))
 945
 946 (defun nnheader-be-verbose (level)
 947   "Return whether the backends should be verbose on LEVEL."
 948   (or (not (numberp gnus-verbose-backends))
 949       (<= level gnus-verbose-backends)))
 950
 951 (defvar nnheader-pathname-coding-system 'binary
 952   "*Coding system for pathname.")
 953
 954 (defun nnheader-group-pathname (group dir &optional file)
 955   "Make pathname for GROUP."
 956   (concat
 957    (let ((dir (file-name-as-directory (expand-file-name dir))))
 958      ;; If this directory exists, we use it directly.
 959      (file-name-as-directory
 960       (if (file-directory-p (concat dir group))
 961           (expand-file-name group dir)
 962         ;; If not, we translate dots into slashes.
 963         (expand-file-name (encode-coding-string
 964                            (nnheader-replace-chars-in-string group ?. ?/)
 965                            nnheader-pathname-coding-system)
 966                           dir))))
 967    (cond ((null file) "")
 968          ((numberp file) (int-to-string file))
 969          (t file))))
 970
 971 (defun nnheader-functionp (form)
 972   "Return non-nil if FORM is funcallable."
 973   (or (and (symbolp form) (fboundp form))
 974       (and (listp form) (eq (car form) 'lambda))))
 975
 976 (defun nnheader-concat (dir &rest files)
 977   "Concat DIR as directory to FILES."
 978   (apply 'concat (file-name-as-directory dir) files))
 979
 980 (defun nnheader-ms-strip-cr ()
 981   "Strip ^M from the end of all lines."
 982   (save-excursion
 983     (goto-char (point-min))
 984     (while (re-search-forward "\r$" nil t)
 985       (delete-backward-char 1))))
 986
 987 (defun nnheader-file-size (file)
 988   "Return the file size of FILE or 0."
 989   (or (nth 7 (file-attributes file)) 0))
 990
 991 (defun nnheader-find-etc-directory (package &optional file)
 992   "Go through the path and find the \".../etc/PACKAGE\" directory.
 993 If FILE, find the \".../etc/PACKAGE\" file instead."
 994   (let ((path load-path)
 995         dir result)
 996     ;; We try to find the dir by looking at the load path,
 997     ;; stripping away the last component and adding "etc/".
 998     (while path
 999       (if (and (car path)
1000                (file-exists-p
1001                 (setq dir (concat
1002                            (file-name-directory
1003                             (directory-file-name (car path)))
1004                            "etc/" package
1005                            (if file "" "/"))))
1006                (or file (file-directory-p dir)))
1007           (setq result dir
1008                 path nil)
1009         (setq path (cdr path))))
1010     result))
1011
1012 (defvar ange-ftp-path-format)
1013 (defvar efs-path-regexp)
1014 (defun nnheader-re-read-dir (path)
1015   "Re-read directory PATH if PATH is on a remote system."
1016   (if (and (fboundp 'efs-re-read-dir) (boundp 'efs-path-regexp))
1017       (when (string-match efs-path-regexp path)
1018         (efs-re-read-dir path))
1019     (when (and (fboundp 'ange-ftp-re-read-dir) (boundp 'ange-ftp-path-format))
1020       (when (string-match (car ange-ftp-path-format) path)
1021         (ange-ftp-re-read-dir path)))))
1022
1023 (defvar nnheader-file-coding-system 'raw-text
1024   "Coding system used in file backends of Gnus.")
1025
1026 (defun nnheader-insert-file-contents (filename &optional visit beg end replace)
1027   "Like `insert-file-contents', q.v., but only reads in the file.
1028 A buffer may be modified in several ways after reading into the buffer due
1029 to advanced Emacs features, such as file-name-handlers, format decoding,
1030 find-file-hooks, etc.
1031   This function ensures that none of these modifications will take place."
1032   (let ((format-alist nil)
1033         (auto-mode-alist (nnheader-auto-mode-alist))
1034         (default-major-mode 'fundamental-mode)
1035         (enable-local-variables nil)
1036         (after-insert-file-functions nil)
1037         (enable-local-eval nil)
1038         (find-file-hooks nil))
1039     (insert-file-contents-as-coding-system
1040      nnheader-file-coding-system filename visit beg end replace)))
1041
1042 (defun nnheader-find-file-noselect (&rest args)
1043   (let ((format-alist nil)
1044         (auto-mode-alist (nnheader-auto-mode-alist))
1045         (default-major-mode 'fundamental-mode)
1046         (enable-local-variables nil)
1047         (after-insert-file-functions nil)
1048         (enable-local-eval nil)
1049         (find-file-hooks nil))
1050     (apply 'find-file-noselect-as-coding-system
1051            nnheader-file-coding-system args)))
1052
1053 (defun nnheader-auto-mode-alist ()
1054   "Return an `auto-mode-alist' with only the .gz (etc) thingies."
1055   (let ((alist auto-mode-alist)
1056         out)
1057     (while alist
1058       (when (listp (cdar alist))
1059         (push (car alist) out))
1060       (pop alist))
1061     (nreverse out)))
1062
1063 (defun nnheader-directory-regular-files (dir)
1064   "Return a list of all regular files in DIR."
1065   (let ((files (directory-files dir t))
1066         out)
1067     (while files
1068       (when (file-regular-p (car files))
1069         (push (car files) out))
1070       (pop files))
1071     (nreverse out)))
1072
1073 (defun nnheader-directory-files (&rest args)
1074   "Same as `directory-files', but prune \".\" and \"..\"."
1075   (let ((files (apply 'directory-files args))
1076         out)
1077     (while files
1078       (unless (member (file-name-nondirectory (car files)) '("." ".."))
1079         (push (car files) out))
1080       (pop files))
1081     (nreverse out)))
1082
1083 (defmacro nnheader-skeleton-replace (from &optional to regexp)
1084   `(let ((new (generate-new-buffer " *nnheader replace*"))
1085          (cur (current-buffer))
1086          (start (point-min)))
1087      (set-buffer cur)
1088      (goto-char (point-min))
1089      (while (,(if regexp 're-search-forward 'search-forward)
1090              ,from nil t)
1091        (insert-buffer-substring
1092         cur start (prog1 (match-beginning 0) (set-buffer new)))
1093        (goto-char (point-max))
1094        ,(when to `(insert ,to))
1095        (set-buffer cur)
1096        (setq start (point)))
1097      (insert-buffer-substring
1098       cur start (prog1 (point-max) (set-buffer new)))
1099      (copy-to-buffer cur (point-min) (point-max))
1100      (kill-buffer (current-buffer))
1101      (set-buffer cur)))
1102
1103 (defun nnheader-replace-string (from to)
1104   "Do a fast replacement of FROM to TO from point to `point-max'."
1105   (nnheader-skeleton-replace from to))
1106
1107 (defun nnheader-replace-regexp (from to)
1108   "Do a fast regexp replacement of FROM to TO from point to `point-max'."
1109   (nnheader-skeleton-replace from to t))
1110
1111 (defun nnheader-strip-cr ()
1112   "Strip all \r's from the current buffer."
1113   (nnheader-skeleton-replace "\r"))
1114
1115 (defalias 'nnheader-run-at-time 'run-at-time)
1116 (defalias 'nnheader-cancel-timer 'cancel-timer)
1117 (defalias 'nnheader-cancel-function-timers 'cancel-function-timers)
1118
1119 (defun nnheader-Y-or-n-p (prompt)
1120   "Ask user a \"Y/n\" question. Return t if answer is neither \"n\", \"N\" nor \"C-g\"."
1121   (let ((cursor-in-echo-area t)
1122         (echo-keystrokes 0)
1123         (inhibit-quit t)
1124         ans)
1125     (let (message-log-max)
1126       (while (not (memq ans '(?\  ?N ?Y ?\C-g ?\e ?\n ?\r ?n ?y)))
1127         (message "%s(Y/n) " prompt)
1128         (setq ans (read-char-exclusive))))
1129     (if (memq ans '(?\C-g ?N ?n))
1130         (progn
1131           (message "%s(Y/n) No" prompt)
1132           nil)
1133       (message "%s(Y/n) Yes" prompt)
1134       t)))
1135
1136 (when (string-match "XEmacs" emacs-version)
1137   (require 'nnheaderxm))
1138
1139 (run-hooks 'nnheader-load-hook)
1140
1141 (provide 'nnheader)
1142
1143 ;;; nnheader.el ends here