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