| 1 | ;;; gnus-spec.el --- format spec functions for Gnus -*- coding: iso-latin-1 -*- |
| 2 | ;; Copyright (C) 1996, 1997, 1998, 1999, 2000 |
| 3 | ;; Free Software Foundation, Inc. |
| 4 | |
| 5 | ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> |
| 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 | ;;; Code: |
| 28 | |
| 29 | (eval-when-compile (require 'cl)) |
| 30 | |
| 31 | (require 'gnus) |
| 32 | |
| 33 | ;;; Internal variables. |
| 34 | |
| 35 | (defvar gnus-summary-mark-positions nil) |
| 36 | (defvar gnus-group-mark-positions nil) |
| 37 | (defvar gnus-group-indentation "") |
| 38 | |
| 39 | ;; Format specs. The chunks below are the machine-generated forms |
| 40 | ;; that are to be evaled as the result of the default format strings. |
| 41 | ;; We write them in here to get them byte-compiled. That way the |
| 42 | ;; default actions will be quite fast, while still retaining the full |
| 43 | ;; flexibility of the user-defined format specs. |
| 44 | |
| 45 | ;; First we have lots of dummy defvars to let the compiler know these |
| 46 | ;; are really dynamic variables. |
| 47 | |
| 48 | (defvar gnus-tmp-unread) |
| 49 | (defvar gnus-tmp-replied) |
| 50 | (defvar gnus-tmp-score-char) |
| 51 | (defvar gnus-tmp-indentation) |
| 52 | (defvar gnus-tmp-opening-bracket) |
| 53 | (defvar gnus-tmp-lines) |
| 54 | (defvar gnus-tmp-name) |
| 55 | (defvar gnus-tmp-closing-bracket) |
| 56 | (defvar gnus-tmp-subject-or-nil) |
| 57 | (defvar gnus-tmp-subject) |
| 58 | (defvar gnus-tmp-marked) |
| 59 | (defvar gnus-tmp-marked-mark) |
| 60 | (defvar gnus-tmp-subscribed) |
| 61 | (defvar gnus-tmp-process-marked) |
| 62 | (defvar gnus-tmp-number-of-unread) |
| 63 | (defvar gnus-tmp-group-name) |
| 64 | (defvar gnus-tmp-group) |
| 65 | (defvar gnus-tmp-article-number) |
| 66 | (defvar gnus-tmp-unread-and-unselected) |
| 67 | (defvar gnus-tmp-news-method) |
| 68 | (defvar gnus-tmp-news-server) |
| 69 | (defvar gnus-tmp-article-number) |
| 70 | (defvar gnus-mouse-face) |
| 71 | (defvar gnus-mouse-face-prop) |
| 72 | |
| 73 | (defun gnus-summary-line-format-spec () |
| 74 | (insert gnus-tmp-unread gnus-tmp-replied |
| 75 | gnus-tmp-score-char gnus-tmp-indentation) |
| 76 | (gnus-put-text-property |
| 77 | (point) |
| 78 | (progn |
| 79 | (insert |
| 80 | gnus-tmp-opening-bracket |
| 81 | (format "%4d: %-20s" |
| 82 | gnus-tmp-lines |
| 83 | (if (> (length gnus-tmp-name) 20) |
| 84 | (substring gnus-tmp-name 0 20) |
| 85 | gnus-tmp-name)) |
| 86 | gnus-tmp-closing-bracket) |
| 87 | (point)) |
| 88 | gnus-mouse-face-prop gnus-mouse-face) |
| 89 | (insert " " gnus-tmp-subject-or-nil "\n")) |
| 90 | |
| 91 | (defvar gnus-summary-line-format-spec |
| 92 | (gnus-byte-code 'gnus-summary-line-format-spec)) |
| 93 | |
| 94 | (defun gnus-summary-dummy-line-format-spec () |
| 95 | (insert "* ") |
| 96 | (gnus-put-text-property |
| 97 | (point) |
| 98 | (progn |
| 99 | (insert ": :") |
| 100 | (point)) |
| 101 | gnus-mouse-face-prop gnus-mouse-face) |
| 102 | (insert " " gnus-tmp-subject "\n")) |
| 103 | |
| 104 | (defvar gnus-summary-dummy-line-format-spec |
| 105 | (gnus-byte-code 'gnus-summary-dummy-line-format-spec)) |
| 106 | |
| 107 | (defun gnus-group-line-format-spec () |
| 108 | (insert gnus-tmp-marked-mark gnus-tmp-subscribed |
| 109 | gnus-tmp-process-marked |
| 110 | gnus-group-indentation |
| 111 | (format "%5s: " gnus-tmp-number-of-unread)) |
| 112 | (gnus-put-text-property |
| 113 | (point) |
| 114 | (progn |
| 115 | (insert gnus-tmp-group "\n") |
| 116 | (1- (point))) |
| 117 | gnus-mouse-face-prop gnus-mouse-face)) |
| 118 | (defvar gnus-group-line-format-spec |
| 119 | (gnus-byte-code 'gnus-group-line-format-spec)) |
| 120 | |
| 121 | (defvar gnus-format-specs |
| 122 | `((version . ,emacs-version) |
| 123 | (group "%M\%S\%p\%P\%5y: %(%g%)%l\n" ,gnus-group-line-format-spec) |
| 124 | (summary-dummy "* %(: :%) %S\n" |
| 125 | ,gnus-summary-dummy-line-format-spec) |
| 126 | (summary "%U\%R\%z\%I\%(%[%4L: %-20,20n%]%) %s\n" |
| 127 | ,gnus-summary-line-format-spec)) |
| 128 | "Alist of format specs.") |
| 129 | |
| 130 | (defvar gnus-article-mode-line-format-spec nil) |
| 131 | (defvar gnus-summary-mode-line-format-spec nil) |
| 132 | (defvar gnus-group-mode-line-format-spec nil) |
| 133 | |
| 134 | ;;; Phew. All that gruft is over, fortunately. |
| 135 | |
| 136 | ;;;###autoload |
| 137 | (defun gnus-update-format (var) |
| 138 | "Update the format specification near point." |
| 139 | (interactive |
| 140 | (list |
| 141 | (save-excursion |
| 142 | (eval-defun nil) |
| 143 | ;; Find the end of the current word. |
| 144 | (re-search-forward "[ \t\n]" nil t) |
| 145 | ;; Search backward. |
| 146 | (when (re-search-backward "\\(gnus-[-a-z]+-line-format\\)" nil t) |
| 147 | (match-string 1))))) |
| 148 | (let* ((type (intern (progn (string-match "gnus-\\([-a-z]+\\)-line" var) |
| 149 | (match-string 1 var)))) |
| 150 | (entry (assq type gnus-format-specs)) |
| 151 | value spec) |
| 152 | (when entry |
| 153 | (setq gnus-format-specs (delq entry gnus-format-specs))) |
| 154 | (set |
| 155 | (intern (format "%s-spec" var)) |
| 156 | (gnus-parse-format (setq value (symbol-value (intern var))) |
| 157 | (symbol-value (intern (format "%s-alist" var))) |
| 158 | (not (string-match "mode" var)))) |
| 159 | (setq spec (symbol-value (intern (format "%s-spec" var)))) |
| 160 | (push (list type value spec) gnus-format-specs) |
| 161 | |
| 162 | (pop-to-buffer "*Gnus Format*") |
| 163 | (erase-buffer) |
| 164 | (lisp-interaction-mode) |
| 165 | (insert (pp-to-string spec)))) |
| 166 | |
| 167 | (defun gnus-update-format-specifications (&optional force &rest types) |
| 168 | "Update all (necessary) format specifications." |
| 169 | ;; Make the indentation array. |
| 170 | ;; See whether all the stored info needs to be flushed. |
| 171 | (when (or force |
| 172 | (not (equal emacs-version |
| 173 | (cdr (assq 'version gnus-format-specs))))) |
| 174 | (setq gnus-format-specs nil)) |
| 175 | |
| 176 | ;; Go through all the formats and see whether they need updating. |
| 177 | (let (new-format entry type val) |
| 178 | (while (setq type (pop types)) |
| 179 | ;; Jump to the proper buffer to find out the value of |
| 180 | ;; the variable, if possible. (It may be buffer-local.) |
| 181 | (save-excursion |
| 182 | (let ((buffer (intern (format "gnus-%s-buffer" type))) |
| 183 | val) |
| 184 | (when (and (boundp buffer) |
| 185 | (setq val (symbol-value buffer)) |
| 186 | (gnus-buffer-exists-p val)) |
| 187 | (set-buffer val)) |
| 188 | (setq new-format (symbol-value |
| 189 | (intern (format "gnus-%s-line-format" type))))) |
| 190 | (setq entry (cdr (assq type gnus-format-specs))) |
| 191 | (if (and (car entry) |
| 192 | (equal (car entry) new-format)) |
| 193 | ;; Use the old format. |
| 194 | (set (intern (format "gnus-%s-line-format-spec" type)) |
| 195 | (cadr entry)) |
| 196 | ;; This is a new format. |
| 197 | (setq val |
| 198 | (if (not (stringp new-format)) |
| 199 | ;; This is a function call or something. |
| 200 | new-format |
| 201 | ;; This is a "real" format. |
| 202 | (gnus-parse-format |
| 203 | new-format |
| 204 | (symbol-value |
| 205 | (intern (format "gnus-%s-line-format-alist" type))) |
| 206 | (not (string-match "mode$" (symbol-name type)))))) |
| 207 | ;; Enter the new format spec into the list. |
| 208 | (if entry |
| 209 | (progn |
| 210 | (setcar (cdr entry) val) |
| 211 | (setcar entry new-format)) |
| 212 | (push (list type new-format val) gnus-format-specs)) |
| 213 | (set (intern (format "gnus-%s-line-format-spec" type)) val))))) |
| 214 | |
| 215 | (unless (assq 'version gnus-format-specs) |
| 216 | (push (cons 'version emacs-version) gnus-format-specs))) |
| 217 | |
| 218 | (defvar gnus-mouse-face-0 'highlight) |
| 219 | (defvar gnus-mouse-face-1 'highlight) |
| 220 | (defvar gnus-mouse-face-2 'highlight) |
| 221 | (defvar gnus-mouse-face-3 'highlight) |
| 222 | (defvar gnus-mouse-face-4 'highlight) |
| 223 | |
| 224 | (defun gnus-mouse-face-function (form type) |
| 225 | `(gnus-put-text-property |
| 226 | (point) (progn ,@form (point)) |
| 227 | gnus-mouse-face-prop |
| 228 | ,(if (equal type 0) |
| 229 | 'gnus-mouse-face |
| 230 | `(quote ,(symbol-value (intern (format "gnus-mouse-face-%d" type))))))) |
| 231 | |
| 232 | (defvar gnus-face-0 'bold) |
| 233 | (defvar gnus-face-1 'italic) |
| 234 | (defvar gnus-face-2 'bold-italic) |
| 235 | (defvar gnus-face-3 'bold) |
| 236 | (defvar gnus-face-4 'bold) |
| 237 | |
| 238 | (defun gnus-face-face-function (form type) |
| 239 | `(gnus-add-text-properties |
| 240 | (point) (progn ,@form (point)) |
| 241 | '(gnus-face t face ,(symbol-value (intern (format "gnus-face-%d" type)))))) |
| 242 | |
| 243 | (defun gnus-balloon-face-function (form type) |
| 244 | `(gnus-put-text-property |
| 245 | (point) (progn ,@form (point)) |
| 246 | 'balloon-help |
| 247 | ,(intern (format "gnus-balloon-face-%d" type)))) |
| 248 | |
| 249 | (defun gnus-tilde-max-form (el max-width) |
| 250 | "Return a form that limits EL to MAX-WIDTH." |
| 251 | (let ((max (abs max-width))) |
| 252 | (if (symbolp el) |
| 253 | `(if (> (length ,el) ,max) |
| 254 | ,(if (< max-width 0) |
| 255 | `(substring ,el (- (length el) ,max)) |
| 256 | `(substring ,el 0 ,max)) |
| 257 | ,el) |
| 258 | `(let ((val (eval ,el))) |
| 259 | (if (> (length val) ,max) |
| 260 | ,(if (< max-width 0) |
| 261 | `(substring val (- (length val) ,max)) |
| 262 | `(substring val 0 ,max)) |
| 263 | val))))) |
| 264 | |
| 265 | (defun gnus-tilde-cut-form (el cut-width) |
| 266 | "Return a form that cuts CUT-WIDTH off of EL." |
| 267 | (let ((cut (abs cut-width))) |
| 268 | (if (symbolp el) |
| 269 | `(if (> (length ,el) ,cut) |
| 270 | ,(if (< cut-width 0) |
| 271 | `(substring ,el 0 (- (length el) ,cut)) |
| 272 | `(substring ,el ,cut)) |
| 273 | ,el) |
| 274 | `(let ((val (eval ,el))) |
| 275 | (if (> (length val) ,cut) |
| 276 | ,(if (< cut-width 0) |
| 277 | `(substring val 0 (- (length val) ,cut)) |
| 278 | `(substring val ,cut)) |
| 279 | val))))) |
| 280 | |
| 281 | (defun gnus-tilde-ignore-form (el ignore-value) |
| 282 | "Return a form that is blank when EL is IGNORE-VALUE." |
| 283 | (if (symbolp el) |
| 284 | `(if (equal ,el ,ignore-value) |
| 285 | "" ,el) |
| 286 | `(let ((val (eval ,el))) |
| 287 | (if (equal val ,ignore-value) |
| 288 | "" val)))) |
| 289 | |
| 290 | (defun gnus-parse-format (format spec-alist &optional insert) |
| 291 | ;; This function parses the FORMAT string with the help of the |
| 292 | ;; SPEC-ALIST and returns a list that can be eval'ed to return the |
| 293 | ;; string. If the FORMAT string contains the specifiers %( and %) |
| 294 | ;; the text between them will have the mouse-face text property. |
| 295 | ;; If the FORMAT string contains the specifiers %[ and %], the text between |
| 296 | ;; them will have the balloon-help text property. |
| 297 | (if (string-match |
| 298 |