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