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

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