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
   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
  54 (defcustom gnus-verbose-backends 7
  55   "Integer that says how verbose the Gnus backends should be.
  56 The higher the number, the more messages the Gnus backends will flash
  57 to say what it's doing.  At zero, the Gnus backends will be totally
  58 mute; at five, they will display most important messages; and at ten,
  59 they will keep on jabbering all the time."
  60   :group 'gnus-start
  61   :type 'integer)
  62
  63 (defcustom gnus-nov-is-evil nil
  64   "If non-nil, Gnus backends will never output headers in the NOV format."
  65   :group 'gnus-server
  66   :type 'boolean)
  67
  68 (defvar nnheader-max-head-length 4096
  69   "*Max length of the head of articles.
  70
  71 Value is an integer, nil, or t.  Nil means read in chunks of a file
  72 indefinitely until a complete head is found\; t means always read the
  73 entire file immediately, disregarding `nnheader-head-chop-length'.
  74
  75 Integer values will in effect be rounded up to the nearest multiple of
  76 `nnheader-head-chop-length'.")
  77
  78 (defvar nnheader-head-chop-length 2048
  79   "*Length of each read operation when trying to fetch HEAD headers.")
  80
  81 (defvar nnheader-file-name-translation-alist nil
  82   "*Alist that says how to translate characters in file names.
  83 For instance, if \":\" is invalid as a file character in file names
  84 on your system, you could say something like:
  85
  86 \(setq nnheader-file-name-translation-alist '((?: . ?_)))")
  87
  88 (defvar nnheader-text-coding-system
  89   (if (memq system-type '(windows-nt ms-dos ms-windows))
  90       'raw-text-dos
  91     'raw-text)
  92   "Text-safe coding system (For removing ^M).
  93 This variable is a substitute for `mm-text-coding-system'.")
  94
  95 (defvar nnheader-text-coding-system-for-write nil
  96   "Text coding system for write.
  97 This variable is a substitute for `mm-text-coding-system-for-write'.")
  98
  99 (eval-and-compile
 100   (autoload 'nnmail-message-id "nnmail")
 101   (autoload 'mail-position-on-field "sendmail")
 102   (autoload 'message-remove-header "message")
 103   (autoload 'gnus-point-at-eol "gnus-util")
 104   (autoload 'gnus-delete-line "gnus-util" nil nil 'macro)
 105   (autoload 'gnus-buffer-live-p "gnus-util"))
 106
 107 ;;; Header access macros.
 108
 109 ;; These macros may look very much like the ones in GNUS 4.1.  They
 110 ;; are, in a way, but you should note that the indices they use have
 111 ;; been changed from the internal GNUS format to the NOV format.  The
 112 ;; makes it possible to read headers from XOVER much faster.
 113 ;;
 114 ;; The format of a header is now:
 115 ;; [number subject from date id references chars lines xref extra]
 116 ;;
 117 ;; (That next-to-last entry is defined as "misc" in the NOV format,
 118 ;; but Gnus uses it for xrefs.)
 119
 120 (require 'mmgnus)
 121
 122 (defmacro mail-header-number (header)
 123   "Return article number in HEADER."
 124   `(mime-entity-location-internal ,header))
 125
 126 (defmacro mail-header-set-number (header number)
 127   "Set article number of HEADER to NUMBER."
 128   `(mime-entity-set-location-internal ,header ,number))
 129
 130 (defalias 'mail-header-subject 'mime-gnus-entity-subject-internal)
 131 (defalias 'mail-header-set-subject 'mime-gnus-entity-set-subject-internal)
 132
 133 (defalias 'mail-header-from 'mime-gnus-entity-from-internal)
 134 (defalias 'mail-header-set-from 'mime-gnus-entity-set-from-internal)
 135
 136 (defalias 'mail-header-date 'mime-gnus-entity-date-internal)
 137 (defalias 'mail-header-set-date 'mime-gnus-entity-set-date-internal)
 138
 139 (defalias 'mail-header-message-id 'mime-gnus-entity-id-internal)
 140 (defalias 'mail-header-id 'mime-gnus-entity-id-internal)
 141 (defalias 'mail-header-set-message-id 'mime-gnus-entity-set-id-internal)
 142 (defalias 'mail-header-set-id 'mime-gnus-entity-set-id-internal)
 143
 144 (defalias 'mail-header-references 'mime-gnus-entity-references-internal)
 145 (defalias 'mail-header-set-references
 146   'mime-gnus-entity-set-references-internal)
 147
 148 (defalias 'mail-header-chars 'mime-gnus-entity-chars-internal)
 149 (defalias 'mail-header-set-chars 'mime-gnus-entity-set-chars-internal)
 150
 151 (defalias 'mail-header-lines 'mime-gnus-entity-lines-internal)
 152 (defalias 'mail-header-set-lines 'mime-gnus-entity-set-lines-internal)
 153
 154 (defalias 'mail-header-xref 'mime-gnus-entity-xref-internal)
 155 (defalias 'mail-header-set-xref 'mime-gnus-entity-set-xref-internal)
 156
 157 (defalias 'nnheader-decode-subject
 158   (mime-find-field-decoder 'Subject 'nov))
 159 (defalias 'nnheader-decode-from
 160   (mime-find-field-decoder 'From 'nov))
 161
 162 (defalias 'mail-header-extra 'mime-gnus-entity-extra-internal)
 163 (defalias 'mail-header-set-extra 'mime-gnus-entity-set-extra-internal)
 164
 165 (defun nnheader-decode-field-body (field-body field-name
 166                                               &optional mode max-column)
 167   (mime-decode-field-body field-body
 168                           (if (stringp field-name)
 169                               (intern (capitalize field-name))
 170                             field-name)
 171                           mode max-column))
 172
 173 (defsubst make-full-mail-header (&optional number subject from date id
 174                                            references chars lines xref
 175                                            extra)
 176   "Create a new mail header structure initialized with the parameters given."
 177   (luna-make-entity (mm-expand-class-name 'gnus)
 178                     :location number
 179                     :subject (if subject
 180                                  (nnheader-decode-subject subject))
 181                     :from (if from
 182                               (nnheader-decode-from from))
 183                     :date date
 184                     :id id
 185                     :references references
 186                     :chars chars
 187                     :lines lines
 188                     :xref xref
 189                     :original-header (list (cons 'Subject subject)
 190                                            (cons 'From from))
 191                     :extra extra))
 192
 193 (defsubst make-full-mail-header-from-decoded-header
 194   (&optional number subject from date id references chars lines xref extra)
 195   "Create a new mail header structure initialized with the parameters given."
 196   (luna-make-entity (mm-expand-class-name 'gnus)
 197                     :location number
 198                     :subject subject
 199                     :from from
 200                     :date date
 201                     :id id
 202                     :references references
 203                     :chars chars
 204                     :lines lines
 205                     :xref xref
 206                     :extra extra))
 207
 208 (defsubst make-mail-header (&optional init)
 209   "Create a new mail header structure initialized with INIT."
 210   (make-full-mail-header init init init init init
 211                          init init init init init))
 212
 213 ;; fake message-ids: generation and detection
 214
 215 (defvar nnheader-fake-message-id 1)
 216
 217 (defsubst nnheader-generate-fake-message-id ()
 218   (concat "fake+none+" (int-to-string (incf nnheader-fake-message-id))))
 219
 220 (defsubst nnheader-fake-message-id-p (id)
 221   (save-match-data                      ; regular message-id's are <.*>
 222     (string-match "\\`fake\\+none\\+[0-9]+\\'" id)))
 223
 224 ;; Parsing headers and NOV lines.
 225
 226 (defsubst nnheader-header-value ()
 227   (let ((pt (point)))
 228     (prog2
 229         (skip-chars-forward " \t")
 230         (buffer-substring (point) (std11-field-end))
 231       (goto-char pt))))
 232
 233 (defun nnheader-parse-head (&optional naked)
 234   (let ((case-fold-search t)
 235         (cur (current-buffer))
 236         (buffer-read-only nil)
 237         in-reply-to lines p ref)
 238     (goto-char (point-min))
 239     (when naked
 240       (insert "\n"))
 241     ;; Search to the beginning of the next header.  Error messages
 242     ;; do not begin with 2 or 3.
 243     (prog1
 244         (when (or naked (re-search-forward "^[23][0-9]+ " nil t))
 245           ;; This implementation of this function, with nine
 246           ;; search-forwards instead of the one re-search-forward and
 247           ;; a case (which basically was the old function) is actually
 248           ;; about twice as fast, even though it looks messier.  You
 249           ;; can't have everything, I guess.  Speed and elegance
 250           ;; don't always go hand in hand.
 251           (make-full-mail-header
 252            ;; Number.
 253            (if naked
 254                (progn
 255                  (setq p (point-min))
 256                  0)
 257              (prog1
 258                  (read cur)
 259                (end-of-line)
 260                (setq p (point))
 261                (narrow-to-region (point)
 262                                  (or (and (search-forward "\n.\n" nil t)
 263                                           (- (point) 2))
 264                                      (point)))))
 265            ;; Subject.
 266            (progn
 267              (goto-char p)
 268              (if (search-forward "\nsubject:" nil t)
 269                  (nnheader-header-value) "(none)"))
 270            ;; From.
 271            (progn
 272              (goto-char p)
 273              (if (search-forward "\nfrom:" nil t)
 274                  (nnheader-header-value) "(nobody)"))
 275            ;; Date.
 276            (progn
 277              (goto-char p)
 278              (if (search-forward "\ndate:" nil t)
 279                  (nnheader-header-value) ""))
 280            ;; Message-ID.
 281            (progn
 282              (goto-char p)
 283              (if (search-forward "\nmessage-id:" nil t)
 284                  (buffer-substring
 285                   (1- (or (search-forward "<" (gnus-point-at-eol) t)
 286                           (point)))
 287                   (or (search-forward ">" (gnus-point-at-eol) t) (point)))
 288                ;; If there was no message-id, we just fake one to make
 289                ;; subsequent routines simpler.
 290                (nnheader-generate-fake-message-id)))
 291            ;; References.
 292            (progn
 293              (goto-char p)
 294              (if (search-forward "\nreferences:" nil t)
 295                  (nnheader-header-value)
 296                ;; Get the references from the in-reply-to header if there
 297                ;; were no references and the in-reply-to header looks
 298                ;; promising.
 299                (if (and (search-forward "\nin-reply-to:" nil t)
 300                         (setq in-reply-to (nnheader-header-value))
 301                         (string-match "<[^\n>]+>" in-reply-to))
 302                    (let (ref2)
 303                      (setq ref (substring in-reply-to (match-beginning 0)
 304                                           (match-end 0)))
 305                      (while (string-match "<[^\n>]+>"
 306                                           in-reply-to (match-end 0))
 307                        (setq ref2 (substring in-reply-to (match-beginning 0)
 308                                              (match-end 0)))
 309                        (when (> (length ref2) (length ref))
 310                          (setq ref ref2)))
 311                      ref)
 312                  nil)))
 313            ;; Chars.
 314            0
 315            ;; Lines.
 316            (progn
 317              (goto-char p)
 318              (if (search-forward "\nlines: " nil t)
 319                  (if (numberp (setq lines (read cur)))
 320                      lines 0)
 321                0))
 322            ;; Xref.
 323            (progn
 324              (goto-char p)
 325              (and (search-forward "\nxref:" nil t)
 326                   (nnheader-header-value)))
 327
 328            ;; Extra.
 329            (when nnmail-extra-headers
 330              (let ((extra nnmail-extra-headers)
 331                    out)
 332                (while extra
 333                  (goto-char p)
 334                  (when (search-forward
 335                         (concat "\n" (symbol-name (car extra)) ":") nil t)
 336                    (push (cons (car extra) (nnheader-header-value))
 337                          out))
 338                  (pop extra))
 339                out))))
 340       (when naked
 341         (goto-char (point-min))
 342         (delete-char 1)))))
 343
 344 (defmacro nnheader-nov-skip-field ()
 345   '(search-forward "\t" eol 'move))
 346
 347 (defmacro nnheader-nov-field ()
 348   '(buffer-substring (point) (if (nnheader-nov-skip-field) (1- (point)) eol)))
 349
 350 (defmacro nnheader-nov-read-integer ()
 351   '(prog1
 352        (if (eq (char-after) ?\t)
 353            0
 354          (let ((num (condition-case nil
 355                         (read (current-buffer))
 356                       (error nil))))
 357            (if (numberp num) num 0)))
 358      (unless (eobp)
 359        (search-forward "\t" eol 'move))))
 360
 361 (defmacro nnheader-nov-parse-extra ()
 362   '(let (out string)
 363      (while (not (memq (char-after) '(?\n nil)))
 364        (setq string (nnheader-nov-field))
 365        (when (string-match "^\\([^ :]+\\): " string)
 366          (push (cons (intern (match-string 1 string))
 367                      (substring string (match-end 0)))
 368                out)))
 369      out))
 370
 371 (defmacro nnheader-nov-read-message-id ()
 372   '(let ((id (nnheader-nov-field)))
 373      (if (string-match "^<[^>]+>$" id)
 374          id
 375        (nnheader-generate-fake-message-id))))
 376
 377 (defun nnheader-parse-nov ()
 378   (let ((eol (gnus-point-at-eol)))
 379     (make-full-mail-header
 380      (nnheader-nov-read-integer)        ; number
 381      (nnheader-nov-field)               ; subject
 382      (nnheader-nov-field)               ; from
 383      (nnheader-nov-field)               ; date
 384      (nnheader-nov-read-message-id)     ; id
 385      (nnheader-nov-field)               ; refs
 386      (nnheader-nov-read-integer)        ; chars
 387      (nnheader-nov-read-integer)        ; lines
 388      (if (eq (char-after) ?\n)
 389          nil
 390        (if (looking-at "Xref: ")
 391            (goto-char (match-end 0)))
 392        (nnheader-nov-field))            ; Xref
 393      (nnheader-nov-parse-extra))))      ; extra
 394
 395 (defun nnheader-insert-nov (header)
 396   (princ (mail-header-number header) (current-buffer))
 397   (let ((p (point)))
 398     (insert
 399      "\t"
 400      (or (mime-entity-fetch-field header 'Subject) "(none)") "\t"
 401      (or (mime-entity-fetch-field header 'From) "(nobody)") "\t"
 402      (or (mail-header-date header) "") "\t"
 403      (or (mail-header-id header)
 404          (nnmail-message-id))
 405      "\t"
 406      (or (mail-header-references header) "") "\t")
 407     (princ (or (mail-header-chars header) 0) (current-buffer))
 408     (insert "\t")
 409     (princ (or (mail-header-lines header) 0) (current-buffer))
 410     (insert "\t")
 411     (when (mail-header-xref header)
 412       (insert "Xref: " (mail-header-xref header)))
 413     (when (or (mail-header-xref header)
 414               (mail-header-extra header))
 415       (insert "\t"))
 416     (when (mail-header-extra header)
 417       (let ((extra (mail-header-extra header)))
 418         (while extra
 419           (insert (symbol-name (caar extra))
 420                   ": " (cdar extra) "\t")
 421           (pop extra))))
 422     (insert "\n")
 423     (backward-char 1)
 424     (while (search-backward "\n" p t)
 425       (delete-char 1))
 426     (forward-line 1)))
 427
 428 (defun nnheader-insert-header (header)
 429   (insert
 430    "Subject: " (or (mail-header-subject header) "(none)") "\n"
 431    "From: " (or (mail-header-from header) "(nobody)") "\n"
 432    "Date: " (or (mail-header-date header) "") "\n"
 433    "Message-ID: " (or (mail-header-id header) (nnmail-message-id)) "\n"
 434    "References: " (or (mail-header-references header) "") "\n"
 435    "Lines: ")
 436   (princ (or (mail-header-lines header) 0) (current-buffer))
 437   (insert "\n\n"))
 438
 439 (defun nnheader-insert-article-line (article)
 440   (goto-char (point-min))
 441   (insert "220 ")
 442   (princ article (current-buffer))
 443   (insert " Article retrieved.\n")
 444   (search-forward "\n\n" nil 'move)
 445   (delete-region (point) (point-max))
 446   (forward-char -1)
 447   (insert "."))
 448
 449 (defun nnheader-nov-delete-outside-range (beg end)
 450   "Delete all NOV lines that lie outside the BEG to END range."
 451   ;; First we find the first wanted line.
 452   (nnheader-find-nov-line beg)
 453   (delete-region (point-min) (point))
 454   ;; Then we find the last wanted line.
 455   (when (nnheader-find-nov-line end)
 456     (forward-line 1))
 457   (delete-region (point) (point-max)))
 458
 459 (defun nnheader-find-nov-line (article)
 460   "Put point at the NOV line that start with ARTICLE.
 461 If ARTICLE doesn't exist, put point where that line
 462 would have been.  The function will return non-nil if
 463 the line could be found."
 464   ;; This function basically does a binary search.
 465   (let ((max (point-max))
 466         (min (goto-char (point-min)))
 467         (cur (current-buffer))
 468         (prev (point-min))
 469         num found)
 470     (while (not found)
 471       (goto-char (/ (+ max min) 2))
 472       (beginning-of-line)
 473       (if (or (= (point) prev)
 474               (eobp))
 475           (setq found t)
 476         (setq prev (point))
 477         (while (and (not (numberp (setq num (read cur))))
 478                     (not (eobp)))
 479           (gnus-delete-line))
 480         (cond ((> num article)
 481                (setq max (point)))
 482               ((< num article)
 483                (setq min (point)))
 484               (t
 485                (setq found 'yes)))))
 486     ;; We may be at the first line.
 487     (when (and (not num)
 488                (not (eobp)))
 489       (setq num (read cur)))
 490     ;; Now we may have found the article we're looking for, or we
 491     ;; may be somewhere near it.
 492     (when (and (not (eq found 'yes))
 493                (not (eq num article)))
 494       (setq found (point))
 495       (while (and (< (point) max)
 496                   (or (not (numberp num))
 497                       (< num article)))
 498         (forward-line 1)
 499         (setq found (point))
 500         (or (eobp)
 501             (= (setq num (read cur)) article)))
 502       (unless (eq num article)
 503         (goto-char found)))
 504     (beginning-of-line)
 505     (eq num article)))
 506
 507 (defun nnheader-retrieve-headers-from-directory* (articles
 508                                                   directory dependencies
 509                                                   &optional
 510                                                   fetch-old force-new large
 511                                                   backend)
 512   (with-temp-buffer
 513     (let* ((file nil)
 514            (number (length articles))
 515            (count 0)
 516            (file-name-coding-system 'binary)
 517            (pathname-coding-system 'binary)
 518            (case-fold-search t)
 519            (cur (current-buffer))
 520            article
 521            headers header id end ref in-reply-to lines chars ctype)
 522       ;; We don't support fetching by Message-ID.
 523       (if (stringp (car articles))
 524           'headers
 525         (while articles
 526           (when (and (file-exists-p
 527                       (setq file (expand-file-name
 528                                   (int-to-string
 529                                    (setq article (pop articles)))
 530                                   directory)))
 531                      (not (file-directory-p file)))
 532             (erase-buffer)
 533             (nnheader-insert-head file)
 534             (save-restriction
 535               (std11-narrow-to-header)
 536               (setq
 537                header
 538                (make-full-mail-header
 539                 ;; Number.
 540                 article
 541                 ;; Subject.
 542                 (or (std11-fetch-field "Subject")
 543                     "(none)")
 544                 ;; From.
 545                 (or (std11-fetch-field "From")
 546                     "(nobody)")
 547                 ;; Date.
 548                 (or (std11-fetch-field "Date")
 549                     "")
 550                 ;; Message-ID.
 551                 (progn
 552                   (goto-char (point-min))
 553                   (setq id (if (re-search-forward
 554                                 "^Message-ID: *\\(<[^\n\t> ]+>\\)" nil t)
 555                                ;; We do it this way to make sure the Message-ID
 556                                ;; is (somewhat) syntactically valid.
 557                                (buffer-substring (match-beginning 1)
 558                                                  (match-end 1))
 559                              ;; If there was no message-id, we just fake one
 560                              ;; to make subsequent routines simpler.
 561                              (nnheader-generate-fake-message-id))))
 562                 ;; References.
 563                 (progn
 564                   (goto-char (point-min))
 565                   (if (search-forward "\nReferences: " nil t)
 566                       (progn
 567                         (setq end (point))
 568                         (prog1
 569                             (buffer-substring (match-end 0) (std11-field-end))
 570                           (setq ref
 571                                 (buffer-substring
 572                                  (progn
 573                                    ;; (end-of-line)
 574                                    (search-backward ">" end t)
 575                                    (1+ (point)))
 576                                  (progn
 577                                    (search-backward "<" end t)
 578                                    (point))))))
 579                     ;; Get the references from the in-reply-to header if there
 580                     ;; were no references and the in-reply-to header looks
 581                     ;; promising.
 582                     (if (and (search-forward "\nIn-Reply-To: " nil t)
 583                              (setq in-reply-to
 584                                    (buffer-substring (match-end 0)
 585                                                      (std11-field-end)))
 586                              (string-match "<[^>]+>" in-reply-to))
 587                         (let (ref2)
 588                           (setq ref (substring in-reply-to (match-beginning 0)
 589                                                (match-end 0)))
 590                           (while (string-match "<[^>]+>"
 591                                                in-reply-to (match-end 0))
 592                             (setq ref2
 593                                   (substring in-reply-to (match-beginning 0)
 594                                              (match-end 0)))
 595                             (when (> (length ref2) (length ref))
 596                               (setq ref ref2)))
 597                           ref)
 598                       (setq ref nil))))
 599                 ;; Chars.
 600                 (progn
 601                   (goto-char (point-min))
 602                   (if (search-forward "\nChars: " nil t)
 603                       (if (numberp (setq chars (ignore-errors (read cur))))
 604                           chars 0)
 605                     0))
 606                 ;; Lines.
 607                 (progn
 608                   (goto-char (point-min))
 609                   (if (search-forward "\nLines: " nil t)
 610                       (if (numberp (setq lines (ignore-errors (read cur))))
 611                           lines 0)
 612                     0))
 613                 ;; Xref.
 614                 (std11-fetch-field "Xref")
 615                 ))
 616               (goto-char (point-min))
 617               (if (setq ctype (std11-fetch-field "Content-Type"))
 618                   (mime-entity-set-content-type-internal
 619                    header (mime-parse-Content-Type ctype)))
 620               )
 621             (when (setq header
 622                         (gnus-dependencies-add-header
 623                          header dependencies force-new))
 624               (push header headers))
 625             )
 626           (setq count (1+ count))
 627
 628           (and large
 629                (zerop (% count 20))
 630                (nnheader-message 5 "%s: Receiving headers... %d%%"
 631                                  backend
 632                                  (/ (* count 100) number))))
 633
 634         (when large
 635           (nnheader-message 5 "%s: Receiving headers...done" backend))
 636
 637         headers))))
 638
 639 (defun nnheader-retrieve-headers-from-directory (articles
 640                                                  directory dependencies
 641                                                  &optional
 642                                                  fetch-old force-new large
 643                                                  backend)
 644   (cons 'header
 645         (nreverse (nnheader-retrieve-headers-from-directory*
 646                    articles directory dependencies
 647                    fetch-old force-new large backend))))
 648
 649 (defun nnheader-get-newsgroup-headers-xover* (sequence
 650                                               &optional
 651                                               force-new dependencies
 652                                               group)
 653   "Parse the news overview data in the server buffer, and return a
 654 list of headers that match SEQUENCE (see `nntp-retrieve-headers')."
 655   ;; Get the Xref when the users reads the articles since most/some
 656   ;; NNTP servers do not include Xrefs when using XOVER.
 657   ;; (setq gnus-article-internal-prepare-hook '(gnus-article-get-xrefs))
 658   (let ((cur nntp-server-buffer)
 659         number headers header)
 660     (save-excursion
 661       (set-buffer nntp-server-buffer)
 662       ;; Allow the user to mangle the headers before parsing them.
 663       (gnus-run-hooks 'gnus-parse-headers-hook)
 664       (goto-char (point-min))
 665       (while (not (eobp))
 666         (condition-case ()
 667             (while (and sequence (not (eobp)))
 668               (setq number (read cur))
 669               (while (and sequence
 670                           (< (car sequence) number))
 671                 (setq sequence (cdr sequence)))
 672               (and sequence
 673                    (eq number (car sequence))
 674                    (progn
 675                      (setq sequence (cdr sequence))
 676                      (setq header (inline
 677                                     (gnus-nov-parse-line
 678                                      number dependencies force-new))))
 679                    (push header headers))
 680               (forward-line 1))
 681           (error
 682            (gnus-error 4 "Strange nov line (%d)"
 683                        (count-lines (point-min) (point)))))
 684         (forward-line 1))
 685       ;; A common bug in inn is that if you have posted an article and
 686       ;; then retrieves the active file, it will answer correctly --
 687       ;; the new article is included.  However, a NOV entry for the
 688       ;; article may not have been generated yet, so this may fail.
 689       ;; We work around this problem by retrieving the last few
 690       ;; headers using HEAD.
 691       headers)))
 692
 693 ;; Various cruft the backends and Gnus need to communicate.
 694
 695 (defvar nntp-server-buffer nil)
 696 (defvar nntp-process-response nil)
 697 (defvar news-reply-yank-from nil)
 698 (defvar news-reply-yank-message-id nil)
 699
 700 (defvar nnheader-callback-function nil)
 701
 702 (defun nnheader-init-server-buffer ()
 703   "Initialize the Gnus-backend communication buffer."
 704   (save-excursion
 705     (unless (gnus-buffer-live-p nntp-server-buffer)
 706       (setq nntp-server-buffer (get-buffer-create " *nntpd*")))
 707     (set-buffer nntp-server-buffer)
 708     (erase-buffer)
 709     (kill-all-local-variables)
 710     (setq case-fold-search t)           ;Should ignore case.
 711     (set (make-local-variable 'nntp-process-response) nil)
 712     t))
 713
 714 ;;; Various functions the backends use.
 715
 716 (defun nnheader-file-error (file)
 717   "Return a string that says what is wrong with FILE."
 718   (format
 719    (cond
 720     ((not (file-exists-p file))
 721      "%s does not exist")
 722     ((file-directory-p file)
 723      "%s is a directory")
 724     ((not (file-readable-p file))
 725      "%s is not readable"))
 726    file))
 727
 728 (defun nnheader-insert-head (file)
 729   "Insert the head of the article."
 730   (when (file-exists-p file)
 731     (if (eq nnheader-max-head-length t)
 732         ;; Just read the entire file.
 733         (nnheader-insert-file-contents file)
 734       ;; Read 1K blocks until we find a separator.
 735       (let ((beg 0)
 736             format-alist)
 737         (while (and (eq nnheader-head-chop-length
 738                         (nth 1 (nnheader-insert-file-contents
 739                                 file nil beg
 740                                 (incf beg nnheader-head-chop-length))))
 741                     (prog1 (not (search-forward "\n\n" nil t))
 742                       (goto-char (point-max)))
 743                     (or (null nnheader-max-head-length)
 744                         (< beg nnheader-max-head-length))))))
 745     t))
 746
 747 (defun nnheader-article-p ()
 748   "Say whether the current buffer looks like an article."
 749   (goto-char (point-min))
 750   (if (not (search-forward "\n\n" nil t))
 751       nil
 752     (narrow-to-region (point-min) (1- (point)))
 753     (goto-char (point-min))
 754     (while (looking-at "[a-zA-Z][^ \t]+:.*\n\\([ \t].*\n\\)*\\|From .*\n")
 755       (goto-char (match-end 0)))
 756     (prog1
 757         (eobp)
 758       (widen))))
 759
 760 (defun nnheader-insert-references (references message-id)
 761   "Insert a References header based on REFERENCES and MESSAGE-ID."
 762   (if (and (not references) (not message-id))
 763       ;; This is invalid, but not all articles have Message-IDs.
 764       ()
 765     (mail-position-on-field "References")
 766     (let ((begin (save-excursion (beginning-of-line) (point)))
 767           (fill-column 78)
 768           (fill-prefix "\t"))
 769       (when references
 770         (insert references))
 771       (when (and references message-id)
 772         (insert " "))
 773       (when message-id
 774         (insert message-id))
 775       ;; Fold long References lines to conform to RFC1036 (sort of).
 776       ;; The region must end with a newline to fill the region
 777       ;; without inserting extra newline.
 778       (fill-region-as-paragraph begin (1+ (point))))))
 779
 780 (defun nnheader-replace-header (header new-value)
 781   "Remove HEADER and insert the NEW-VALUE."
 782   (save-excursion
 783     (save-restriction
 784       (nnheader-narrow-to-headers)
 785       (prog1
 786           (message-remove-header header)
 787         (goto-char (point-max))
 788         (insert header ": " new-value "\n")))))
 789
 790 (defun nnheader-narrow-to-headers ()
 791   "Narrow to the head of an article."
 792   (widen)
 793   (narrow-to-region
 794    (goto-char (point-min))
 795    (if (search-forward "\n\n" nil t)
 796        (1- (point))
 797      (point-max)))
 798   (goto-char (point-min)))
 799
 800 (defun nnheader-set-temp-buffer (name &optional noerase)
 801   "Set-buffer to an empty (possibly new) buffer called NAME with undo disabled."
 802   (set-buffer (get-buffer-create name))
 803   (buffer-disable-undo)
 804   (unless noerase
 805     (erase-buffer))
 806   (current-buffer))
 807
 808 (eval-when-compile (defvar jka-compr-compression-info-list))
 809 (defvar nnheader-numerical-files
 810   (if (boundp 'jka-compr-compression-info-list)
 811       (concat "\\([0-9]+\\)\\("
 812               (mapconcat (lambda (i) (aref i 0))
 813                          jka-compr-compression-info-list "\\|")
 814               "\\)?")
 815     "[0-9]+$")
 816   "Regexp that match numerical files.")
 817
 818 (defvar nnheader-numerical-short-files (concat "^" nnheader-numerical-files)
 819   "Regexp that matches numerical file names.")
 820
 821 (defvar nnheader-numerical-full-files (concat "/" nnheader-numerical-files)
 822   "Regexp that matches numerical full file paths.")
 823
 824 (defsubst nnheader-file-to-number (file)
 825   "Take a FILE name and return the article number."
 826   (if (string= nnheader-numerical-short-files "^[0-9]+$")
 827       (string-to-int file)
 828     (string-match nnheader-numerical-short-files file)
 829     (string-to-int (match-string 0 file))))
 830
 831 (defvar nnheader-directory-files-is-safe
 832   (or (eq system-type 'windows-nt)
 833       (and (not (featurep 'xemacs))
 834            (> emacs-major-version 20)))
 835   "If non-nil, Gnus believes `directory-files' is safe.
 836 It has been reported numerous times that `directory-files' fails with
 837 an alarming frequency on NFS mounted file systems. If it is nil,
 838 `nnheader-directory-files-safe' is used.")
 839
 840 (defun nnheader-directory-files-safe (&rest args)
 841   "Execute `directory-files' twice and returns the longer result."
 842   (let ((first (apply 'directory-files args))
 843         (second (apply 'directory-files args)))
 844     (if (> (length first) (length second))
 845         first
 846       second)))
 847
 848 (defun nnheader-directory-articles (dir)
 849   "Return a list of all article files in directory DIR."
 850   (mapcar 'nnheader-file-to-number
 851           (if nnheader-directory-files-is-safe
 852               (directory-files
 853                dir nil nnheader-numerical-short-files t)
 854             (nnheader-directory-files-safe
 855              dir nil nnheader-numerical-short-files t))))
 856
 857 (defun nnheader-article-to-file-alist (dir)
 858   "Return an alist of article/file pairs in DIR."
 859   (mapcar (lambda (file) (cons (nnheader-file-to-number file) file))
 860           (if nnheader-directory-files-is-safe
 861               (directory-files
 862                dir nil nnheader-numerical-short-files t)
 863             (nnheader-directory-files-safe
 864              dir nil nnheader-numerical-short-files t))))
 865
 866 (defun nnheader-fold-continuation-lines ()
 867   "Fold continuation lines in the current buffer."
 868   (nnheader-replace-regexp "\\(\r?\n[ \t]+\\)+" " "))
 869
 870 (defun nnheader-translate-file-chars (file &optional full)
 871   "Translate FILE into something that can be a file name.
 872 If FULL, translate everything."
 873   (if (null nnheader-file-name-translation-alist)
 874       ;; No translation is necessary.
 875       file
 876     (let* ((i 0)
 877            trans leaf path len)
 878       (if full
 879           ;; Do complete translation.
 880           (setq leaf (copy-sequence file)
 881                 path ""
 882                 i (if (and (< 1 (length leaf)) (eq ?: (aref leaf 1)))
 883                       2 0))
 884         ;; We translate -- but only the file name.  We leave the directory
 885         ;; alone.
 886         (if (and (featurep 'xemacs)
 887                  (memq system-type '(cygwin32 win32 w32 mswindows windows-nt)))
 888             ;; This is needed on NT and stuff, because
 889             ;; file-name-nondirectory is not enough to split
 890             ;; file names, containing ':', e.g.
 891             ;; "d:\\Work\\News\\nntp+news.fido7.ru:fido7.ru.gnu.SCORE"
 892             ;;
 893             ;; we are trying to correctly split such names:
 894             ;; "d:file.name" -> "a:" "file.name"
 895             ;; "aaa:bbb.ccc" -> "" "aaa:bbb.ccc"
 896             ;; "d:aaa\\bbb:ccc"   -> "d:aaa\\" "bbb:ccc"
 897             ;; etc.
 898             ;; to translate then only the file name part.
 899             (progn
 900               (setq leaf file
 901                     path "")
 902               (if (string-match "\\(^\\w:\\|[/\\]\\)\\([^/\\]+\\)$" file)
 903                   (setq leaf (substring file (match-beginning 2))
 904                         path (substring file 0 (match-beginning 2)))))
 905           ;; Emacs DTRT, says andrewi.
 906           (setq leaf (file-name-nondirectory file)
 907                 path (file-name-directory file))))
 908       (setq len (length leaf))
 909       (while (< i len)
 910         (when (setq trans (cdr (assq (aref leaf i)
 911                                      nnheader-file-name-translation-alist)))
 912           (aset leaf i trans))
 913         (incf i))
 914       (concat path leaf))))
 915
 916 (defun nnheader-report (backend &rest args)
 917   "Report an error from the BACKEND.
 918 The first string in ARGS can be a format string."
 919   (set (intern (format "%s-status-string" backend))
 920        (if (< (length args) 2)
 921            (car args)
 922          (apply 'format args)))
 923   nil)
 924
 925 (defun nnheader-get-report (backend)
 926   "Get the most recent report from BACKEND."
 927   (condition-case ()
 928       (nnheader-message 5 "%s" (symbol-value (intern (format "%s-status-string"
 929                                                              backend))))
 930     (error (nnheader-message 5 ""))))
 931
 932 (defun nnheader-insert (format &rest args)
 933   "Clear the communication buffer and insert FORMAT and ARGS into the buffer.
 934 If FORMAT isn't a format string, it and all ARGS will be inserted
 935 without formatting."
 936   (save-excursion
 937     (set-buffer nntp-server-buffer)
 938     (erase-buffer)
 939     (if (string-match "%" format)
 940         (insert (apply 'format format args))
 941       (apply 'insert format args))
 942     t))
 943
 944 (static-if (fboundp 'subst-char-in-string)
 945     (defsubst nnheader-replace-chars-in-string (string from to)
 946       (subst-char-in-string from to string))
 947   (defun nnheader-replace-chars-in-string (string from to)
 948     "Replace characters in STRING from FROM to TO."
 949     (let ((string (substring string 0)) ;Copy string.
 950           (len (length string))
 951           (idx 0))
 952       ;; Replace all occurrences of FROM with TO.
 953       (while (< idx len)
 954         (when (= (aref string idx) from)
 955           (aset string idx to))
 956         (setq idx (1+ idx)))
 957       string)))
 958
 959 (defun nnheader-replace-duplicate-chars-in-string (string from to)
 960   "Replace characters in STRING from FROM to TO."
 961   (let ((string (substring string 0))   ;Copy string.
 962         (len (length string))
 963         (idx 0) prev i)
 964     ;; Replace all occurrences of FROM with TO.
 965     (while (< idx len)
 966       (setq i (aref string idx))
 967       (when (and (eq prev from) (= i from))
 968         (aset string (1- idx) to)
 969         (aset string idx to))
 970       (setq prev i)
 971       (setq idx (1+ idx)))
 972     string))
 973
 974 (defun nnheader-file-to-group (file &optional top)
 975   "Return a group name based on FILE and TOP."
 976   (nnheader-replace-chars-in-string
 977    (if (not top)
 978        file
 979      (condition-case ()
 980          (substring (expand-file-name file)
 981                     (length
 982                      (expand-file-name
 983                       (file-name-as-directory top))))
 984        (error "")))
 985    ?/ ?.))
 986
 987 (defun nnheader-message (level &rest args)
 988   "Message if the Gnus backends are talkative."
 989   (if (or (not (numberp gnus-verbose-backends))
 990           (<= level gnus-verbose-backends))
 991       (apply 'message args)
 992     (apply 'format args)))
 993
 994 (defun nnheader-be-verbose (level)
 995   "Return whether the backends should be verbose on LEVEL."
 996   (or (not (numberp gnus-verbose-backends))
 997       (<= level gnus-verbose-backends)))
 998
 999 (defvar nnheader-pathname-coding-system 'binary
1000   "*Coding system for pathname.")
1001
1002 (defun nnheader-group-pathname (group dir &optional file)
1003   "Make pathname for GROUP."
1004   (concat
1005    (let ((dir (file-name-as-directory (expand-file-name dir))))
1006      ;; If this directory exists, we use it directly.
1007      (file-name-as-directory
1008       (if (file-directory-p (concat dir group))
1009           (expand-file-name group dir)
1010         ;; If not, we translate dots into slashes.
1011         (expand-file-name (encode-coding-string
1012                            (nnheader-replace-chars-in-string group ?. ?/)
1013                            nnheader-pathname-coding-system)
1014                           dir))))
1015    (cond ((null file) "")
1016          ((numberp file) (int-to-string file))
1017          (t file))))
1018
1019 (defun nnheader-functionp (form)
1020   "Return non-nil if FORM is funcallable."
1021   (or (and (symbolp form) (fboundp form))
1022       (and (listp form) (eq (car form) 'lambda))))
1023
1024 (defun nnheader-concat (dir &rest files)
1025   "Concat DIR as directory to FILES."
1026   (apply 'concat (file-name-as-directory dir) files))
1027
1028 (defun nnheader-ms-strip-cr ()
1029   "Strip ^M from the end of all lines."
1030   (save-excursion
1031     (goto-char (point-min))
1032     (while (re-search-forward "\r$" nil t)
1033       (delete-backward-char 1))))
1034
1035 (defun nnheader-file-size (file)
1036   "Return the file size of FILE or 0."
1037   (or (nth 7 (file-attributes file)) 0))
1038
1039 (defun nnheader-find-etc-directory (package &optional file)
1040   "Go through the path and find the \".../etc/PACKAGE\" directory.
1041 If FILE, find the \".../etc/PACKAGE\" file instead."
1042   (let ((path load-path)
1043         dir result)
1044     ;; We try to find the dir by looking at the load path,
1045     ;; stripping away the last component and adding "etc/".
1046     (while path
1047       (if (and (car path)
1048                (file-exists-p
1049                 (setq dir (concat
1050                            (file-name-directory
1051                             (directory-file-name (car path)))
1052                            "etc/" package
1053                            (if file "" "/"))))
1054                (or file (file-directory-p dir)))
1055           (setq result dir
1056                 path nil)
1057         (setq path (cdr path))))
1058     result))
1059
1060 (eval-when-compile
1061   (defvar ange-ftp-path-format)
1062   (defvar efs-path-regexp))
1063 (defun nnheader-re-read-dir (path)
1064   "Re-read directory PATH if PATH is on a remote system."
1065   (if (and (fboundp 'efs-re-read-dir) (boundp 'efs-path-regexp))
1066       (when (string-match efs-path-regexp path)
1067         (efs-re-read-dir path))
1068     (when (and (fboundp 'ange-ftp-re-read-dir) (boundp 'ange-ftp-path-format))
1069       (when (string-match (car ange-ftp-path-format) path)
1070         (ange-ftp-re-read-dir path)))))
1071
1072 (defvar nnheader-file-coding-system 'raw-text
1073   "Coding system used in file backends of Gnus.")
1074
1075 (defun nnheader-insert-file-contents (filename &optional visit beg end replace)
1076   "Like `insert-file-contents', q.v., but only reads in the file.
1077 A buffer may be modified in several ways after reading into the buffer due
1078 to advanced Emacs features, such as file-name-handlers, format decoding,
1079 find-file-hooks, etc.
1080   This function ensures that none of these modifications will take place."
1081   (let ((format-alist nil)
1082         (auto-mode-alist (nnheader-auto-mode-alist))
1083         (default-major-mode 'fundamental-mode)
1084         (enable-local-variables nil)
1085         (after-insert-file-functions nil)
1086         (enable-local-eval nil)
1087         (find-file-hooks nil))
1088     (insert-file-contents-as-coding-system
1089      nnheader-file-coding-system filename visit beg end replace)))
1090
1091 (defun nnheader-find-file-noselect (&rest args)
1092   (let ((format-alist nil)
1093         (auto-mode-alist (nnheader-auto-mode-alist))
1094         (default-major-mode 'fundamental-mode)
1095         (enable-local-variables nil)
1096         (after-insert-file-functions nil)
1097         (enable-local-eval nil)
1098         (find-file-hooks nil))
1099     (apply 'find-file-noselect-as-coding-system
1100            nnheader-file-coding-system args)))
1101
1102 (defun nnheader-auto-mode-alist ()
1103   "Return an `auto-mode-alist' with only the .gz (etc) thingies."
1104   (let ((alist auto-mode-alist)
1105         out)
1106     (while alist
1107       (when (listp (cdar alist))
1108         (push (car alist) out))
1109       (pop alist))
1110     (nreverse out)))
1111
1112 (defun nnheader-directory-regular-files (dir)
1113   "Return a list of all regular files in DIR."
1114   (let ((files (directory-files dir t))
1115         out)
1116     (while files
1117       (when (file-regular-p (car files))
1118         (push (car files) out))
1119       (pop files))
1120     (nreverse out)))
1121
1122 (defun nnheader-directory-files (&rest args)
1123   "Same as `directory-files', but prune \".\" and \"..\"."
1124   (let ((files (apply 'directory-files args))
1125         out)
1126     (while files
1127       (unless (member (file-name-nondirectory (car files)) '("." ".."))
1128         (push (car files) out))
1129       (pop files))
1130     (nreverse out)))
1131
1132 (defmacro nnheader-skeleton-replace (from &optional to regexp)
1133   `(let ((new (generate-new-buffer " *nnheader replace*"))
1134          (cur (current-buffer))
1135          (start (point-min)))
1136      (set-buffer cur)
1137      (goto-char (point-min))
1138      (while (,(if regexp 're-search-forward 'search-forward)
1139              ,from nil t)
1140        (insert-buffer-substring
1141         cur start (prog1 (match-beginning 0) (set-buffer new)))
1142        (goto-char (point-max))
1143        ,(when to `(insert ,to))
1144        (set-buffer cur)
1145        (setq start (point)))
1146      (insert-buffer-substring
1147       cur start (prog1 (point-max) (set-buffer new)))
1148      (copy-to-buffer cur (point-min) (point-max))
1149      (kill-buffer (current-buffer))
1150      (set-buffer cur)))
1151
1152 (defun nnheader-replace-string (from to)
1153   "Do a fast replacement of FROM to TO from point to `point-max'."
1154   (nnheader-skeleton-replace from to))
1155
1156 (defun nnheader-replace-regexp (from to)
1157   "Do a fast regexp replacement of FROM to TO from point to `point-max'."
1158   (nnheader-skeleton-replace from to t))
1159
1160 (defun nnheader-strip-cr ()
1161   "Strip all \r's from the current buffer."
1162   (nnheader-skeleton-replace "\r"))
1163
1164 (defalias 'nnheader-run-at-time 'run-at-time)
1165 (defalias 'nnheader-cancel-timer 'cancel-timer)
1166 (defalias 'nnheader-cancel-function-timers 'cancel-function-timers)
1167 (defalias 'nnheader-string-as-multibyte 'string-as-multibyte)
1168
1169 (defun nnheader-Y-or-n-p (prompt)
1170   "Ask user a \"Y/n\" question. Return t if answer is neither \"n\", \"N\" nor \"C-g\"."
1171   (let ((cursor-in-echo-area t)
1172         (echo-keystrokes 0)
1173         (inhibit-quit t)
1174         ans)
1175     (let (message-log-max)
1176       (while (not (memq ans '(?\  ?N ?Y ?\C-g ?\e ?\n ?\r ?n ?y)))
1177         (message "%s(Y/n) " prompt)
1178         (setq ans (read-char-exclusive))))
1179     (if (memq ans '(?\C-g ?N ?n))
1180         (progn
1181           (message "%s(Y/n) No" prompt)
1182           nil)
1183       (message "%s(Y/n) Yes" prompt)
1184       t)))
1185
1186 (defun nnheader-image-load-path (&optional package)
1187   (let (dir result)
1188     (dolist (path load-path (nreverse result))
1189       (if (file-directory-p
1190            (setq dir (concat (file-name-directory
1191                               (directory-file-name path))
1192                              "etc/" (or package "gnus/"))))
1193           (push dir result))
1194       (push path result))))
1195 (defalias 'mm-image-load-path 'nnheader-image-load-path)
1196
1197 (defalias 'mm-read-coding-system
1198   (if (or (and (featurep 'xemacs)
1199                (<= (string-to-number emacs-version) 21.1))
1200           (boundp 'MULE))
1201       (lambda (prompt &optional default-coding-system)
1202         (read-coding-system prompt))
1203     'read-coding-system))
1204
1205 (when (featurep 'xemacs)
1206   (require 'nnheaderxm))
1207
1208 (run-hooks 'nnheader-load-hook)
1209
1210 (provide 'nnheader)
1211
1212 ;;; nnheader.el ends here