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