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