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,
   4 ;;   1995, 1996, 1997, 1998, 2000, 2001, 2002, 2003,
   5 ;;   2004, 2005 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., 51 Franklin Street, Fifth Floor,
  28 ;; Boston, MA 02110-1301, USA.
  29
  30 ;;; Commentary:
  31
  32 ;;; Code:
  33
  34 (eval-when-compile (require 'cl))
  35 (eval-when-compile (require 'static))
  36
  37 (defvar nnmail-extra-headers)
  38
  39 ;; Requiring `gnus-util' at compile time creates a circular
  40 ;; dependency between nnheader.el and gnus-util.el.
  41 ;;(eval-when-compile (require 'gnus-util))
  42
  43 (require 'mail-utils)
  44 (require 'gnus-util)
  45
  46 ;; Reduce the required value of `recursive-load-depth-limit' for Emacs 21.
  47 (require 'pces)
  48 (require 'poem)
  49 (require 'std11)
  50
  51 (require 'mime)
  52 (eval-and-compile
  53   (autoload 'gnus-sorted-intersection "gnus-range")
  54   (autoload 'gnus-intersection "gnus-range")
  55   (autoload 'gnus-sorted-complement "gnus-range")
  56   (autoload 'gnus-sorted-difference "gnus-range"))
  57
  58 (defcustom gnus-verbose-backends 7
  59   "Integer that says how verbose the Gnus backends should be.
  60 The higher the number, the more messages the Gnus backends will flash
  61 to say what it's doing.  At zero, the Gnus backends will be totally
  62 mute; at five, they will display most important messages; and at ten,
  63 they will keep on jabbering all the time."
  64   :group 'gnus-start
  65   :type 'integer)
  66
  67 (defcustom gnus-nov-is-evil nil
  68   "If non-nil, Gnus backends will never output headers in the NOV format."
  69   :group 'gnus-server
  70   :type 'boolean)
  71
  72 (defvar nnheader-max-head-length 8192
  73   "*Max length of the head of articles.
  74
  75 Value is an integer, nil, or t.  nil means read in chunks of a file
  76 indefinitely until a complete head is found\; t means always read the
  77 entire file immediately, disregarding `nnheader-head-chop-length'.
  78
  79 Integer values will in effect be rounded up to the nearest multiple of
  80 `nnheader-head-chop-length'.")
  81
  82 (defvar nnheader-head-chop-length 2048
  83   "*Length of each read operation when trying to fetch HEAD headers.")
  84
  85 (defvar nnheader-read-timeout
  86   (if (string-match "windows-nt\\|os/2\\|emx\\|cygwin"
  87                     (symbol-name system-type))
  88       ;; http://thread.gmane.org/v9655t3pjo.fsf@marauder.physik.uni-ulm.de
  89       ;;
  90       ;; IIRC, values lower than 1.0 didn't/don't work on Windows/DOS.
  91       ;;
  92       ;; There should probably be a runtime test to determine the timing
  93       ;; resolution, or a primitive to report it.  I don't know off-hand
  94       ;; what's possible.  Perhaps better, maybe the Windows/DOS primitive
  95       ;; could round up non-zero timeouts to a minimum of 1.0?
  96       1.0
  97     0.1)
  98   "How long nntp should wait between checking for the end of output.
  99 Shorter values mean quicker response, but are more CPU intensive.")
 100
 101 (defvar nnheader-file-name-translation-alist
 102   (let ((case-fold-search t))
 103     (cond
 104      ((string-match "windows-nt\\|os/2\\|emx\\|cygwin"
 105                     (symbol-name system-type))
 106       (append (mapcar (lambda (c) (cons c ?_))
 107                       '(?: ?* ?\" ?< ?> ??))
 108               (if (string-match "windows-nt\\|cygwin"
 109                                 (symbol-name system-type))
 110                   nil
 111                 '((?+ . ?-)))))
 112      (t nil)))
 113   "*Alist that says how to translate characters in file names.
 114 For instance, if \":\" is invalid as a file character in file names
 115 on your system, you could say something like:
 116
 117 \(setq nnheader-file-name-translation-alist '((?: . ?_)))")
 118
 119 (defvar nnheader-text-coding-system
 120   (if (memq system-type '(windows-nt ms-dos ms-windows))
 121       'raw-text-dos
 122     'raw-text)
 123   "Text-safe coding system (For removing ^M).
 124 This variable is a substitute for `mm-text-coding-system'.")
 125
 126 (defvar nnheader-text-coding-system-for-write nil
 127   "Text coding system for write.
 128 This variable is a substitute for `mm-text-coding-system-for-write'.")
 129
 130 (defvar nnheader-auto-save-coding-system
 131   (cond
 132    ((not (fboundp 'find-coding-system)) nil)
 133    ((find-coding-system 'emacs-mule)
 134     (if (memq system-type '(windows-nt ms-dos ms-windows))
 135         'emacs-mule-dos 'emacs-mule))
 136    ((find-coding-system 'escape-quoted) 'escape-quoted)
 137    ((find-coding-system 'no-conversion) 'no-conversion)
 138    (t nil))
 139   "Coding system of auto save file.")
 140
 141 (defvar nnheader-directory-separator-character
 142   (string-to-char (substring (file-name-as-directory ".") -1))
 143   "*A character used to a directory separator.")
 144
 145 (eval-and-compile
 146   (autoload 'nnmail-message-id "nnmail")
 147   (autoload 'mail-position-on-field "sendmail")
 148   (autoload 'message-remove-header "message")
 149   (autoload 'gnus-buffer-live-p "gnus-util"))
 150
 151 ;; mm-util stuff.
 152 (defvar mm-emacs-mule t "True in Emacs with Mule.")
 153
 154 (unless (featurep 'mm-util)
 155   ;; Should keep track of `mm-image-load-path' in mm-util.el.
 156   (defun nnheader-image-load-path (&optional package)
 157     (let (dir result)
 158       (dolist (path load-path (nreverse result))
 159         (if (file-directory-p
 160              (setq dir (concat (file-name-directory
 161                                 (directory-file-name path))
 162                                "etc/" (or package "gnus/"))))
 163             (push dir result))
 164         (push path result))))
 165   (defalias 'mm-image-load-path 'nnheader-image-load-path)
 166
 167   ;; Should keep track of `mm-read-coding-system' in mm-util.el.
 168   (defalias 'mm-read-coding-system 'read-coding-system)
 169
 170   ;; Should keep track of `mm-%s' in mm-util.el.
 171   (defalias 'mm-multibyte-string-p
 172     (if (fboundp 'multibyte-string-p)
 173         'multibyte-string-p
 174       'ignore))
 175   (defalias 'mm-encode-coding-string 'encode-coding-string)
 176   (defalias 'mm-decode-coding-string 'decode-coding-string)
 177   (defalias 'mm-encode-coding-region 'encode-coding-region)
 178   (defalias 'mm-decode-coding-region 'decode-coding-region)
 179   (defalias 'mm-set-buffer-file-coding-system 'set-buffer-file-coding-system)
 180
 181   ;; Should keep track of `mm-detect-coding-region' in mm-util.el.
 182   (defun nnheader-detect-coding-region (start end)
 183     "Like 'detect-coding-region' except returning the best one."
 184     (let ((coding-systems (detect-coding-region (point) (point-max))))
 185       (or (car-safe coding-systems)
 186           coding-systems)))
 187   (defalias 'mm-detect-coding-region 'nnheader-detect-coding-region)
 188
 189   ;; Should keep track of `mm-detect-mime-charset-region' in mm-util.el.
 190   (defun nnheader-detect-mime-charset-region (start end)
 191     "Detect MIME charset of the text in the region between START and END."
 192     (coding-system-to-mime-charset
 193      (nnheader-detect-coding-region start end)))
 194   (defalias 'mm-detect-mime-charset-region
 195     'nnheader-detect-mime-charset-region)
 196
 197   ;; Should keep track of `mm-with-unibyte-buffer' in mm-util.el.
 198   (defmacro nnheader-with-unibyte-buffer (&rest forms)
 199     "Create a temporary buffer, and evaluate FORMS there like `progn'.
 200 Use unibyte mode for this."
 201     `(let (default-enable-multibyte-characters)
 202        (with-temp-buffer ,@forms)))
 203   (put 'nnheader-with-unibyte-buffer 'lisp-indent-function 0)
 204   (put 'nnheader-with-unibyte-buffer 'edebug-form-spec '(body))
 205   (put 'mm-with-unibyte-buffer 'lisp-indent-function 0)
 206   (put 'mm-with-unibyte-buffer 'edebug-form-spec '(body))
 207   (defalias 'mm-with-unibyte-buffer 'nnheader-with-unibyte-buffer)
 208
 209   ;; Should keep track of `mm-with-multibyte-buffer' in mm-util.el.
 210   (defmacro nnheader-with-multibyte-buffer (&rest forms)
 211     "Create a temporary buffer, and evaluate FORMS there like `progn'.
 212 Use multibyte mode for this."
 213     `(let ((default-enable-multibyte-characters t))
 214        (with-temp-buffer ,@forms)))
 215   (put 'nnheader-with-multibyte-buffer 'lisp-indent-function 0)
 216   (put 'nnheader-with-multibyte-buffer 'edebug-form-spec '(body))
 217   (put 'mm-with-multibyte-buffer 'lisp-indent-function 0)
 218   (put 'mm-with-multibyte-buffer 'edebug-form-spec '(body))
 219   (defalias 'mm-with-multibyte-buffer 'nnheader-with-multibyte-buffer)
 220
 221   ;; Should keep track of `mm-with-unibyte-current-buffer' in mm-util.el.
 222   (defmacro nnheader-with-unibyte-current-buffer (&rest forms)
 223     "Evaluate FORMS with current current buffer temporarily made unibyte.
 224 Also bind `default-enable-multibyte-characters' to nil.
 225 Equivalent to `progn' in XEmacs"
 226     (let ((multibyte (make-symbol "multibyte"))
 227           (buffer (make-symbol "buffer")))
 228       (cond ((featurep 'xemacs)
 229              `(let (default-enable-multibyte-characters)
 230                 ,@forms))
 231             (t
 232              `(let ((,multibyte enable-multibyte-characters)
 233                     (,buffer (current-buffer)))
 234                 (unwind-protect
 235                     (let (default-enable-multibyte-characters)
 236                       (set-buffer-multibyte nil)
 237                       ,@forms)
 238                   (set-buffer ,buffer)
 239                   (set-buffer-multibyte ,multibyte)))))))
 240   (put 'nnheader-with-unibyte-current-buffer 'lisp-indent-function 0)
 241   (put 'nnheader-with-unibyte-current-buffer 'edebug-form-spec '(body))
 242   (put 'mm-with-unibyte-current-buffer 'lisp-indent-function 0)
 243   (put 'mm-with-unibyte-current-buffer 'edebug-form-spec '(body))
 244   (defalias 'mm-with-unibyte-current-buffer
 245     'nnheader-with-unibyte-current-buffer)
 246
 247   ;; Should keep track of `mm-with-unibyte' in mm-util.el.
 248   (defmacro nnheader-with-unibyte (&rest forms)
 249     "Eval the FORMS with the default value of `enable-multibyte-characters'
 250 nil, ."
 251     `(let (default-enable-multibyte-characters)
 252        ,@forms))
 253   (put 'nnheader-with-unibyte 'lisp-indent-function 0)
 254   (put 'nnheader-with-unibyte 'edebug-form-spec '(body))
 255   (put 'mm-with-unibyte 'lisp-indent-function 0)
 256   (put 'mm-with-unibyte 'edebug-form-spec '(body))
 257   (defalias 'mm-with-unibyte 'nnheader-with-unibyte)
 258
 259   ;; Should keep track of `mm-guess-mime-charset' in mm-util.el.
 260   (defun nnheader-guess-mime-charset ()
 261     "Guess the default MIME charset from the language environment."
 262     (let ((language-info
 263            (and (boundp 'current-language-environment)
 264                 (assoc current-language-environment
 265                        language-info-alist)))
 266           item)
 267       (cond
 268        ((null language-info)
 269         'iso-8859-1)
 270        ((setq item
 271               (cadr
 272                (or (assq 'coding-priority language-info)
 273                    (assq 'coding-system language-info))))
 274         (if (fboundp 'coding-system-get)
 275             (or (coding-system-get item 'mime-charset)
 276                 item)
 277           item))
 278        ((setq item (car (last (assq 'charset language-info))))
 279         (if (eq item 'ascii)
 280             'iso-8859-1
 281           (charsets-to-mime-charset (list item))))
 282        (t
 283         'iso-8859-1))))
 284   (defalias 'mm-guess-mime-charset 'nnheader-guess-mime-charset)
 285
 286   (defalias 'mm-char-int 'char-int)
 287
 288   ;; Should keep track of the same alias in mm-util.el.
 289   (defalias 'mm-multibyte-p
 290     (static-cond ((and (featurep 'xemacs) (featurep 'mule))
 291                   (lambda nil t))
 292                  ((featurep 'xemacs)
 293                   (lambda nil nil))
 294                  (t
 295                   (lambda nil enable-multibyte-characters))))
 296
 297   ;; Should keep track of the same alias in mm-util.el.
 298   (defalias 'mm-make-temp-file
 299     (if (fboundp 'make-temp-file)
 300         'make-temp-file
 301       (lambda (prefix &optional dir-flag)
 302         (let ((file (expand-file-name
 303                      (make-temp-name prefix)
 304                      (if (fboundp 'temp-directory)
 305                          (temp-directory)
 306                        temporary-file-directory))))
 307           (if dir-flag
 308               (make-directory file))
 309           file))))
 310
 311   ;; Should keep track of `mm-coding-system-p' in mm-util.el.
 312   (defun nnheader-coding-system-p (sym)
 313     "Return non-nil if SYM is a coding system."
 314     (or (and (fboundp 'find-coding-system) (find-coding-system sym))
 315         (and (fboundp 'coding-system-p) (coding-system-p sym))))
 316   (defalias 'mm-coding-system-p 'nnheader-coding-system-p)
 317
 318   (defalias 'mm-disable-multibyte
 319     (static-if (featurep 'xemacs)
 320         'ignore
 321       (lambda nil (set-buffer-multibyte nil))))
 322   (defalias 'mm-enable-multibyte
 323     (static-if (featurep 'xemacs)
 324         'ignore
 325       ;; Why isn't it t but `to'?  See mm-util.el.
 326       (lambda nil (set-buffer-multibyte 'to))))
 327
 328   (defalias 'mm-encode-coding-region 'encode-coding-region)
 329
 330   (defalias 'mm-string-make-unibyte
 331     (if (fboundp 'string-make-unibyte)
 332         'string-make-unibyte
 333       'identity))
 334
 335   (defalias 'mm-char-or-char-int-p
 336     (cond
 337      ((fboundp 'char-or-char-int-p) 'char-or-char-int-p)
 338      ((fboundp 'char-valid-p) 'char-valid-p)
 339      (t 'identity)))
 340
 341   ;; Should keep track of the same function in mm-util.el.
 342   (if (fboundp 'delete-dups)
 343       (defalias 'mm-delete-duplicates 'delete-dups)
 344     (defun mm-delete-duplicates (list)
 345       "Destructively remove `equal' duplicates from LIST.
 346 Store the result in LIST and return it.  LIST must be a proper list.
 347 Of several `equal' occurrences of an element in LIST, the first
 348 one is kept.
 349
 350 This is a compatibility function for Emacsen without `delete-dups'."
 351       ;; Code from `subr.el' in Emacs 22:
 352       (let ((tail list))
 353         (while tail
 354           (setcdr tail (delete (car tail) (cdr tail)))
 355           (setq tail (cdr tail))))
 356       list)))
 357
 358 ;; mail-parse stuff.
 359 (unless (featurep 'mail-parse)
 360   (unless (fboundp 'std11-narrow-to-field)
 361     (defalias 'std11-narrow-to-field
 362       ;; Should keep track of `rfc2047-narrow-to-field' in rfc2047.el.
 363       (lambda ()
 364         "Narrow the buffer to the header on the current line."
 365         (forward-line 0)
 366         (narrow-to-region (point)
 367                           (progn
 368                             (std11-field-end)
 369                             (when (eolp) (forward-line 1))
 370                             (point)))
 371         (goto-char (point-min)))))
 372   (defalias 'mail-header-narrow-to-field 'std11-narrow-to-field)
 373
 374   ;; Should keep track of `ietf-drums-narrow-to-header' in ietf-drums.el.
 375   (defun mail-narrow-to-head ()
 376     "Narrow to the header section in the current buffer."
 377     (narrow-to-region
 378      (goto-char (point-min))
 379      (if (re-search-forward "^\r?$" nil 1)
 380          (match-beginning 0)
 381        (point-max)))
 382     (goto-char (point-min)))
 383
 384   (unless (fboundp 'std11-fold-region)
 385     (defalias 'std11-fold-region
 386       ;; Should keep track of `rfc2047-fold-region' in rfc2047.el.
 387       (lambda (b e)
 388         "Fold long lines in region B to E."
 389         (save-restriction
 390           (narrow-to-region b e)
 391           (goto-char (point-min))
 392           (let ((break nil)
 393                 (qword-break nil)
 394                 (first t)
 395                 (bol (save-restriction
 396                        (widen)
 397                        (point-at-bol))))
 398             (while (not (eobp))
 399               (when (and (or break qword-break)
 400                          (> (- (point) bol) 76))
 401                 (goto-char (or break qword-break))
 402                 (setq break nil
 403                       qword-break nil)
 404                 (if (looking-at "[ \t]")
 405                     (insert "\n")
 406                   (insert "\n "))
 407                 (setq bol (1- (point)))
 408                 ;; Don't break before the first non-LWSP characters.
 409                 (skip-chars-forward " \t")
 410                 (unless (eobp)
 411                   (forward-char 1)))
 412               (cond
 413                ((eq (char-after) ?\n)
 414                 (forward-char 1)
 415                 (setq bol (point)
 416                       break nil
 417                       qword-break nil)
 418                 (skip-chars-forward " \t")
 419                 (unless (or (eobp) (eq (char-after) ?\n))
 420                   (forward-char 1)))
 421                ((eq (char-after) ?\r)
 422                 (forward-char 1))
 423                ((memq (char-after) '(?  ?\t))
 424                 (skip-chars-forward " \t")
 425                 (if first
 426                     ;; Don't break just after the header name.
 427                     (setq first nil)
 428                   (setq break (1- (point)))))
 429                ((not break)
 430                 (if (not (looking-at "=\\?[^=]"))
 431                     (if (eq (char-after) ?=)
 432                         (forward-char 1)
 433                       (skip-chars-forward "^ \t\n\r="))
 434                   (setq qword-break (point))
 435                   (skip-chars-forward "^ \t\n\r")))
 436                (t
 437                 (skip-chars-forward "^ \t\n\r"))))
 438             (when (and (or break qword-break)
 439                        (> (- (point) bol) 76))
 440               (goto-char (or break qword-break))
 441               (setq break nil
 442                     qword-break nil)
 443               (if (looking-at "[ \t]")
 444                   (insert "\n")
 445                 (insert "\n "))
 446               (setq bol (1- (point)))
 447               ;; Don't break before the first non-LWSP characters.
 448               (skip-chars-forward " \t")
 449               (unless (eobp)
 450                 (forward-char 1))))))))
 451
 452   (unless (fboundp 'std11-fold-field)
 453     (defalias 'std11-fold-field
 454       ;; Should keep track of `rfc2047-fold-field' in rfc2047.el.
 455       (lambda ()
 456         "Fold the current line."
 457         (save-excursion
 458           (save-restriction
 459             (std11-narrow-to-field)
 460             (std11-fold-region (point-min) (point-max)))))))
 461   (defalias 'mail-header-fold-field 'std11-fold-field)
 462
 463   (unless (fboundp 'std11-unfold-region)
 464     (defalias 'std11-unfold-region
 465       ;; Should keep track of `rfc2047-unfold-region' in rfc2047.el.
 466       (lambda (b e)
 467         "Unfold lines in region B to E."
 468         (save-restriction
 469           (narrow-to-region b e)
 470           (goto-char (point-min))
 471           (let ((bol (save-restriction
 472                        (widen)
 473                        (point-at-bol)))
 474                 (eol (point-at-eol)))
 475             (forward-line 1)
 476             (while (not (eobp))
 477               (if (and (looking-at "[ \t]")
 478                        (< (- (point-at-eol) bol) 76))
 479                   (delete-region eol (progn
 480                                        (goto-char eol)
 481                                        (skip-chars-forward "\r\n")
 482                                        (point)))
 483                 (setq bol (point-at-bol)))
 484               (setq eol (point-at-eol))
 485               (forward-line 1)))))))
 486
 487   (unless (fboundp 'std11-unfold-field)
 488     (defalias 'std11-unfold-field
 489       ;; Should keep track of `rfc2047-unfold-field' in rfc2047.el.
 490       (lambda ()
 491         "Fold the current line."
 492         (save-excursion
 493           (save-restriction
 494             (std11-narrow-to-field)
 495             (std11-unfold-region (point-min) (point-max)))))))
 496   (defalias 'mail-header-unfold-field 'std11-unfold-field)
 497
 498   (unless (fboundp 'std11-extract-addresses-components)
 499     (defalias 'std11-extract-addresses-components
 500       ;; This is the original function in T-gnus.
 501       (lambda (string)
 502         "Extract a list of full name and canonical address from STRING.  Each
 503 element looks like a list of the form (FULL-NAME CANONICAL-ADDRESS).
 504 If no name can be extracted, FULL-NAME will be nil."
 505         (when string
 506           (let (addresses)
 507             (dolist (structure (std11-parse-addresses-string
 508                                 (std11-unfold-string string))
 509                                addresses)
 510               (push (list (std11-full-name-string structure)
 511                           (std11-address-string structure))
 512                     addresses))
 513             (nreverse addresses))))))
 514
 515   ;; Should keep track of `ietf-drums-parse-addresses' in ietf-drums.el.
 516   (defun mail-header-parse-addresses (string)
 517     "Parse STRING and return a list of MAILBOX / DISPLAY-NAME pairs."
 518     (mapcar (function
 519              (lambda (components)
 520                (cons (nth 1 components) (car components))))
 521             (std11-extract-addresses-components string)))
 522
 523   ;; Should keep track of `rfc2047-field-value' in rfc2047.el.
 524   (defun std11-field-value (&optional dont-include-last-newline)
 525     "Return the value of the field at point.  If the optional argument is
 526 given, the return value will not contain the last newline."
 527     (let ((begin (point))
 528           (inhibit-point-motion-hooks t)
 529           start value)
 530       (beginning-of-line)
 531       (unless (eobp)
 532         (while (and (memq (char-after) '(?\t ?\ ))
 533                     (zerop (forward-line -1))))
 534         (when (looking-at "[^\t\n ]+:[\t\n ]+")
 535           (goto-char (setq start (match-end 0)))
 536           (forward-line 1)
 537           (while (and (memq (char-after) '(?\t ?\ ))
 538                       (zerop (forward-line 1))))
 539           (when dont-include-last-newline
 540             (skip-chars-backward "\t\n " start))
 541           (setq value (buffer-substring start (point)))))
 542       (goto-char begin)
 543       value))
 544   (defalias 'mail-header-field-value 'std11-field-value))
 545
 546 ;; ietf-drums stuff.
 547 (unless (featurep 'ietf-drums)
 548   ;; Should keep track of `ietf-drums-unfold-fws' in ietf-drums.el.
 549   (defun nnheader-unfold-fws ()
 550     "Unfold folding white space in the current buffer."
 551     (goto-char (point-min))
 552     (while (re-search-forward "[ \t]*\n[ \t]+" nil t)
 553       (replace-match " " t t))
 554     (goto-char (point-min)))
 555
 556   (defalias 'ietf-drums-unfold-fws 'nnheader-unfold-fws))
 557
 558 ;;; Header access macros.
 559
 560 ;; These macros may look very much like the ones in GNUS 4.1.  They
 561 ;; are, in a way, but you should note that the indices they use have
 562 ;; been changed from the internal GNUS format to the NOV format.  The
 563 ;; makes it possible to read headers from XOVER much faster.
 564 ;;
 565 ;; The format of a header is now:
 566 ;; [number subject from date id references chars lines xref extra]
 567 ;;
 568 ;; (That next-to-last entry is defined as "misc" in the NOV format,
 569 ;; but Gnus uses it for xrefs.)
 570
 571 (require 'mmgnus)
 572
 573 (defmacro mail-header-number (header)
 574   "Return article number in HEADER."
 575   `(mime-entity-location-internal ,header))
 576
 577 (defmacro mail-header-set-number (header number)
 578   "Set article number of HEADER to NUMBER."
 579   `(mime-entity-set-location-internal ,header ,number))
 580
 581 (defalias 'mail-header-subject 'mime-gnus-entity-subject-internal)
 582 (defalias 'mail-header-set-subject 'mime-gnus-entity-set-subject-internal)
 583
 584 (defalias 'mail-header-from 'mime-gnus-entity-from-internal)
 585 (defalias 'mail-header-set-from 'mime-gnus-entity-set-from-internal)
 586
 587 (defalias 'mail-header-date 'mime-gnus-entity-date-internal)
 588 (defalias 'mail-header-set-date 'mime-gnus-entity-set-date-internal)
 589
 590 (defalias 'mail-header-message-id 'mime-gnus-entity-id-internal)
 591 (defalias 'mail-header-id 'mime-gnus-entity-id-internal)
 592 (defalias 'mail-header-set-message-id 'mime-gnus-entity-set-id-internal)
 593 (defalias 'mail-header-set-id 'mime-gnus-entity-set-id-internal)
 594
 595 (defalias 'mail-header-references 'mime-gnus-entity-references-internal)
 596 (defalias 'mail-header-set-references
 597   'mime-gnus-entity-set-references-internal)
 598
 599 (defalias 'mail-header-chars 'mime-gnus-entity-chars-internal)
 600 (defalias 'mail-header-set-chars 'mime-gnus-entity-set-chars-internal)
 601
 602 (defalias 'mail-header-lines 'mime-gnus-entity-lines-internal)
 603 (defalias 'mail-header-set-lines 'mime-gnus-entity-set-lines-internal)
 604
 605 (defalias 'mail-header-xref 'mime-gnus-entity-xref-internal)
 606 (defalias 'mail-header-set-xref 'mime-gnus-entity-set-xref-internal)
 607
 608 (defalias 'nnheader-decode-subject
 609   (mime-find-field-decoder 'Subject 'nov))
 610 (defalias 'nnheader-decode-from
 611   (mime-find-field-decoder 'From 'nov))
 612
 613 (defalias 'mail-header-extra 'mime-gnus-entity-extra-internal)
 614
 615 (defun mail-header-set-extra (header extra)
 616   "Set the extra headers in HEADER to EXTRA."
 617   (mime-gnus-entity-set-extra-internal header extra))
 618
 619 (defun nnheader-decode-field-body (field-body field-name
 620                                               &optional mode max-column)
 621   (mime-decode-field-body field-body
 622                           (if (stringp field-name)
 623                               (intern (capitalize field-name))
 624                             field-name)
 625                           mode max-column))
 626
 627 (defsubst make-full-mail-header (&optional number subject from date id
 628                                            references chars lines xref
 629                                            extra)
 630   "Create a new mail header structure initialized with the parameters given."
 631   (luna-make-entity (mm-expand-class-name 'gnus)
 632                     :location number
 633                     :subject (if subject
 634                                  (nnheader-decode-subject subject))
 635                     :from (if from
 636                               (nnheader-decode-from from))
 637                     :date date
 638                     :id id
 639                     :references references
 640                     :chars chars
 641                     :lines lines
 642                     :xref xref
 643                     :original-header (list (cons 'Subject subject)
 644                                            (cons 'From from))
 645                     :extra extra))
 646
 647 (defsubst make-full-mail-header-from-decoded-header
 648   (&optional number subject from date id references chars lines xref extra)
 649   "Create a new mail header structure initialized with the parameters given."
 650   (luna-make-entity (mm-expand-class-name 'gnus)
 651                     :location number
 652                     :subject subject
 653                     :from from
 654                     :date date
 655                     :id id
 656                     :references references
 657                     :chars chars
 658                     :lines lines
 659                     :xref xref
 660                     :extra extra))
 661
 662 (defsubst make-mail-header (&optional init)
 663   "Create a new mail header structure initialized with INIT."
 664   (make-full-mail-header init init init init init
 665                          init init init init init))
 666
 667 ;; fake message-ids: generation and detection
 668
 669 (defvar nnheader-fake-message-id 1)
 670
 671 (defsubst nnheader-generate-fake-message-id (&optional number)
 672   (if (numberp number)
 673       (format "fake+none+%s+%d" gnus-newsgroup-name number)
 674     (format "fake+none+%s+%s"
 675             gnus-newsgroup-name
 676             (int-to-string (incf nnheader-fake-message-id)))))
 677
 678 (defsubst nnheader-fake-message-id-p (id)
 679   (save-match-data                      ; regular message-id's are <.*>
 680     (string-match "\\`fake\\+none\\+.*\\+[0-9]+\\'" id)))
 681
 682 ;; Parsing headers and NOV lines.
 683
 684 (defsubst nnheader-remove-cr-followed-by-lf ()
 685   (goto-char (point-max))
 686   (while (search-backward "\r\n" nil t)
 687     (delete-char 1)))
 688
 689 (defsubst nnheader-header-value ()
 690   (let ((pt (point)))
 691     (prog2
 692         (skip-chars-forward " \t")
 693         (buffer-substring (point) (std11-field-end))
 694       (goto-char pt))))
 695
 696 (defun nnheader-parse-naked-head (&optional number)
 697   ;; This function unfolds continuation lines in this buffer
 698   ;; destructively.  When this side effect is unwanted, use
 699   ;; `nnheader-parse-head' instead of this function.
 700   (let ((case-fold-search t)
 701         (buffer-read-only nil)
 702         (cur (current-buffer))
 703         (p (point-min))
 704         in-reply-to lines ref)
 705     (nnheader-remove-cr-followed-by-lf)
 706     (ietf-drums-unfold-fws)
 707     (subst-char-in-region (point-min) (point-max) ?\t ? )
 708     (goto-char p)
 709     (insert "\n")
 710     (prog1
 711         ;; This implementation of this function, with nine
 712         ;; search-forwards instead of the one re-search-forward and a
 713         ;; case (which basically was the old function) is actually
 714         ;; about twice as fast, even though it looks messier.  You
 715         ;; can't have everything, I guess.  Speed and elegance don't
 716         ;; always go hand in hand.
 717         (make-full-mail-header
 718          ;; Number.
 719          (or number 0)
 720          ;; Subject.
 721          (progn
 722            (goto-char p)
 723            (if (search-forward "\nsubject:" nil t)
 724                (nnheader-header-value) "(none)"))
 725          ;; From.
 726          (progn
 727            (goto-char p)
 728            (if (search-forward "\nfrom:" nil t)
 729                (nnheader-header-value) "(nobody)"))
 730          ;; Date.
 731          (progn
 732            (goto-char p)
 733            (if (search-forward "\ndate:" nil t)
 734                (nnheader-header-value) ""))
 735          ;; Message-ID.
 736          (progn
 737            (goto-char p)
 738            (if (search-forward "\nmessage-id:" nil t)
 739                (buffer-substring
 740                 (1- (or (search-forward "<" (point-at-eol) t)
 741                         (point)))
 742                 (or (search-forward ">" (point-at-eol) t) (point)))
 743              ;; If there was no message-id, we just fake one to make
 744              ;; subsequent routines simpler.
 745              (nnheader-generate-fake-message-id number)))
 746          ;; References.
 747          (progn
 748            (goto-char p)
 749            (if (search-forward "\nreferences:" nil t)
 750                (nnheader-header-value)
 751              ;; Get the references from the in-reply-to header if
 752              ;; there were no references and the in-reply-to header
 753              ;; looks promising.
 754              (if (and (search-forward "\nin-reply-to:" nil t)
 755                       (setq in-reply-to (nnheader-header-value))
 756                       (string-match "<[^\n>]+>" in-reply-to))
 757                  (let (ref2)
 758                    (setq ref (substring in-reply-to (match-beginning 0)
 759                                         (match-end 0)))
 760                    (while (string-match "<[^\n>]+>"
 761                                         in-reply-to (match-end 0))
 762                      (setq ref2 (substring in-reply-to (match-beginning 0)
 763                                            (match-end 0)))
 764                      (when (> (length ref2) (length ref))
 765                        (setq ref ref2)))
 766                    ref)
 767                nil)))
 768          ;; Chars.
 769          0
 770          ;; Lines.
 771          (progn
 772            (goto-char p)
 773            (if (search-forward "\nlines: " nil t)
 774                (if (numberp (setq lines (read cur)))
 775                    lines 0)
 776              0))
 777          ;; Xref.
 778          (progn
 779            (goto-char p)
 780            (and (search-forward "\nxref:" nil t)
 781                 (nnheader-header-value)))
 782          ;; Extra.
 783          (when nnmail-extra-headers
 784            (let ((extra nnmail-extra-headers)
 785                  out)
 786              (while extra
 787                (goto-char p)
 788                (when (search-forward
 789                       (concat "\n" (symbol-name (car extra)) ":") nil t)
 790                  (push (cons (car extra) (nnheader-header-value))
 791                        out))
 792                (pop extra))
 793              out)))
 794       (goto-char p)
 795       (delete-char 1))))
 796
 797 (defun nnheader-parse-head (&optional naked)
 798   (let ((cur (current-buffer)) num beg end)
 799     (when (if naked
 800               (setq num 0
 801                     beg (point-min)
 802                     end (point-max))
 803             (goto-char (point-min))
 804             ;; Search to the beginning of the next header.  Error
 805             ;; messages do not begin with 2 or 3.
 806             (when (re-search-forward "^[23][0-9]+ " nil t)
 807               (end-of-line)
 808               (setq num (read cur)
 809                     beg (point)
 810                     end (if (search-forward "\n.\n" nil t)
 811                             (- (point) 2)
 812                           (point)))))
 813       (with-temp-buffer
 814         (insert-buffer-substring cur beg end)
 815         (nnheader-parse-naked-head num)))))
 816
 817 (defmacro nnheader-nov-skip-field ()
 818   '(search-forward "\t" eol 'move))
 819
 820 (defmacro nnheader-nov-field ()
 821   '(buffer-substring (point) (if (nnheader-nov-skip-field) (1- (point)) eol)))
 822
 823 (defmacro nnheader-nov-read-integer ()
 824   '(prog1
 825        (if (eq (char-after) ?\t)
 826            0
 827          (let ((num (condition-case nil
 828                         (read (current-buffer))
 829                       (error nil))))
 830            (if (numberp num) num 0)))
 831      (unless (eobp)
 832        (search-forward "\t" eol 'move))))
 833
 834 (defmacro nnheader-nov-parse-extra ()
 835   '(let (out string)
 836      (while (not (memq (char-after) '(?\n nil)))
 837        (setq string (nnheader-nov-field))
 838        (when (string-match "^\\([^ :]+\\): " string)
 839          (push (cons (intern (match-string 1 string))
 840                      (substring string (match-end 0)))
 841                out)))
 842      out))
 843
 844 (defvar nnheader-uniquify-message-id nil)
 845
 846 (defmacro nnheader-nov-read-message-id (&optional number)
 847   `(let ((id (nnheader-nov-field)))
 848      (if (string-match "^<[^>]+>$" id)
 849          ,(if nnheader-uniquify-message-id
 850               `(if (string-match "__[^@]+@" id)
 851                    (concat (substring id 0 (match-beginning 0))
 852                            (substring id (1- (match-end 0))))
 853                  id)
 854             'id)
 855        (nnheader-generate-fake-message-id ,number))))
 856
 857 (defun nnheader-parse-nov ()
 858   (let* ((eol (point-at-eol))
 859          (number (nnheader-nov-read-integer)))
 860     (make-full-mail-header
 861      number                             ; number
 862      (nnheader-nov-field)               ; subject
 863      (nnheader-nov-field)               ; from
 864      (nnheader-nov-field)               ; date
 865      (nnheader-nov-read-message-id number) ; id
 866      (nnheader-nov-field)               ; refs
 867      (nnheader-nov-read-integer)        ; chars
 868      (nnheader-nov-read-integer)        ; lines
 869      (if (eq (char-after) ?\n)
 870          nil
 871        (if (looking-at "Xref: ")
 872            (goto-char (match-end 0)))
 873        (nnheader-nov-field))            ; Xref
 874      (nnheader-nov-parse-extra))))      ; extra
 875
 876 (defun nnheader-insert-nov (header)
 877   (princ (mail-header-number header) (current-buffer))
 878   (let ((p (point)))
 879     (insert
 880      "\t"
 881      (or (mime-entity-fetch-field header 'Subject) "(none)") "\t"
 882      (or (mime-entity-fetch-field header 'From) "(nobody)") "\t"
 883      (or (mail-header-date header) "") "\t"
 884      (or (mail-header-id header)
 885          (nnmail-message-id))
 886      "\t"
 887      (or (mail-header-references header) "") "\t")
 888     (princ (or (mail-header-chars header) 0) (current-buffer))
 889     (insert "\t")
 890     (princ (or (mail-header-lines header) 0) (current-buffer))
 891     (insert "\t")
 892     (when (mail-header-xref header)
 893       (insert "Xref: " (mail-header-xref header)))
 894     (when (or (mail-header-xref header)
 895               (mail-header-extra header))
 896       (insert "\t"))
 897     (when (mail-header-extra header)
 898       (let ((extra (mail-header-extra header)))
 899         (while extra
 900           (insert (symbol-name (caar extra))
 901                   ": " (cdar extra) "\t")
 902           (pop extra))))
 903     (insert "\n")
 904     (backward-char 1)
 905     (while (search-backward "\n" p t)
 906       (delete-char 1))
 907     (forward-line 1)))
 908
 909 (defun nnheader-parse-overview-file (file)
 910   "Parse FILE and return a list of headers."
 911   (mm-with-unibyte-buffer
 912     (nnheader-insert-file-contents file)
 913     (goto-char (point-min))
 914     (let (headers)
 915       (while (not (eobp))
 916         (push (nnheader-parse-nov) headers)
 917         (forward-line 1))
 918       (nreverse headers))))
 919
 920 (defun nnheader-write-overview-file (file headers)
 921   "Write HEADERS to FILE."
 922   (with-temp-file file
 923     (mapcar 'nnheader-insert-nov headers)))
 924
 925 (defun nnheader-insert-header (header)
 926   (insert
 927    "Subject: " (or (mail-header-subject header) "(none)") "\n"
 928    "From: " (or (mail-header-from header) "(nobody)") "\n"
 929    "Date: " (or (mail-header-date header) "") "\n"
 930    "Message-ID: " (or (mail-header-id header) (nnmail-message-id)) "\n"
 931    "References: " (or (mail-header-references header) "") "\n"
 932    "Lines: ")
 933   (princ (or (mail-header-lines header) 0) (current-buffer))
 934   (insert "\n\n"))
 935
 936 (defun nnheader-insert-article-line (article)
 937   (goto-char (point-min))
 938   (insert "220 ")
 939   (princ article (current-buffer))
 940   (insert " Article retrieved.\n")
 941   (search-forward "\n\n" nil 'move)
 942   (delete-region (point) (point-max))
 943   (forward-char -1)
 944   (insert "."))
 945
 946 (defun nnheader-nov-delete-outside-range (beg end)
 947   "Delete all NOV lines that lie outside the BEG to END range."
 948   ;; First we find the first wanted line.
 949   (nnheader-find-nov-line beg)
 950   (delete-region (point-min) (point))
 951   ;; Then we find the last wanted line.
 952   (when (nnheader-find-nov-line end)
 953     (forward-line 1))
 954   (delete-region (point) (point-max)))
 955
 956 (defun nnheader-find-nov-line (article)
 957   "Put point at the NOV line that start with ARTICLE.
 958 If ARTICLE doesn't exist, put point where that line
 959 would have been.  The function will return non-nil if
 960 the line could be found."
 961   ;; This function basically does a binary search.
 962   (let ((max (point-max))
 963         (min (goto-char (point-min)))
 964         (cur (current-buffer))
 965         (prev (point-min))
 966         num found)
 967     (while (not found)
 968       (goto-char (+ min (/ (- max min) 2)))
 969       (beginning-of-line)
 970       (if (or (= (point) prev)
 971               (eobp))
 972           (setq found t)
 973         (setq prev (point))
 974         (while (and (not (numberp (setq num (read cur))))
 975                     (not (eobp)))
 976           (gnus-delete-line))
 977         (cond ((> num article)
 978                (setq max (point)))
 979               ((< num article)
 980                (setq min (point)))
 981               (t
 982                (setq found 'yes)))))
 983     ;; We may be at the first line.
 984     (when (and (not num)
 985                (not (eobp)))
 986       (setq num (read cur)))
 987     ;; Now we may have found the article we're looking for, or we
 988     ;; may be somewhere near it.
 989     (when (and (not (eq found 'yes))
 990                (not (eq num article)))
 991       (setq found (point))
 992       (while (and (< (point) max)
 993                   (or (not (numberp num))
 994                       (< num article)))
 995         (forward-line 1)
 996         (setq found (point))
 997         (or (eobp)
 998             (= (setq num (read cur)) article)))
 999       (unless (eq num article)
1000         (goto-char found)))
1001     (beginning-of-line)
1002     (eq num article)))
1003
1004 (defun nnheader-retrieve-headers-from-directory* (articles
1005                                                   directory dependencies
1006                                                   &optional
1007                                                   fetch-old force-new large
1008                                                   backend)
1009   (with-temp-buffer
1010     (let* ((file nil)
1011            (number (length articles))
1012            (count 0)
1013            (file-name-coding-system 'binary)
1014            (case-fold-search t)
1015            (cur (current-buffer))
1016            article
1017            headers header id end ref in-reply-to lines chars ctype)
1018       ;; We don't support fetching by Message-ID.
1019       (if (stringp (car articles))
1020           'headers
1021         (while articles
1022           (when (and (file-exists-p
1023                       (setq file (expand-file-name
1024                                   (int-to-string
1025                                    (setq article (pop articles)))
1026                                   directory)))
1027                      (not (file-directory-p file)))
1028             (erase-buffer)
1029             (nnheader-insert-head file)
1030             (save-restriction
1031               (std11-narrow-to-header)
1032               (setq
1033                header
1034                (make-full-mail-header
1035                 ;; Number.
1036                 article
1037                 ;; Subject.
1038                 (or (std11-fetch-field "Subject")
1039                     "(none)")
1040                 ;; From.
1041                 (or (std11-fetch-field "From")
1042                     "(nobody)")
1043                 ;; Date.
1044                 (or (std11-fetch-field "Date")
1045                     "")
1046                 ;; Message-ID.
1047                 (progn
1048                   (goto-char (point-min))
1049                   (setq id (if (re-search-forward
1050                                 "^Message-ID: *\\(<[^\n\t> ]+>\\)" nil t)
1051                                ;; We do it this way to make sure the Message-ID
1052                                ;; is (somewhat) syntactically valid.
1053                                (buffer-substring (match-beginning 1)
1054                                                  (match-end 1))
1055                              ;; If there was no message-id, we just fake one
1056                              ;; to make subsequent routines simpler.
1057                              (nnheader-generate-fake-message-id))))
1058                 ;; References.
1059                 (progn
1060                   (goto-char (point-min))
1061                   (if (search-forward "\nReferences: " nil t)
1062                       (progn
1063                         (setq end (point))
1064                         (prog1
1065                             (buffer-substring (match-end 0) (std11-field-end))
1066                           (setq ref
1067                                 (buffer-substring
1068                                  (progn
1069                                    ;; (end-of-line)
1070                                    (search-backward ">" end t)
1071                                    (1+ (point)))
1072                                  (progn
1073                                    (search-backward "<" end t)
1074                                    (point))))))
1075                     ;; Get the references from the in-reply-to header if there
1076                     ;; were no references and the in-reply-to header looks
1077                     ;; promising.
1078                     (if (and (search-forward "\nIn-Reply-To: " nil t)
1079                              (setq in-reply-to
1080                                    (buffer-substring (match-end 0)
1081                                                      (std11-field-end)))
1082                              (string-match "<[^>]+>" in-reply-to))
1083                         (let (ref2)
1084                           (setq ref (substring in-reply-to (match-beginning 0)
1085                                                (match-end 0)))
1086                           (while (string-match "<[^>]+>"
1087                                                in-reply-to (match-end 0))
1088                             (setq ref2
1089                                   (substring in-reply-to (match-beginning 0)
1090                                              (match-end 0)))
1091                             (when (> (length ref2) (length ref))
1092                               (setq ref ref2)))
1093                           ref)
1094                       (setq ref nil))))
1095                 ;; Chars.
1096                 (progn
1097                   (goto-char (point-min))
1098                   (if (search-forward "\nChars: " nil t)
1099                       (if (numberp (setq chars (ignore-errors (read cur))))
1100                           chars 0)
1101                     0))
1102                 ;; Lines.
1103                 (progn
1104                   (goto-char (point-min))
1105                   (if (search-forward "\nLines: " nil t)
1106                       (if (numberp (setq lines (ignore-errors (read cur))))
1107                           lines 0)
1108                     0))
1109                 ;; Xref.
1110                 (std11-fetch-field "Xref")
1111                 ))
1112               (goto-char (point-min))
1113               (if (setq ctype (std11-fetch-field "Content-Type"))
1114                   (mime-entity-set-content-type-internal
1115                    header (mime-parse-Content-Type ctype)))
1116               )
1117             (when (setq header
1118                         (gnus-dependencies-add-header
1119                          header dependencies force-new))
1120               (push header headers))
1121             )
1122           (setq count (1+ count))
1123
1124           (and large
1125                (zerop (% count 20))
1126                (nnheader-message 5 "%s: Receiving headers... %d%%"
1127                                  backend
1128                                  (/ (* count 100) number))))
1129
1130         (when large
1131           (nnheader-message 5 "%s: Receiving headers...done" backend))
1132
1133         headers))))
1134
1135 (defun nnheader-retrieve-headers-from-directory (articles
1136                                                  directory dependencies
1137                                                  &optional
1138                                                  fetch-old force-new large
1139                                                  backend)
1140   (cons 'header
1141         (nreverse (nnheader-retrieve-headers-from-directory*
1142                    articles directory dependencies
1143                    fetch-old force-new large backend))))
1144
1145 (defun nnheader-get-newsgroup-headers-xover* (sequence
1146                                               &optional
1147                                               force-new dependencies
1148                                               group)
1149   "Parse the news overview data in the server buffer, and return a
1150 list of headers that match SEQUENCE (see `nntp-retrieve-headers')."
1151   ;; Get the Xref when the users reads the articles since most/some
1152   ;; NNTP servers do not include Xrefs when using XOVER.
1153   ;; (setq gnus-article-internal-prepare-hook '(gnus-article-get-xrefs))
1154   (let ((cur nntp-server-buffer)
1155         number headers header)
1156     (save-excursion
1157       (set-buffer nntp-server-buffer)
1158       ;; Allow the user to mangle the headers before parsing them.
1159       (gnus-run-hooks 'gnus-parse-headers-hook)
1160       (goto-char (point-min))
1161       (while (not (eobp))
1162         (condition-case ()
1163             (while (and sequence (not (eobp)))
1164               (setq number (read cur))
1165               (while (and sequence
1166                           (< (car sequence) number))
1167                 (setq sequence (cdr sequence)))
1168               (and sequence
1169                    (eq number (car sequence))
1170                    (progn
1171                      (setq sequence (cdr sequence))
1172                      (setq header (inline
1173                                     (gnus-nov-parse-line
1174                                      number dependencies force-new))))
1175                    (push header headers))
1176               (forward-line 1))
1177           (error
1178            (gnus-error 4 "Strange nov line (%d)"
1179                        (count-lines (point-min) (point)))))
1180         (forward-line 1))
1181       ;; A common bug in inn is that if you have posted an article and
1182       ;; then retrieves the active file, it will answer correctly --
1183       ;; the new article is included.  However, a NOV entry for the
1184       ;; article may not have been generated yet, so this may fail.
1185       ;; We work around this problem by retrieving the last few
1186       ;; headers using HEAD.
1187       headers)))
1188
1189 ;; Various cruft the backends and Gnus need to communicate.
1190
1191 (defvar nntp-server-buffer nil)
1192 (defvar nntp-process-response nil)
1193 (defvar news-reply-yank-from nil)
1194 (defvar news-reply-yank-message-id nil)
1195
1196 (defvar nnheader-callback-function nil)
1197
1198 (defun nnheader-init-server-buffer ()
1199   "Initialize the Gnus-backend communication buffer."
1200   (save-excursion
1201     (unless (gnus-buffer-live-p nntp-server-buffer)
1202       (setq nntp-server-buffer (get-buffer-create " *nntpd*")))
1203     (set-buffer nntp-server-buffer)
1204     (erase-buffer)
1205     (kill-all-local-variables)
1206     (setq case-fold-search t)           ;Should ignore case.
1207     (set (make-local-variable 'nntp-process-response) nil)
1208     t))
1209
1210 ;;; Various functions the backends use.
1211
1212 (defun nnheader-file-error (file)
1213   "Return a string that says what is wrong with FILE."
1214   (format
1215    (cond
1216     ((not (file-exists-p file))
1217      "%s does not exist")
1218     ((file-directory-p file)
1219      "%s is a directory")
1220     ((not (file-readable-p file))
1221      "%s is not readable"))
1222    file))
1223
1224 (defun nnheader-insert-head (file)
1225   "Insert the head of the article."
1226   (when (file-exists-p file)
1227     (if (eq nnheader-max-head-length t)
1228         ;; Just read the entire file.
1229         (nnheader-insert-file-contents file)
1230       ;; Read 1K blocks until we find a separator.
1231       (let ((beg 0)
1232             format-alist)
1233         (while (and (eq nnheader-head-chop-length
1234                         (nth 1 (nnheader-insert-file-contents
1235                                 file nil beg
1236                                 (incf beg nnheader-head-chop-length))))
1237                     (prog1 (not (search-forward "\n\n" nil t))
1238                       (goto-char (point-max)))
1239                     (or (null nnheader-max-head-length)
1240                         (< beg nnheader-max-head-length))))))
1241     t))
1242
1243 (defun nnheader-article-p ()
1244   "Say whether the current buffer looks like an article."
1245   (goto-char (point-min))
1246   (if (not (search-forward "\n\n" nil t))
1247       nil
1248     (narrow-to-region (point-min) (1- (point)))
1249     (goto-char (point-min))
1250     (while (looking-at "[a-zA-Z][^ \t]+:.*\n\\([ \t].*\n\\)*\\|From .*\n")
1251       (goto-char (match-end 0)))
1252     (prog1
1253         (eobp)
1254       (widen))))
1255
1256 (defun nnheader-insert-references (references message-id)
1257   "Insert a References header based on REFERENCES and MESSAGE-ID."
1258   (if (and (not references) (not message-id))
1259       ;; This is invalid, but not all articles have Message-IDs.
1260       ()
1261     (mail-position-on-field "References")
1262     (let ((begin (point-at-bol))
1263           (fill-column 78)
1264           (fill-prefix "\t"))
1265       (when references
1266         (insert references))
1267       (when (and references message-id)
1268         (insert " "))
1269       (when message-id
1270         (insert message-id))
1271       ;; Fold long References lines to conform to RFC1036 (sort of).
1272       ;; The region must end with a newline to fill the region
1273       ;; without inserting extra newline.
1274       (fill-region-as-paragraph begin (1+ (point))))))
1275
1276 (defun nnheader-replace-header (header new-value)
1277   "Remove HEADER and insert the NEW-VALUE."
1278   (save-excursion
1279     (save-restriction
1280       (nnheader-narrow-to-headers)
1281       (prog1
1282           (message-remove-header header)
1283         (goto-char (point-max))
1284         (insert header ": " new-value "\n")))))
1285
1286 (defun nnheader-narrow-to-headers ()
1287   "Narrow to the head of an article."
1288   (widen)
1289   (narrow-to-region
1290    (goto-char (point-min))
1291    (if (search-forward "\n\n" nil t)
1292        (1- (point))
1293      (point-max)))
1294   (goto-char (point-min)))
1295
1296 (defun nnheader-get-lines-and-char ()
1297   "Return the number of lines and chars in the article body."
1298   (goto-char (point-min))
1299   (if (not (re-search-forward "\n\r?\n" nil t))
1300       (list 0 0)
1301     (list (count-lines (point) (point-max))
1302           (- (point-max) (point)))))
1303
1304 (defun nnheader-remove-body ()
1305   "Remove the body from an article in this current buffer."
1306   (goto-char (point-min))
1307   (when (re-search-forward "\n\r?\n" nil t)
1308     (delete-region (point) (point-max))))
1309
1310 (defun nnheader-set-temp-buffer (name &optional noerase)
1311   "Set-buffer to an empty (possibly new) buffer called NAME with undo disabled."
1312   (set-buffer (get-buffer-create name))
1313   (buffer-disable-undo)
1314   (unless noerase
1315     (erase-buffer))
1316   (current-buffer))
1317
1318 (eval-when-compile (defvar jka-compr-compression-info-list))
1319 (defvar nnheader-numerical-files
1320   (if (boundp 'jka-compr-compression-info-list)
1321       (concat "\\([0-9]+\\)\\("
1322               (mapconcat (lambda (i) (aref i 0))
1323                          jka-compr-compression-info-list "\\|")
1324               "\\)?")
1325     "[0-9]+$")
1326   "Regexp that match numerical files.")
1327
1328 (defvar nnheader-numerical-short-files (concat "^" nnheader-numerical-files)
1329   "Regexp that matches numerical file names.")
1330
1331 (defvar nnheader-numerical-full-files (concat "/" nnheader-numerical-files)
1332   "Regexp that matches numerical full file names.")
1333
1334 (defsubst nnheader-file-to-number (file)
1335   "Take a FILE name and return the article number."
1336   (if (string= nnheader-numerical-short-files "^[0-9]+$")
1337       (string-to-number file)
1338     (string-match nnheader-numerical-short-files file)
1339     (string-to-number (match-string 0 file))))
1340
1341 (defvar nnheader-directory-files-is-safe
1342   (or (eq system-type 'windows-nt)
1343       (not (featurep 'xemacs)))
1344   "If non-nil, Gnus believes `directory-files' is safe.
1345 It has been reported numerous times that `directory-files' fails with
1346 an alarming frequency on NFS mounted file systems. If it is nil,
1347 `nnheader-directory-files-safe' is used.")
1348
1349 (defun nnheader-directory-files-safe (&rest args)
1350   "Execute `directory-files' twice and returns the longer result."
1351   (let ((first (apply 'directory-files args))
1352         (second (apply 'directory-files args)))
1353     (if (> (length first) (length second))
1354         first
1355       second)))
1356
1357 (defun nnheader-directory-articles (dir)
1358   "Return a list of all article files in directory DIR."
1359   (mapcar 'nnheader-file-to-number
1360           (if nnheader-directory-files-is-safe
1361               (directory-files
1362                dir nil nnheader-numerical-short-files t)
1363             (nnheader-directory-files-safe
1364              dir nil nnheader-numerical-short-files t))))
1365
1366 (defun nnheader-article-to-file-alist (dir)
1367   "Return an alist of article/file pairs in DIR."
1368   (mapcar (lambda (file) (cons (nnheader-file-to-number file) file))
1369           (if nnheader-directory-files-is-safe
1370               (directory-files
1371                dir nil nnheader-numerical-short-files t)
1372             (nnheader-directory-files-safe
1373              dir nil nnheader-numerical-short-files t))))
1374
1375 (defun nnheader-fold-continuation-lines ()
1376   "Fold continuation lines in the current buffer."
1377   (nnheader-replace-regexp "\\(\r?\n[ \t]+\\)+" " "))
1378
1379 (defun nnheader-translate-file-chars (file &optional full)
1380   "Translate FILE into something that can be a file name.
1381 If FULL, translate everything."
1382   (if (null nnheader-file-name-translation-alist)
1383       ;; No translation is necessary.
1384       file
1385     (let* ((i 0)
1386            trans leaf path len)
1387       (if full
1388           ;; Do complete translation.
1389           (setq leaf (copy-sequence file)
1390                 path ""
1391                 i (if (and (< 1 (length leaf)) (eq ?: (aref leaf 1)))
1392                       2 0))
1393         ;; We translate -- but only the file name.  We leave the directory
1394         ;; alone.
1395         (if (and (featurep 'xemacs)
1396                  (memq system-type '(cygwin32 win32 w32 mswindows windows-nt
1397                                               cygwin)))
1398             ;; This is needed on NT and stuff, because
1399             ;; file-name-nondirectory is not enough to split
1400             ;; file names, containing ':', e.g.
1401             ;; "d:\\Work\\News\\nntp+news.fido7.ru:fido7.ru.gnu.SCORE"
1402             ;;
1403             ;; we are trying to correctly split such names:
1404             ;; "d:file.name" -> "a:" "file.name"
1405             ;; "aaa:bbb.ccc" -> "" "aaa:bbb.ccc"
1406             ;; "d:aaa\\bbb:ccc"   -> "d:aaa\\" "bbb:ccc"
1407             ;; etc.
1408             ;; to translate then only the file name part.
1409             (progn
1410               (setq leaf file
1411                     path "")
1412               (if (string-match "\\(^\\w:\\|[/\\]\\)\\([^/\\]+\\)$" file)
1413                   (setq leaf (substring file (match-beginning 2))
1414                         path (substring file 0 (match-beginning 2)))))
1415           ;; Emacs DTRT, says andrewi.
1416           (setq leaf (file-name-nondirectory file)
1417                 path (file-name-directory file))))
1418       (setq len (length leaf))
1419       (while (< i len)
1420         (when (setq trans (cdr (assq (aref leaf i)
1421                                      nnheader-file-name-translation-alist)))
1422           (aset leaf i trans))
1423         (incf i))
1424       (concat path leaf))))
1425
1426 (defun nnheader-report (backend &rest args)
1427   "Report an error from the BACKEND.
1428 The first string in ARGS can be a format string."
1429   (set (intern (format "%s-status-string" backend))
1430        (if (< (length args) 2)
1431            (car args)
1432          (apply 'format args)))
1433   nil)
1434
1435 (defun nnheader-get-report (backend)
1436   "Get the most recent report from BACKEND."
1437   (condition-case ()
1438       (nnheader-message 5 "%s" (symbol-value (intern (format "%s-status-string"
1439                                                              backend))))
1440     (error (nnheader-message 5 ""))))
1441
1442 (defun nnheader-insert (format &rest args)
1443   "Clear the communication buffer and insert FORMAT and ARGS into the buffer.
1444 If FORMAT isn't a format string, it and all ARGS will be inserted
1445 without formatting."
1446   (save-excursion
1447     (set-buffer nntp-server-buffer)
1448     (erase-buffer)
1449     (if (string-match "%" format)
1450         (insert (apply 'format format args))
1451       (apply 'insert format args))
1452     t))
1453
1454 (static-if (fboundp 'subst-char-in-string)
1455     (defsubst nnheader-replace-chars-in-string (string from to)
1456       (subst-char-in-string from to string))
1457   (defun nnheader-replace-chars-in-string (string from to)
1458     "Replace characters in STRING from FROM to TO."
1459     (let ((string (substring string 0)) ;Copy string.
1460           (len (length string))
1461           (idx 0))
1462       ;; Replace all occurrences of FROM with TO.
1463       (while (< idx len)
1464         (when (= (aref string idx) from)
1465           (aset string idx to))
1466         (setq idx (1+ idx)))
1467       string)))
1468
1469 (defun nnheader-replace-duplicate-chars-in-string (string from to)
1470   "Replace characters in STRING from FROM to TO."
1471   (let ((string (substring string 0))   ;Copy string.
1472         (len (length string))
1473         (idx 0) prev i)
1474     ;; Replace all occurrences of FROM with TO.
1475     (while (< idx len)
1476       (setq i (aref string idx))
1477       (when (and (eq prev from) (= i from))
1478         (aset string (1- idx) to)
1479         (aset string idx to))
1480       (setq prev i)
1481       (setq idx (1+ idx)))
1482     string))
1483
1484 (defun nnheader-file-to-group (file &optional top)
1485   "Return a group name based on FILE and TOP."
1486   (nnheader-replace-chars-in-string
1487    (if (not top)
1488        file
1489      (condition-case ()
1490          (substring (expand-file-name file)
1491                     (length
1492                      (expand-file-name
1493                       (file-name-as-directory top))))
1494        (error "")))
1495    nnheader-directory-separator-character ?.))
1496
1497 (defun nnheader-message (level &rest args)
1498   "Message if the Gnus backends are talkative."
1499   (if (or (not (numberp gnus-verbose-backends))
1500           (<= level gnus-verbose-backends))
1501       (apply 'message args)
1502     (apply 'format args)))
1503
1504 (defun nnheader-be-verbose (level)
1505   "Return whether the backends should be verbose on LEVEL."
1506   (or (not (numberp gnus-verbose-backends))
1507       (<= level gnus-verbose-backends)))
1508
1509 (defvar nnheader-pathname-coding-system 'binary
1510   "*Coding system for file name.")
1511
1512 (defun nnheader-group-pathname (group dir &optional file)
1513   "Make file name for GROUP."
1514   (concat
1515    (let ((dir (file-name-as-directory (expand-file-name dir))))
1516      ;; If this directory exists, we use it directly.
1517      (file-name-as-directory
1518       (if (file-directory-p (concat dir group))
1519           (expand-file-name group dir)
1520         ;; If not, we translate dots into slashes.
1521         (expand-file-name (encode-coding-string
1522                            (nnheader-replace-chars-in-string group ?. ?/)
1523                            nnheader-pathname-coding-system)
1524                           dir))))
1525    (cond ((null file) "")
1526          ((numberp file) (int-to-string file))
1527          (t file))))
1528
1529 (defun nnheader-concat (dir &rest files)
1530   "Concat DIR as directory to FILES."
1531   (apply 'concat (file-name-as-directory dir) files))
1532
1533 (defun nnheader-ms-strip-cr ()
1534   "Strip ^M from the end of all lines."
1535   (save-excursion
1536     (nnheader-remove-cr-followed-by-lf)))
1537
1538 (defun nnheader-file-size (file)
1539   "Return the file size of FILE or 0."
1540   (or (nth 7 (file-attributes file)) 0))
1541
1542 (defun nnheader-find-etc-directory (package &optional file first)
1543   "Go through `load-path' and find the \"../etc/PACKAGE\" directory.
1544 This function will look in the parent directory of each `load-path'
1545 entry, and look for the \"etc\" directory there.
1546 If FILE, find the \".../etc/PACKAGE\" file instead.
1547 If FIRST is non-nil, return the directory or the file found at the
1548 first.  Otherwise, find the newest one, though it may take a time."
1549   (let ((path load-path)
1550         dir results)
1551     ;; We try to find the dir by looking at the load path,
1552     ;; stripping away the last component and adding "etc/".
1553     (while path
1554       (if (and (car path)
1555                (file-exists-p
1556                 (setq dir (concat
1557                            (file-name-directory
1558                             (directory-file-name (car path)))
1559                            "etc/" package
1560                            (if file "" "/"))))
1561                (or file (file-directory-p dir)))
1562           (progn
1563             (or (member dir results)
1564                 (push dir results))
1565             (setq path (if first nil (cdr path))))
1566         (setq path (cdr path))))
1567     (if (or first (not (cdr results)))
1568         (car results)
1569       (car (sort results 'file-newer-than-file-p)))))
1570
1571 (eval-when-compile
1572   (defvar ange-ftp-path-format)
1573   (defvar efs-path-regexp))
1574 (defun nnheader-re-read-dir (path)
1575   "Re-read directory PATH if PATH is on a remote system."
1576   (if (and (fboundp 'efs-re-read-dir) (boundp 'efs-path-regexp))
1577       (when (string-match efs-path-regexp path)
1578         (efs-re-read-dir path))
1579     (when (and (fboundp 'ange-ftp-re-read-dir) (boundp 'ange-ftp-path-format))
1580       (when (string-match (car ange-ftp-path-format) path)
1581         (ange-ftp-re-read-dir path)))))
1582
1583 (defvar nnheader-file-coding-system 'raw-text
1584   "Coding system used in file backends of Gnus.")
1585
1586 (defun nnheader-insert-file-contents (filename &optional visit beg end replace)
1587   "Like `insert-file-contents', q.v., but only reads in the file.
1588 A buffer may be modified in several ways after reading into the buffer due
1589 to advanced Emacs features, such as file-name-handlers, format decoding,
1590 find-file-hooks, etc.
1591   This function ensures that none of these modifications will take place."
1592   (let* ((format-alist nil)
1593          (auto-mode-alist (nnheader-auto-mode-alist))
1594          (default-major-mode 'fundamental-mode)
1595          (enable-local-variables nil)
1596          (after-insert-file-functions nil)
1597          (enable-local-eval nil)
1598          (ffh (if (boundp 'find-file-hook)
1599                   'find-file-hook
1600                 'find-file-hooks))
1601          (val (symbol-value ffh)))
1602     (set ffh nil)
1603     (unwind-protect
1604         (insert-file-contents-as-coding-system
1605          nnheader-file-coding-system filename visit beg end replace)
1606       (set ffh val))))
1607
1608 (defun nnheader-insert-nov-file (file first)
1609   (let ((size (nth 7 (file-attributes file)))
1610         (cutoff (* 32 1024)))
1611     (when size
1612       (if (< size cutoff)
1613           ;; If the file is small, we just load it.
1614           (nnheader-insert-file-contents file)
1615         ;; We start on the assumption that FIRST is pretty recent.  If
1616         ;; not, we just insert the rest of the file as well.
1617         (let (current)
1618           (nnheader-insert-file-contents file nil (- size cutoff) size)
1619           (goto-char (point-min))
1620           (delete-region (point) (or (search-forward "\n" nil 'move) (point)))
1621           (setq current (ignore-errors (read (current-buffer))))
1622           (if (and (numberp current)
1623                    (< current first))
1624               t
1625             (delete-region (point-min) (point-max))
1626             (nnheader-insert-file-contents file)))))))
1627
1628 (defun nnheader-find-file-noselect (&rest args)
1629   "Open a file with some variables bound.
1630 See `find-file-noselect' for the arguments."
1631   (let* ((format-alist nil)
1632          (auto-mode-alist (nnheader-auto-mode-alist))
1633          (default-major-mode 'fundamental-mode)
1634          (enable-local-variables nil)
1635          (after-insert-file-functions nil)
1636          (enable-local-eval nil)
1637          (ffh (if (boundp 'find-file-hook)
1638                   'find-file-hook
1639                 'find-file-hooks))
1640          (val (symbol-value ffh)))
1641     (set ffh nil)
1642     (unwind-protect
1643         (apply 'find-file-noselect-as-coding-system
1644                nnheader-file-coding-system args)
1645       (set ffh val))))
1646
1647 (defun nnheader-auto-mode-alist ()
1648   "Return an `auto-mode-alist' with only the .gz (etc) thingies."
1649   (let ((alist auto-mode-alist)
1650         out)
1651     (while alist
1652       (when (listp (cdar alist))
1653         (push (car alist) out))
1654       (pop alist))
1655     (nreverse out)))
1656
1657 (defun nnheader-directory-regular-files (dir)
1658   "Return a list of all regular files in DIR."
1659   (let ((files (directory-files dir t))
1660         out)
1661     (while files
1662       (when (file-regular-p (car files))
1663         (push (car files) out))
1664       (pop files))
1665     (nreverse out)))
1666
1667 (defun nnheader-directory-files (&rest args)
1668   "Same as `directory-files', but prune \".\" and \"..\"."
1669   (let ((files (apply 'directory-files args))
1670         out)
1671     (while files
1672       (unless (member (file-name-nondirectory (car files)) '("." ".."))
1673         (push (car files) out))
1674       (pop files))
1675     (nreverse out)))
1676
1677 (defmacro nnheader-skeleton-replace (from &optional to regexp)
1678   `(let ((new (generate-new-buffer " *nnheader replace*"))
1679          (cur (current-buffer))
1680          (start (point-min)))
1681      (set-buffer cur)
1682      (goto-char (point-min))
1683      (while (,(if regexp 're-search-forward 'search-forward)
1684              ,from nil t)
1685        (insert-buffer-substring
1686         cur start (prog1 (match-beginning 0) (set-buffer new)))
1687        (goto-char (point-max))
1688        ,(when to `(insert ,to))
1689        (set-buffer cur)
1690        (setq start (point)))
1691      (insert-buffer-substring
1692       cur start (prog1 (point-max) (set-buffer new)))
1693      (copy-to-buffer cur (point-min) (point-max))
1694      (kill-buffer (current-buffer))
1695      (set-buffer cur)))
1696
1697 (defun nnheader-replace-string (from to)
1698   "Do a fast replacement of FROM to TO from point to `point-max'."
1699   (nnheader-skeleton-replace from to))
1700
1701 (defun nnheader-replace-regexp (from to)
1702   "Do a fast regexp replacement of FROM to TO from point to `point-max'."
1703   (nnheader-skeleton-replace from to t))
1704
1705 (defun nnheader-strip-cr ()
1706   "Strip all \r's from the current buffer."
1707   (nnheader-skeleton-replace "\r"))
1708
1709 (defalias 'nnheader-cancel-timer 'cancel-timer)
1710 (defalias 'nnheader-cancel-function-timers 'cancel-function-timers)
1711 (defalias 'nnheader-string-as-multibyte 'string-as-multibyte)
1712
1713 (defun nnheader-Y-or-n-p (prompt)
1714   "Ask user a \"Y/n\" question. Return t if answer is neither \"n\", \"N\" nor \"C-g\"."
1715   (let ((cursor-in-echo-area t)
1716         (echo-keystrokes 0)
1717         (inhibit-quit t)
1718         ans)
1719     (let (message-log-max)
1720       (while (not (memq ans '(?\  ?N ?Y ?\C-g ?\e ?\n ?\r ?n ?y)))
1721         (message "%s(Y/n) " prompt)
1722         (setq ans (read-char-exclusive))))
1723     (if (memq ans '(?\C-g ?N ?n))
1724         (progn
1725           (message "%s(Y/n) No" prompt)
1726           nil)
1727       (message "%s(Y/n) Yes" prompt)
1728       t)))
1729
1730 (defun-maybe shell-command-to-string (command)
1731   "Execute shell command COMMAND and return its output as a string."
1732   (with-output-to-string
1733     (with-current-buffer
1734         standard-output
1735       (call-process shell-file-name nil t nil shell-command-switch command))))
1736
1737 (defun nnheader-accept-process-output (process)
1738   (accept-process-output
1739    process
1740    (truncate nnheader-read-timeout)
1741    (truncate (* (- nnheader-read-timeout
1742                    (truncate nnheader-read-timeout))
1743                 1000))))
1744
1745 (when (featurep 'xemacs)
1746   (require 'nnheaderxm))
1747
1748 (run-hooks 'nnheader-load-hook)
1749
1750 (provide 'nnheader)
1751
1752 ;;; nnheader.el ends here