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

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