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