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

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