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