cgit.sxemacs.org Git - gnus/blob - lisp/nnheader.el

   1 ;;; nnheader.el --- header access macros for Gnus and its backends
   2 ;; Copyright (C) 1987,88,89,90,93,94,95,96 Free Software Foundation, Inc.
   3
   4 ;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
   5 ;;      Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
   6 ;; Keywords: news
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Commentary:
  26
  27 ;; These macros may look very much like the ones in GNUS 4.1.  They
  28 ;; are, in a way, but you should note that the indices they use have
  29 ;; been changed from the internal GNUS format to the NOV format.  The
  30 ;; makes it possible to read headers from XOVER much faster.
  31 ;;
  32 ;; The format of a header is now:
  33 ;; [number subject from date id references chars lines xref]
  34 ;;
  35 ;; (That last entry is defined as "misc" in the NOV format, but Gnus
  36 ;; uses it for xrefs.)
  37
  38 ;;; Code:
  39
  40 (require 'mail-utils)
  41 (require 'sendmail)
  42 (require 'rmail)
  43 (eval-when-compile (require 'cl))
  44
  45 (defvar nnheader-max-head-length 4096
  46   "*Max length of the head of articles.")
  47
  48 (defvar nnheader-file-name-translation-alist nil
  49   "*Alist that says how to translate characters in file names.
  50 For instance, if \":\" is illegal as a file character in file names
  51 on your system, you could say something like:
  52
  53 \(setq nnheader-file-name-translation-alist '((?: . ?_)))")
  54
  55 ;;; Header access macros.
  56
  57 (defmacro mail-header-number (header)
  58   "Return article number in HEADER."
  59   `(aref ,header 0))
  60
  61 (defmacro mail-header-set-number (header number)
  62   "Set article number of HEADER to NUMBER."
  63   `(aset ,header 0 ,number))
  64
  65 (defmacro mail-header-subject (header)
  66   "Return subject string in HEADER."
  67   `(aref ,header 1))
  68
  69 (defmacro mail-header-set-subject (header subject)
  70   "Set article subject of HEADER to SUBJECT."
  71   `(aset ,header 1 ,subject))
  72
  73 (defmacro mail-header-from (header)
  74   "Return author string in HEADER."
  75   `(aref ,header 2))
  76
  77 (defmacro mail-header-set-from (header from)
  78   "Set article author of HEADER to FROM."
  79   `(aset ,header 2 ,from))
  80
  81 (defmacro mail-header-date (header)
  82   "Return date in HEADER."
  83   `(aref ,header 3))
  84
  85 (defmacro mail-header-set-date (header date)
  86   "Set article date of HEADER to DATE."
  87   `(aset ,header 3 ,date))
  88
  89 (defalias 'mail-header-message-id 'mail-header-id)
  90 (defmacro mail-header-id (header)
  91   "Return Id in HEADER."
  92   `(aref ,header 4))
  93
  94 (defalias 'mail-header-set-message-id 'mail-header-set-id)
  95 (defmacro mail-header-set-id (header id)
  96   "Set article Id of HEADER to ID."
  97   `(aset ,header 4 ,id))
  98
  99 (defmacro mail-header-references (header)
 100   "Return references in HEADER."
 101   `(aref ,header 5))
 102
 103 (defmacro mail-header-set-references (header ref)
 104   "Set article references of HEADER to REF."
 105   `(aset ,header 5 ,ref))
 106
 107 (defmacro mail-header-chars (header)
 108   "Return number of chars of article in HEADER."
 109   `(aref ,header 6))
 110
 111 (defmacro mail-header-set-chars (header chars)
 112   "Set number of chars in article of HEADER to CHARS."
 113   `(aset ,header 6 ,chars))
 114
 115 (defmacro mail-header-lines (header)
 116   "Return lines in HEADER."
 117   `(aref ,header 7))
 118
 119 (defmacro mail-header-set-lines (header lines)
 120   "Set article lines of HEADER to LINES."
 121   `(aset ,header 7 ,lines))
 122
 123 (defmacro mail-header-xref (header)
 124   "Return xref string in HEADER."
 125   `(aref ,header 8))
 126
 127 (defmacro mail-header-set-xref (header xref)
 128   "Set article xref of HEADER to xref."
 129   `(aset ,header 8 ,xref))
 130
 131 (defun make-mail-header (&optional init)
 132   "Create a new mail header structure initialized with INIT."
 133   (make-vector 9 init))
 134
 135 ;; Various cruft the backends and Gnus need to communicate.
 136
 137 (defvar nntp-server-buffer nil)
 138 (defvar gnus-verbose-backends 7
 139   "*A number that says how talkative the Gnus backends should be.")
 140 (defvar gnus-nov-is-evil nil
 141   "If non-nil, Gnus backends will never output headers in the NOV format.")
 142 (defvar news-reply-yank-from nil)
 143 (defvar news-reply-yank-message-id nil)
 144
 145 (defun nnheader-init-server-buffer ()
 146   "Initialize the Gnus-backend communication buffer."
 147   (save-excursion
 148     (setq nntp-server-buffer (get-buffer-create " *nntpd*"))
 149     (set-buffer nntp-server-buffer)
 150     (buffer-disable-undo (current-buffer))
 151     (erase-buffer)
 152     (kill-all-local-variables)
 153     (setq case-fold-search t)           ;Should ignore case.
 154     t))
 155
 156 ;;; Virtual server functions.
 157
 158 (defun nnheader-set-init-variables (server defs)
 159   (let ((s server)
 160         val)
 161     ;; First we set the server variables in the sequence required.  We
 162     ;; use the definitions from the `defs' list where that is
 163     ;; possible.
 164     (while s
 165       (set (car (car s))
 166            (if (setq val (assq (car (car s)) defs))
 167                (nth 1 val)
 168              (nth 1 (car s))))
 169       (setq s (cdr s)))
 170     ;; The we go through the defs list and set any variables that were
 171     ;; not set in the first sweep.
 172     (while defs
 173       (if (not (assq (car (car defs)) server))
 174           (set (car (car defs))
 175                (if (and (symbolp (nth 1 (car defs)))
 176                         (not (boundp (nth 1 (car defs)))))
 177                    (nth 1 (car defs))
 178                  (eval (nth 1 (car defs))))))
 179       (setq defs (cdr defs)))))
 180
 181 (defun nnheader-save-variables (server)
 182   (let (out)
 183     (while server
 184       (setq out (cons (list (car (car server))
 185                             (symbol-value (car (car server))))
 186                       out))
 187       (setq server (cdr server)))
 188     (nreverse out)))
 189
 190 (defun nnheader-restore-variables (state)
 191   (while state
 192     (set (car (car state)) (nth 1 (car state)))
 193     (setq state (cdr state))))
 194
 195 ;;; Various functions the backends use.
 196
 197 (defun nnheader-insert-head (file)
 198   "Insert the head of the article."
 199   (if (eq nnheader-max-head-length t)
 200       ;; Just read the entire file.
 201       (insert-file-contents-literally file)
 202     (let ((beg 0)
 203           (chop 1024))
 204       ;; Read 1K blocks until we find a separator.
 205       (while (and (eq chop (nth 1 (insert-file-contents-literally
 206                                    file nil beg (setq beg (+ chop beg)))))
 207                   (prog1 (not (search-backward "\n\n" nil t))
 208                     (goto-char (point-max)))
 209                   (or (null nnheader-max-head-length)
 210                       (< beg nnheader-max-head-length)))))))
 211
 212 (defun nnheader-article-p ()
 213   "Say whether the current buffer looks like an article."
 214   (goto-char (point-min))
 215   (if (not (search-forward "\n\n" nil t))
 216       nil
 217     (narrow-to-region (point-min) (1- (point)))
 218     (goto-char (point-min))
 219     (while (looking-at "[A-Z][^ \t]+:.*\n\\([ \t].*\n\\)*\\|From .*\n")
 220       (goto-char (match-end 0)))
 221     (prog1
 222         (eobp)
 223       (widen))))
 224
 225 (defun nnheader-insert-references (references message-id)
 226   "Insert a References header based on REFERENCES and MESSAGE-ID."
 227   (if (and (not references) (not message-id))
 228       ()        ; This is illegal, but not all articles have Message-IDs.
 229     (mail-position-on-field "References")
 230     (let ((begin (save-excursion (beginning-of-line) (point)))
 231           (fill-column 78)
 232           (fill-prefix "\t"))
 233       (if references (insert references))
 234       (if (and references message-id) (insert " "))
 235       (if message-id (insert message-id))
 236       ;; Fold long References lines to conform to RFC1036 (sort of).
 237       ;; The region must end with a newline to fill the region
 238       ;; without inserting extra newline.
 239       (fill-region-as-paragraph begin (1+ (point))))))
 240
 241 (defun nnheader-remove-header (header &optional is-regexp first)
 242   "Remove HEADER.
 243 If FIRST, only remove the first instance if the header.
 244 Return the number of headers removed."
 245   (goto-char (point-min))
 246   (let ((regexp (if is-regexp header (concat "^" header ":")))
 247         (number 0)
 248         (case-fold-search t)
 249         last)
 250     (while (and (re-search-forward regexp nil t)
 251                 (not last))
 252       (incf number)
 253       (when first
 254         (setq last t))
 255       (delete-region
 256        (match-beginning 0)
 257        ;; There might be a continuation header, so we have to search
 258        ;; until we find a new non-continuation line.
 259        (if (re-search-forward "^[^ \t]" nil t)
 260            (match-beginning 0)
 261          (point-max))))
 262     number))
 263
 264 (defun nnheader-replace-header (header new-value)
 265   "Remove HEADER and insert the NEW-VALUE."
 266   (save-excursion
 267     (save-restriction
 268       (nnheader-narrow-to-headers)
 269       (prog1
 270           (nnheader-remove-header header)
 271         (goto-char (point-max))
 272         (insert header ": " new-value "\n")))))
 273
 274 (defun nnheader-narrow-to-headers ()
 275   "Narrow to the head of an article."
 276   (widen)
 277   (narrow-to-region
 278    (goto-char (point-min))
 279    (if (search-forward "\n\n" nil t)
 280        (1- (point))
 281      (point-max)))
 282   (goto-char (point-min)))
 283
 284 (defun nnheader-set-temp-buffer (name)
 285   "Set-buffer to an empty (possibly new) buffer called NAME with undo disabled."
 286   (set-buffer (get-buffer-create name))
 287   (buffer-disable-undo (current-buffer))
 288   (erase-buffer)
 289   (current-buffer))
 290
 291 (defvar jka-compr-compression-info-list)
 292 (defvar nnheader-numerical-files
 293   (if (boundp 'jka-compr-compression-info-list)
 294       (concat "\\([0-9]+\\)\\("
 295               (mapconcat (lambda (i) (aref i 0))
 296                          jka-compr-compression-info-list "\\|")
 297               "\\)?")
 298     "[0-9]+$")
 299   "Regexp that match numerical files.")
 300
 301 (defvar nnheader-numerical-short-files (concat "^" nnheader-numerical-files)
 302   "Regexp that matches numerical file names.")
 303
 304 (defvar nnheader-numerical-full-files (concat "/" nnheader-numerical-files)
 305   "Regexp that matches numerical full file paths.")
 306
 307 (defun nnheader-file-to-number (file)
 308   "Take a file name and return the article number."
 309   (if (not (boundp 'jka-compr-compression-info-list))
 310       (string-to-int file)
 311     (string-match nnheader-numerical-short-files file)
 312     (string-to-int (match-string 0 file))))
 313
 314 (defun nnheader-directory-articles (dir)
 315   "Return a list of all article files in a directory."
 316   (mapcar 'nnheader-file-to-number
 317           (directory-files dir nil nnheader-numerical-short-files t)))
 318
 319 (defun nnheader-article-to-file-alist (dir)
 320   "Return an alist of article/file pairs in DIR."
 321   (mapcar (lambda (file) (cons (nnheader-file-to-number file) file))
 322           (directory-files dir nil nnheader-numerical-short-files t)))
 323
 324 (defun nnheader-fold-continuation-lines ()
 325   "Fold continuation lines in the current buffer."
 326   (goto-char (point-min))
 327   (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t)
 328     (replace-match " " t t)))
 329
 330 (defun nnheader-translate-file-chars (file)
 331   (if (null nnheader-file-name-translation-alist)
 332       ;; No translation is necessary.
 333       file
 334     ;; We translate -- but only the file name.  We leave the directory
 335     ;; alone.
 336     (let* ((new (file-name-nondirectory file))
 337            (len (length new))
 338            (i 0)
 339           trans)
 340       (while (< i len)
 341         (when (setq trans (cdr (assq (aref new i)
 342                                      nnheader-file-name-translation-alist)))
 343           (aset new i trans))
 344         (incf i))
 345       (concat (file-name-directory file) new))))
 346
 347 (defun nnheader-report (backend &rest args)
 348   "Report an error from the BACKEND.
 349 The first string in ARGS can be a format string."
 350   (set (intern (format "%s-status-string" backend))
 351        (if (< (length args) 2)
 352            (car args)
 353          (apply 'format args)))
 354   nil)
 355
 356 (defun nnheader-get-report (backend)
 357   (message "%s" (symbol-value (intern (format "%s-status-string" backend)))))
 358
 359 (defun nnheader-insert (format &rest args)
 360   "Clear the communicaton buffer and insert FORMAT and ARGS into the buffer.
 361 If FORMAT isn't a format string, it and all ARGS will be inserted
 362 without formatting."
 363   (save-excursion
 364     (set-buffer nntp-server-buffer)
 365     (erase-buffer)
 366     (if (string-match "%" format)
 367         (insert (apply 'format format args))
 368       (apply 'insert format args))
 369     t))
 370
 371 (defun nnheader-mail-file-mbox-p (file)
 372   "Say whether FILE looks like an Unix mbox file."
 373   (when (and (file-exists-p file)
 374              (file-readable-p file)
 375              (file-regular-p file))
 376     (save-excursion
 377       (nnheader-set-temp-buffer " *mail-file-mbox-p*")
 378       (insert-file-contents-literally file)
 379       (goto-char (point-min))
 380       (prog1
 381           (looking-at rmail-unix-mail-delimiter)
 382         (kill-buffer (current-buffer))))))
 383
 384 (defun nnheader-replace-chars-in-string (string from to)
 385   "Replace characters in STRING from FROM to TO."
 386   (let ((string (substring string 0))   ;Copy string.
 387         (len (length string))
 388         (idx 0))
 389     ;; Replace all occurrences of FROM with TO.
 390     (while (< idx len)
 391       (if (= (aref string idx) from)
 392           (aset string idx to))
 393       (setq idx (1+ idx)))
 394     string))
 395
 396 (defun nnheader-file-to-group (file &optional top)
 397   "Return a group name based on FILE and TOP."
 398   (nnheader-replace-chars-in-string
 399    (if (not top)
 400        file
 401      (condition-case ()
 402          (substring (expand-file-name file)
 403                     (length
 404                      (expand-file-name
 405                       (file-name-as-directory top))))
 406        (error "")))
 407    ?/ ?.))
 408
 409 (defun nnheader-message (level &rest args)
 410   "Message if the Gnus backends are talkative."
 411   (if (or (not (numberp gnus-verbose-backends))
 412           (<= level gnus-verbose-backends))
 413       (apply 'message args)
 414     (apply 'format args)))
 415
 416 (defun nnheader-be-verbose (level)
 417   "Return whether the backends should be verbose on LEVEL."
 418   (or (not (numberp gnus-verbose-backends))
 419       (<= level gnus-verbose-backends)))
 420
 421 (defun nnheader-group-pathname (group dir &optional file)
 422   "Make pathname for GROUP."
 423   (concat
 424    (let ((dir (file-name-as-directory (expand-file-name dir))))
 425      ;; If this directory exists, we use it directly.
 426      (if (file-directory-p (concat dir group))
 427          (concat dir group "/")
 428        ;; If not, we translate dots into slashes.
 429        (concat dir (nnheader-replace-chars-in-string group ?. ?/) "/")))
 430    (cond ((null file) "")
 431          ((numberp file) (int-to-string file))
 432          (t file))))
 433
 434 (provide 'nnheader)
 435
 436 ;;; nnheader.el ends here