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-remove-header (header &optional is-regexp first)
 263   "Remove HEADER.
 264 If FIRST, only remove the first instance if the header.
 265 Return the number of headers removed."
 266   (goto-char (point-min))
 267   (let ((regexp (if is-regexp header (concat "^" header ":")))
 268         (number 0)
 269         (case-fold-search t)
 270         last)
 271     (while (and (re-search-forward regexp nil t)
 272                 (not last))
 273       (incf number)
 274       (when first
 275         (setq last t))
 276       (delete-region
 277        (match-beginning 0)
 278        ;; There might be a continuation header, so we have to search
 279        ;; until we find a new non-continuation line.
 280        (if (re-search-forward "^[^ \t]" nil t)
 281            (match-beginning 0)
 282          (point-max))))
 283     number))
 284
 285 (defun nnheader-replace-header (header new-value)
 286   "Remove HEADER and insert the NEW-VALUE."
 287   (save-excursion
 288     (save-restriction
 289       (nnheader-narrow-to-headers)
 290       (prog1
 291           (nnheader-remove-header header)
 292         (goto-char (point-max))
 293         (insert header ": " new-value "\n")))))
 294
 295 (defun nnheader-narrow-to-headers ()
 296   "Narrow to the head of an article."
 297   (widen)
 298   (narrow-to-region
 299    (goto-char (point-min))
 300    (if (search-forward "\n\n" nil t)
 301        (1- (point))
 302      (point-max)))
 303   (goto-char (point-min)))
 304
 305 (defun nnheader-set-temp-buffer (name)
 306   "Set-buffer to an empty (possibly new) buffer called NAME with undo disabled."
 307   (set-buffer (get-buffer-create name))
 308   (buffer-disable-undo (current-buffer))
 309   (erase-buffer)
 310   (current-buffer))
 311
 312 (defmacro nnheader-temp-write (file &rest forms)
 313   "Create a new buffer, evaluate FORM there, and write the buffer to FILE."
 314   `(save-excursion
 315      (let ((nnheader-temp-file ,file)
 316            (nnheader-temp-cur-buffer
 317             (nnheader-set-temp-buffer
 318              (generate-new-buffer-name " *nnheader temp*"))))
 319        (when (and nnheader-temp-file
 320                   (not (file-directory-p (file-name-directory
 321                                           nnheader-temp-file))))
 322          (make-directory (file-name-directory nnheader-temp-file) t))
 323        (unwind-protect
 324            (prog1
 325                (progn
 326                  ,@forms)
 327              (when nnheader-temp-file
 328                (set-buffer nnheader-temp-cur-buffer)
 329                (write-region (point-min) (point-max)
 330                              nnheader-temp-file nil 'nomesg)))
 331          (when (buffer-name nnheader-temp-cur-buffer)
 332            (kill-buffer nnheader-temp-cur-buffer))))))
 333
 334 (put 'nnheader-temp-write 'lisp-indent-function 1)
 335 (put 'nnheader-temp-write 'lisp-indent-hook 1)
 336 (put 'nnheader-temp-write 'edebug-form-spec '(file &rest form))
 337
 338 (defvar jka-compr-compression-info-list)
 339 (defvar nnheader-numerical-files
 340   (if (boundp 'jka-compr-compression-info-list)
 341       (concat "\\([0-9]+\\)\\("
 342               (mapconcat (lambda (i) (aref i 0))
 343                          jka-compr-compression-info-list "\\|")
 344               "\\)?")
 345     "[0-9]+$")
 346   "Regexp that match numerical files.")
 347
 348 (defvar nnheader-numerical-short-files (concat "^" nnheader-numerical-files)
 349   "Regexp that matches numerical file names.")
 350
 351 (defvar nnheader-numerical-full-files (concat "/" nnheader-numerical-files)
 352   "Regexp that matches numerical full file paths.")
 353
 354 (defun nnheader-file-to-number (file)
 355   "Take a file name and return the article number."
 356   (if (not (boundp 'jka-compr-compression-info-list))
 357       (string-to-int file)
 358     (string-match nnheader-numerical-short-files file)
 359     (string-to-int (match-string 0 file))))
 360
 361 (defun nnheader-directory-articles (dir)
 362   "Return a list of all article files in a directory."
 363   (mapcar 'nnheader-file-to-number
 364           (directory-files dir nil nnheader-numerical-short-files t)))
 365
 366 (defun nnheader-article-to-file-alist (dir)
 367   "Return an alist of article/file pairs in DIR."
 368   (mapcar (lambda (file) (cons (nnheader-file-to-number file) file))
 369           (directory-files dir nil nnheader-numerical-short-files t)))
 370
 371 (defun nnheader-fold-continuation-lines ()
 372   "Fold continuation lines in the current buffer."
 373   (goto-char (point-min))
 374   (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t)
 375     (replace-match " " t t)))
 376
 377 (defun nnheader-translate-file-chars (file)
 378   (if (null nnheader-file-name-translation-alist)
 379       ;; No translation is necessary.
 380       file
 381     ;; We translate -- but only the file name.  We leave the directory
 382     ;; alone.
 383     (let* ((new (file-name-nondirectory file))
 384            (len (length new))
 385            (i 0)
 386           trans)
 387       (while (< i len)
 388         (when (setq trans (cdr (assq (aref new i)
 389                                      nnheader-file-name-translation-alist)))
 390           (aset new i trans))
 391         (incf i))
 392       (concat (file-name-directory file) new))))
 393
 394 (defun nnheader-report (backend &rest args)
 395   "Report an error from the BACKEND.
 396 The first string in ARGS can be a format string."
 397   (set (intern (format "%s-status-string" backend))
 398        (if (< (length args) 2)
 399            (car args)
 400          (apply 'format args)))
 401   nil)
 402
 403 (defun nnheader-get-report (backend)
 404   (message "%s" (symbol-value (intern (format "%s-status-string" backend)))))
 405
 406 (defun nnheader-insert (format &rest args)
 407   "Clear the communicaton buffer and insert FORMAT and ARGS into the buffer.
 408 If FORMAT isn't a format string, it and all ARGS will be inserted
 409 without formatting."
 410   (save-excursion
 411     (set-buffer nntp-server-buffer)
 412     (erase-buffer)
 413     (if (string-match "%" format)
 414         (insert (apply 'format format args))
 415       (apply 'insert format args))
 416     t))
 417
 418 (defun nnheader-mail-file-mbox-p (file)
 419   "Say whether FILE looks like an Unix mbox file."
 420   (when (and (file-exists-p file)
 421              (file-readable-p file)
 422              (file-regular-p file))
 423     (save-excursion
 424       (nnheader-set-temp-buffer " *mail-file-mbox-p*")
 425       (insert-file-contents-literally file)
 426       (goto-char (point-min))
 427       (prog1
 428           (looking-at rmail-unix-mail-delimiter)
 429         (kill-buffer (current-buffer))))))
 430
 431 (defun nnheader-replace-chars-in-string (string from to)
 432   "Replace characters in STRING from FROM to TO."
 433   (let ((string (substring string 0))   ;Copy string.
 434         (len (length string))
 435         (idx 0))
 436     ;; Replace all occurrences of FROM with TO.
 437     (while (< idx len)
 438       (if (= (aref string idx) from)
 439           (aset string idx to))
 440       (setq idx (1+ idx)))
 441     string))
 442
 443 (defun nnheader-file-to-group (file &optional top)
 444   "Return a group name based on FILE and TOP."
 445   (nnheader-replace-chars-in-string
 446    (if (not top)
 447        file
 448      (condition-case ()
 449          (substring (expand-file-name file)
 450                     (length
 451                      (expand-file-name
 452                       (file-name-as-directory top))))
 453        (error "")))
 454    ?/ ?.))
 455
 456 (defun nnheader-message (level &rest args)
 457   "Message if the Gnus backends are talkative."
 458   (if (or (not (numberp gnus-verbose-backends))
 459           (<= level gnus-verbose-backends))
 460       (apply 'message args)
 461     (apply 'format args)))
 462
 463 (defun nnheader-be-verbose (level)
 464   "Return whether the backends should be verbose on LEVEL."
 465   (or (not (numberp gnus-verbose-backends))
 466       (<= level gnus-verbose-backends)))
 467
 468 (defun nnheader-group-pathname (group dir &optional file)
 469   "Make pathname for GROUP."
 470   (concat
 471    (let ((dir (file-name-as-directory (expand-file-name dir))))
 472      ;; If this directory exists, we use it directly.
 473      (if (file-directory-p (concat dir group))
 474          (concat dir group "/")
 475        ;; If not, we translate dots into slashes.
 476        (concat dir (nnheader-replace-chars-in-string group ?. ?/) "/")))
 477    (cond ((null file) "")
 478          ((numberp file) (int-to-string file))
 479          (t file))))
 480
 481 (defun nnheader-functionp (form)
 482   "Return non-nil if FORM is funcallable."
 483   (or (and (symbolp form) (fboundp form))
 484       (and (listp form) (eq (car form) 'lambda))))
 485
 486 (fset 'nnheader-find-file-noselect 'find-file-noselect)
 487
 488 (provide 'nnheader)
 489
 490 ;;; nnheader.el ends here