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 (defvar nnheader-callback-function nil)
 146
 147 (defun nnheader-init-server-buffer ()
 148   "Initialize the Gnus-backend communication buffer."
 149   (save-excursion
 150     (setq nntp-server-buffer (get-buffer-create " *nntpd*"))
 151     (set-buffer nntp-server-buffer)
 152     (buffer-disable-undo (current-buffer))
 153     (erase-buffer)
 154     (kill-all-local-variables)
 155     (setq case-fold-search t)           ;Should ignore case.
 156     t))
 157
 158 ;;; Virtual server functions.
 159
 160 (defun nnheader-set-init-variables (server defs)
 161   (let ((s server)
 162         val)
 163     ;; First we set the server variables in the sequence required.  We
 164     ;; use the definitions from the `defs' list where that is
 165     ;; possible.
 166     (while s
 167       (set (caar s)
 168            (if (setq val (assq (caar s) defs))
 169                (nth 1 val)
 170              (nth 1 (car s))))
 171       (setq s (cdr s)))
 172     ;; The we go through the defs list and set any variables that were
 173     ;; not set in the first sweep.
 174     (while defs
 175       (if (not (assq (caar defs) server))
 176           (set (caar defs)
 177                (if (and (symbolp (nth 1 (car defs)))
 178                         (not (boundp (nth 1 (car defs)))))
 179                    (nth 1 (car defs))
 180                  (eval (nth 1 (car defs))))))
 181       (setq defs (cdr defs)))))
 182
 183 (defun nnheader-save-variables (server)
 184   (let (out)
 185     (while server
 186       (push (list (caar server) (symbol-value (caar server))) out)
 187       (setq server (cdr server)))
 188     (nreverse out)))
 189
 190 (defun nnheader-restore-variables (state)
 191   (while state
 192     (set (caar state) (nth 1 (car state)))
 193     (setq state (cdr state))))
 194
 195 (defun nnheader-change-server (backend server defs)
 196   (nnheader-init-server-buffer)
 197   (let ((current-server (intern (format "%s-current-server" backend)))
 198         (alist (intern (format "%s-server-alist" backend)))
 199         (variables (intern (format "%s-server-variables" backend))))
 200
 201     (when (and (symbol-value current-server)
 202                (not (equal server (symbol-value current-server))))
 203       (set alist
 204            (cons (list (symbol-value current-server)
 205                        (nnheader-save-variables (symbol-value variables)))
 206                  (symbol-value alist))))
 207     (let ((state (assoc server (symbol-value alist))))
 208       (if (not state)
 209           (nnheader-set-init-variables (symbol-value variables) defs)
 210         (nnheader-restore-variables (nth 1 state))
 211         (set alist (delq state (symbol-value alist)))))
 212     (set current-server server)
 213     t))
 214
 215 ;;; Various functions the backends use.
 216
 217 (defun nnheader-insert-head (file)
 218   "Insert the head of the article."
 219   (if (eq nnheader-max-head-length t)
 220       ;; Just read the entire file.
 221       (insert-file-contents-literally file)
 222     ;; Read 1K blocks until we find a separator.
 223     (let ((beg 0)
 224           format-alist
 225           (chop 1024))
 226       (while (and (eq chop (nth 1 (insert-file-contents
 227                                    file nil beg (incf beg chop))))
 228                   (prog1 (not (search-forward "\n\n" nil t))
 229                     (goto-char (point-max)))
 230                   (or (null nnheader-max-head-length)
 231                       (< beg nnheader-max-head-length)))))))
 232
 233 (defun nnheader-article-p ()
 234   "Say whether the current buffer looks like an article."
 235   (goto-char (point-min))
 236   (if (not (search-forward "\n\n" nil t))
 237       nil
 238     (narrow-to-region (point-min) (1- (point)))
 239     (goto-char (point-min))
 240     (while (looking-at "[A-Z][^ \t]+:.*\n\\([ \t].*\n\\)*\\|From .*\n")
 241       (goto-char (match-end 0)))
 242     (prog1
 243         (eobp)
 244       (widen))))
 245
 246 (defun nnheader-insert-references (references message-id)
 247   "Insert a References header based on REFERENCES and MESSAGE-ID."
 248   (if (and (not references) (not message-id))
 249       ()        ; This is illegal, but not all articles have Message-IDs.
 250     (mail-position-on-field "References")
 251     (let ((begin (save-excursion (beginning-of-line) (point)))
 252           (fill-column 78)
 253           (fill-prefix "\t"))
 254       (if references (insert references))
 255       (if (and references message-id) (insert " "))
 256       (if message-id (insert message-id))
 257       ;; Fold long References lines to conform to RFC1036 (sort of).
 258       ;; The region must end with a newline to fill the region
 259       ;; without inserting extra newline.
 260       (fill-region-as-paragraph begin (1+ (point))))))
 261
 262 (defun nnheader-replace-header (header new-value)
 263   "Remove HEADER and insert the NEW-VALUE."
 264   (save-excursion
 265     (save-restriction
 266       (nnheader-narrow-to-headers)
 267       (prog1
 268           (message-remove-header header)
 269         (goto-char (point-max))
 270         (insert header ": " new-value "\n")))))
 271
 272 (defun nnheader-narrow-to-headers ()
 273   "Narrow to the head of an article."
 274   (widen)
 275   (narrow-to-region
 276    (goto-char (point-min))
 277    (if (search-forward "\n\n" nil t)
 278        (1- (point))
 279      (point-max)))
 280   (goto-char (point-min)))
 281
 282 (defun nnheader-set-temp-buffer (name)
 283   "Set-buffer to an empty (possibly new) buffer called NAME with undo disabled."
 284   (set-buffer (get-buffer-create name))
 285   (buffer-disable-undo (current-buffer))
 286   (erase-buffer)
 287   (current-buffer))
 288
 289 (defmacro nnheader-temp-write (file &rest forms)
 290   "Create a new buffer, evaluate FORM there, and write the buffer to FILE."
 291   `(save-excursion
 292      (let ((nnheader-temp-file ,file)
 293            (nnheader-temp-cur-buffer
 294             (nnheader-set-temp-buffer
 295              (generate-new-buffer-name " *nnheader temp*"))))
 296        (when (and nnheader-temp-file
 297                   (not (file-directory-p (file-name-directory
 298                                           nnheader-temp-file))))
 299          (make-directory (file-name-directory nnheader-temp-file) t))
 300        (unwind-protect
 301            (prog1
 302                (progn
 303                  ,@forms)
 304              (when nnheader-temp-file
 305                (set-buffer nnheader-temp-cur-buffer)
 306                (write-region (point-min) (point-max)
 307                              nnheader-temp-file nil 'nomesg)))
 308          (when (buffer-name nnheader-temp-cur-buffer)
 309            (kill-buffer nnheader-temp-cur-buffer))))))
 310
 311 (put 'nnheader-temp-write 'lisp-indent-function 1)
 312 (put 'nnheader-temp-write 'lisp-indent-hook 1)
 313 (put 'nnheader-temp-write 'edebug-form-spec '(file &rest form))
 314
 315 (defvar jka-compr-compression-info-list)
 316 (defvar nnheader-numerical-files
 317   (if (boundp 'jka-compr-compression-info-list)
 318       (concat "\\([0-9]+\\)\\("
 319               (mapconcat (lambda (i) (aref i 0))
 320                          jka-compr-compression-info-list "\\|")
 321               "\\)?")
 322     "[0-9]+$")
 323   "Regexp that match numerical files.")
 324
 325 (defvar nnheader-numerical-short-files (concat "^" nnheader-numerical-files)
 326   "Regexp that matches numerical file names.")
 327
 328 (defvar nnheader-numerical-full-files (concat "/" nnheader-numerical-files)
 329   "Regexp that matches numerical full file paths.")
 330
 331 (defsubst nnheader-file-to-number (file)
 332   "Take a file name and return the article number."
 333   (if (not (boundp 'jka-compr-compression-info-list))
 334       (string-to-int file)
 335     (string-match nnheader-numerical-short-files file)
 336     (string-to-int (match-string 0 file))))
 337
 338 (defun nnheader-directory-articles (dir)
 339   "Return a list of all article files in a directory."
 340   (mapcar 'nnheader-file-to-number
 341           (directory-files dir nil nnheader-numerical-short-files t)))
 342
 343 (defun nnheader-article-to-file-alist (dir)
 344   "Return an alist of article/file pairs in DIR."
 345   (mapcar (lambda (file) (cons (nnheader-file-to-number file) file))
 346           (directory-files dir nil nnheader-numerical-short-files t)))
 347
 348 (defun nnheader-fold-continuation-lines ()
 349   "Fold continuation lines in the current buffer."
 350   (goto-char (point-min))
 351   (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t)
 352     (replace-match " " t t)))
 353
 354 (defun nnheader-translate-file-chars (file)
 355   (if (null nnheader-file-name-translation-alist)
 356       ;; No translation is necessary.
 357       file
 358     ;; We translate -- but only the file name.  We leave the directory
 359     ;; alone.
 360     (let* ((new (file-name-nondirectory file))
 361            (len (length new))
 362            (i 0)
 363           trans)
 364       (while (< i len)
 365         (when (setq trans (cdr (assq (aref new i)
 366                                      nnheader-file-name-translation-alist)))
 367           (aset new i trans))
 368         (incf i))
 369       (concat (file-name-directory file) new))))
 370
 371 (defun nnheader-report (backend &rest args)
 372   "Report an error from the BACKEND.
 373 The first string in ARGS can be a format string."
 374   (set (intern (format "%s-status-string" backend))
 375        (if (< (length args) 2)
 376            (car args)
 377          (apply 'format args)))
 378   nil)
 379
 380 (defun nnheader-get-report (backend)
 381   (message "%s" (symbol-value (intern (format "%s-status-string" backend)))))
 382
 383 (defun nnheader-insert (format &rest args)
 384   "Clear the communicaton buffer and insert FORMAT and ARGS into the buffer.
 385 If FORMAT isn't a format string, it and all ARGS will be inserted
 386 without formatting."
 387   (save-excursion
 388     (set-buffer nntp-server-buffer)
 389     (erase-buffer)
 390     (if (string-match "%" format)
 391         (insert (apply 'format format args))
 392       (apply 'insert format args))
 393     t))
 394
 395 (defun nnheader-mail-file-mbox-p (file)
 396   "Say whether FILE looks like an Unix mbox file."
 397   (when (and (file-exists-p file)
 398              (file-readable-p file)
 399              (file-regular-p file))
 400     (save-excursion
 401       (nnheader-set-temp-buffer " *mail-file-mbox-p*")
 402       (insert-file-contents-literally file)
 403       (goto-char (point-min))
 404       (prog1
 405           (looking-at rmail-unix-mail-delimiter)
 406         (kill-buffer (current-buffer))))))
 407
 408 (defun nnheader-replace-chars-in-string (string from to)
 409   "Replace characters in STRING from FROM to TO."
 410   (let ((string (substring string 0))   ;Copy string.
 411         (len (length string))
 412         (idx 0))
 413     ;; Replace all occurrences of FROM with TO.
 414     (while (< idx len)
 415       (if (= (aref string idx) from)
 416           (aset string idx to))
 417       (setq idx (1+ idx)))
 418     string))
 419
 420 (defun nnheader-file-to-group (file &optional top)
 421   "Return a group name based on FILE and TOP."
 422   (nnheader-replace-chars-in-string
 423    (if (not top)
 424        file
 425      (condition-case ()
 426          (substring (expand-file-name file)
 427                     (length
 428                      (expand-file-name
 429                       (file-name-as-directory top))))
 430        (error "")))
 431    ?/ ?.))
 432
 433 (defun nnheader-message (level &rest args)
 434   "Message if the Gnus backends are talkative."
 435   (if (or (not (numberp gnus-verbose-backends))
 436           (<= level gnus-verbose-backends))
 437       (apply 'message args)
 438     (apply 'format args)))
 439
 440 (defun nnheader-be-verbose (level)
 441   "Return whether the backends should be verbose on LEVEL."
 442   (or (not (numberp gnus-verbose-backends))
 443       (<= level gnus-verbose-backends)))
 444
 445 (defun nnheader-group-pathname (group dir &optional file)
 446   "Make pathname for GROUP."
 447   (concat
 448    (let ((dir (file-name-as-directory (expand-file-name dir))))
 449      ;; If this directory exists, we use it directly.
 450      (if (file-directory-p (concat dir group))
 451          (concat dir group "/")
 452        ;; If not, we translate dots into slashes.
 453        (concat dir (nnheader-replace-chars-in-string group ?. ?/) "/")))
 454    (cond ((null file) "")
 455          ((numberp file) (int-to-string file))
 456          (t file))))
 457
 458 (defun nnheader-functionp (form)
 459   "Return non-nil if FORM is funcallable."
 460   (or (and (symbolp form) (fboundp form))
 461       (and (listp form) (eq (car form) 'lambda))))
 462
 463 (fset 'nnheader-find-file-noselect 'find-file-noselect)
 464
 465 (provide 'nnheader)
 466
 467 ;;; nnheader.el ends here