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

   1 ;;; gnus-spec.el --- format spec functions for Gnus
   2 ;; Copyright (C) 1996 Free Software Foundation, Inc.
   3
   4 ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
   5 ;; Keywords: news
   6
   7 ;; This file is part of GNU Emacs.
   8
   9 ;; GNU Emacs is free software; you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation; either version 2, or (at your option)
  12 ;; any later version.
  13
  14 ;; GNU Emacs is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  21 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  22 ;; Boston, MA 02111-1307, USA.
  23
  24 ;;; Commentary:
  25
  26 ;;; Code:
  27
  28 (require 'gnus-load)
  29 (require 'gnus)
  30
  31 ;;; Internal variables.
  32
  33 (defvar gnus-summary-mark-positions nil)
  34 (defvar gnus-group-mark-positions nil)
  35 (defvar gnus-group-indentation "")
  36
  37 ;; Format specs.  The chunks below are the machine-generated forms
  38 ;; that are to be evaled as the result of the default format strings.
  39 ;; We write them in here to get them byte-compiled.  That way the
  40 ;; default actions will be quite fast, while still retaining the full
  41 ;; flexibility of the user-defined format specs.
  42
  43 ;; First we have lots of dummy defvars to let the compiler know these
  44 ;; are really dynamic variables.
  45
  46 (defvar gnus-tmp-unread)
  47 (defvar gnus-tmp-replied)
  48 (defvar gnus-tmp-score-char)
  49 (defvar gnus-tmp-indentation)
  50 (defvar gnus-tmp-opening-bracket)
  51 (defvar gnus-tmp-lines)
  52 (defvar gnus-tmp-name)
  53 (defvar gnus-tmp-closing-bracket)
  54 (defvar gnus-tmp-subject-or-nil)
  55 (defvar gnus-tmp-subject)
  56 (defvar gnus-tmp-marked)
  57 (defvar gnus-tmp-marked-mark)
  58 (defvar gnus-tmp-subscribed)
  59 (defvar gnus-tmp-process-marked)
  60 (defvar gnus-tmp-number-of-unread)
  61 (defvar gnus-tmp-group-name)
  62 (defvar gnus-tmp-group)
  63 (defvar gnus-tmp-article-number)
  64 (defvar gnus-tmp-unread-and-unselected)
  65 (defvar gnus-tmp-news-method)
  66 (defvar gnus-tmp-news-server)
  67 (defvar gnus-tmp-article-number)
  68 (defvar gnus-mouse-face)
  69 (defvar gnus-mouse-face-prop)
  70
  71 (defun gnus-summary-line-format-spec ()
  72   (insert gnus-tmp-unread gnus-tmp-replied
  73           gnus-tmp-score-char gnus-tmp-indentation)
  74   (gnus-put-text-property
  75    (point)
  76    (progn
  77      (insert
  78       gnus-tmp-opening-bracket
  79       (format "%4d: %-20s"
  80               gnus-tmp-lines
  81               (if (> (length gnus-tmp-name) 20)
  82                   (substring gnus-tmp-name 0 20)
  83                 gnus-tmp-name))
  84       gnus-tmp-closing-bracket)
  85      (point))
  86    gnus-mouse-face-prop gnus-mouse-face)
  87   (insert " " gnus-tmp-subject-or-nil "\n"))
  88
  89 (defvar gnus-summary-line-format-spec
  90   (gnus-byte-code 'gnus-summary-line-format-spec))
  91
  92 (defun gnus-summary-dummy-line-format-spec ()
  93   (insert "*  ")
  94   (gnus-put-text-property
  95    (point)
  96    (progn
  97      (insert ":                          :")
  98      (point))
  99    gnus-mouse-face-prop gnus-mouse-face)
 100   (insert " " gnus-tmp-subject "\n"))
 101
 102 (defvar gnus-summary-dummy-line-format-spec
 103   (gnus-byte-code 'gnus-summary-dummy-line-format-spec))
 104
 105 (defun gnus-group-line-format-spec ()
 106   (insert gnus-tmp-marked-mark gnus-tmp-subscribed
 107           gnus-tmp-process-marked
 108           gnus-group-indentation
 109           (format "%5s: " gnus-tmp-number-of-unread))
 110   (gnus-put-text-property
 111    (point)
 112    (progn
 113      (insert gnus-tmp-group "\n")
 114      (1- (point)))
 115    gnus-mouse-face-prop gnus-mouse-face))
 116 (defvar gnus-group-line-format-spec
 117   (gnus-byte-code 'gnus-group-line-format-spec))
 118
 119 (defvar gnus-format-specs
 120   `((version . ,emacs-version)
 121     (group "%M\%S\%p\%P\%5y: %(%g%)%l\n" ,gnus-group-line-format-spec)
 122     (summary-dummy "*  %(:                          :%) %S\n"
 123                    ,gnus-summary-dummy-line-format-spec)
 124     (summary "%U\%R\%z\%I\%(%[%4L: %-20,20n%]%) %s\n"
 125              ,gnus-summary-line-format-spec))
 126   "Alist of format specs.")
 127
 128 (defvar gnus-article-mode-line-format-spec nil)
 129 (defvar gnus-summary-mode-line-format-spec nil)
 130 (defvar gnus-group-mode-line-format-spec nil)
 131
 132 ;;; Phew.  All that gruft is over, fortunately.
 133
 134 ;;;###autoload
 135 (defun gnus-update-format (var)
 136   "Update the format specification near point."
 137   (interactive
 138    (list
 139     (save-excursion
 140       (eval-defun nil)
 141       ;; Find the end of the current word.
 142       (re-search-forward "[ \t\n]" nil t)
 143       ;; Search backward.
 144       (when (re-search-backward "\\(gnus-[-a-z]+-line-format\\)" nil t)
 145         (match-string 1)))))
 146   (let* ((type (intern (progn (string-match "gnus-\\([-a-z]+\\)-line" var)
 147                               (match-string 1 var))))
 148          (entry (assq type gnus-format-specs))
 149          value spec)
 150     (when entry
 151       (setq gnus-format-specs (delq entry gnus-format-specs)))
 152     (set
 153      (intern (format "%s-spec" var))
 154      (gnus-parse-format (setq value (symbol-value (intern var)))
 155                         (symbol-value (intern (format "%s-alist" var)))
 156                         (not (string-match "mode" var))))
 157     (setq spec (symbol-value (intern (format "%s-spec" var))))
 158     (push (list type value spec) gnus-format-specs)
 159
 160     (pop-to-buffer "*Gnus Format*")
 161     (erase-buffer)
 162     (lisp-interaction-mode)
 163     (insert (pp-to-string spec))))
 164
 165 (defun gnus-update-format-specifications (&optional force &rest types)
 166   "Update all (necessary) format specifications."
 167   ;; Make the indentation array.
 168
 169   ;; See whether all the stored info needs to be flushed.
 170   (when (or force
 171             (not (equal emacs-version
 172                         (cdr (assq 'version gnus-format-specs)))))
 173     (setq gnus-format-specs nil))
 174
 175   ;; Go through all the formats and see whether they need updating.
 176   (let (new-format entry type val)
 177     (while (setq type (pop types))
 178       ;; Jump to the proper buffer to find out the value of
 179       ;; the variable, if possible.  (It may be buffer-local.)
 180       (save-excursion
 181         (let ((buffer (intern (format "gnus-%s-buffer" type)))
 182               val)
 183           (when (and (boundp buffer)
 184                      (setq val (symbol-value buffer))
 185                      (get-buffer val)
 186                      (buffer-name (get-buffer val)))
 187             (set-buffer (get-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 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"
 206                                   (if (eq type 'article-mode)
 207                                       'summary-mode type))))
 208                  (not (string-match "mode$" (symbol-name type))))))
 209         ;; Enter the new format spec into the list.
 210         (if entry
 211             (progn
 212               (setcar (cdr entry) val)
 213               (setcar entry new-format))
 214           (push (list type new-format val) gnus-format-specs))
 215         (set (intern (format "gnus-%s-line-format-spec" type)) val))))
 216
 217   (unless (assq 'version gnus-format-specs)
 218     (push (cons 'version emacs-version) gnus-format-specs)))
 219
 220 (defvar gnus-mouse-face-0 'highlight)
 221 (defvar gnus-mouse-face-1 'highlight)
 222 (defvar gnus-mouse-face-2 'highlight)
 223 (defvar gnus-mouse-face-3 'highlight)
 224 (defvar gnus-mouse-face-4 'highlight)
 225
 226 (defun gnus-mouse-face-function (form type)
 227   `(gnus-put-text-property
 228     (point) (progn ,@form (point))
 229     gnus-mouse-face-prop
 230     ,(if (equal type 0)
 231          'gnus-mouse-face
 232        `(quote ,(symbol-value (intern (format "gnus-mouse-face-%d" type)))))))
 233
 234 (defvar gnus-face-0 'bold)
 235 (defvar gnus-face-1 'italic)
 236 (defvar gnus-face-2 'bold-italic)
 237 (defvar gnus-face-3 'bold)
 238 (defvar gnus-face-4 'bold)
 239
 240 (defun gnus-face-face-function (form type)
 241   `(gnus-put-text-property
 242     (point) (progn ,@form (point))
 243     'face ',(symbol-value (intern (format "gnus-face-%d" type)))))
 244
 245 (defun gnus-max-width-function (el max-width)
 246   (or (numberp max-width) (signal 'wrong-type-argument '(numberp max-width)))
 247   (if (symbolp el)
 248       `(if (> (length ,el) ,max-width)
 249            (substring ,el 0 ,max-width)
 250          ,el)
 251     `(let ((val (eval ,el)))
 252        (if (numberp val)
 253            (setq val (int-to-string val)))
 254        (if (> (length val) ,max-width)
 255            (substring val 0 ,max-width)
 256          val))))
 257
 258 (defun gnus-parse-format (format spec-alist &optional insert)
 259   ;; This function parses the FORMAT string with the help of the
 260   ;; SPEC-ALIST and returns a list that can be eval'ed to return the
 261   ;; string.  If the FORMAT string contains the specifiers %( and %)
 262   ;; the text between them will have the mouse-face text property.
 263   (if (string-match
 264        "\\`\\(.*\\)%[0-9]?[{(]\\(.*\\)%[0-9]?[})]\\(.*\n?\\)\\'"
 265        format)
 266       (gnus-parse-complex-format format spec-alist)
 267     ;; This is a simple format.
 268     (gnus-parse-simple-format format spec-alist insert)))
 269
 270 (defun gnus-parse-complex-format (format spec-alist)
 271   (save-excursion
 272     (gnus-set-work-buffer)
 273     (insert format)
 274     (goto-char (point-min))
 275     (while (re-search-forward "\"" nil t)
 276       (replace-match "\\\"" nil t))
 277     (goto-char (point-min))
 278     (insert "(\"")
 279     (while (re-search-forward "%\\([0-9]+\\)?\\([{}()]\\)" nil t)
 280       (let ((number (if (match-beginning 1)
 281                         (match-string 1) "0"))
 282             (delim (aref (match-string 2) 0)))
 283         (if (or (= delim ?\() (= delim ?\{))
 284             (replace-match (concat "\"(" (if (= delim ?\() "mouse" "face")
 285                                    " " number " \""))
 286           (replace-match "\")\""))))
 287     (goto-char (point-max))
 288     (insert "\")")
 289     (goto-char (point-min))
 290     (let ((form (read (current-buffer))))
 291       (cons 'progn (gnus-complex-form-to-spec form spec-alist)))))
 292
 293 (defun gnus-complex-form-to-spec (form spec-alist)
 294   (delq nil
 295         (mapcar
 296          (lambda (sform)
 297            (if (stringp sform)
 298                (gnus-parse-simple-format sform spec-alist t)
 299              (funcall (intern (format "gnus-%s-face-function" (car sform)))
 300                       (gnus-complex-form-to-spec (cddr sform) spec-alist)
 301                       (nth 1 sform))))
 302          form)))
 303
 304 (defun gnus-parse-simple-format (format spec-alist &optional insert)
 305   ;; This function parses the FORMAT string with the help of the
 306   ;; SPEC-ALIST and returns a list that can be eval'ed to return a
 307   ;; string.
 308   (let ((max-width 0)
 309         spec flist fstring newspec elem beg result dontinsert)
 310     (save-excursion
 311       (gnus-set-work-buffer)
 312       (insert format)
 313       (goto-char (point-min))
 314       (while (re-search-forward "%[-0-9]*\\(,[0-9]+\\)?\\([^0-9]\\)\\(.\\)?"
 315                                 nil t)
 316         (if (= (setq spec (string-to-char (match-string 2))) ?%)
 317               (setq newspec "%"
 318                     beg (1+ (match-beginning 0)))
 319           ;; First check if there are any specs that look anything like
 320           ;; "%12,12A", ie. with a "max width specification".  These have
 321           ;; to be treated specially.
 322           (if (setq beg (match-beginning 1))
 323               (setq max-width
 324                     (string-to-int
 325                      (buffer-substring
 326                       (1+ (match-beginning 1)) (match-end 1))))
 327             (setq max-width 0)
 328             (setq beg (match-beginning 2)))
 329           ;; Find the specification from `spec-alist'.
 330           (unless (setq elem (cdr (assq spec spec-alist)))
 331             (setq elem '("*" ?s)))
 332           ;; Treat user defined format specifiers specially.
 333           (when (eq (car elem) 'gnus-tmp-user-defined)
 334             (setq elem
 335                   (list
 336                    (list (intern (concat "gnus-user-format-function-"
 337                                          (match-string 3)))
 338                          'gnus-tmp-header) ?s))
 339             (delete-region (match-beginning 3) (match-end 3)))
 340           (if (not (zerop max-width))
 341               (let ((el (car elem)))
 342                 (cond ((= (cadr elem) ?c)
 343                        (setq el (list 'char-to-string el)))
 344                       ((= (cadr elem) ?d)
 345                        (setq el (list 'int-to-string el))))
 346                 (setq flist (cons (gnus-max-width-function el max-width)
 347                                   flist))
 348                 (setq newspec ?s))
 349             (progn
 350               (setq flist (cons (car elem) flist))
 351               (setq newspec (cadr elem)))))
 352         ;; Remove the old specification (and possibly a ",12" string).
 353         (delete-region beg (match-end 2))
 354         ;; Insert the new specification.
 355         (goto-char beg)
 356         (insert newspec))
 357       (setq fstring (buffer-substring 1 (point-max))))
 358     ;; Do some postprocessing to increase efficiency.
 359     (setq
 360      result
 361      (cond
 362       ;; Emptyness.
 363       ((string= fstring "")
 364        nil)
 365       ;; Not a format string.
 366       ((not (string-match "%" fstring))
 367        (list fstring))
 368       ;; A format string with just a single string spec.
 369       ((string= fstring "%s")
 370        (list (car flist)))
 371       ;; A single character.
 372       ((string= fstring "%c")
 373        (list (car flist)))
 374       ;; A single number.
 375       ((string= fstring "%d")
 376        (setq dontinsert)
 377        (if insert
 378            (list `(princ ,(car flist)))
 379          (list `(int-to-string ,(car flist)))))
 380       ;; Just lots of chars and strings.
 381       ((string-match "\\`\\(%[cs]\\)+\\'" fstring)
 382        (nreverse flist))
 383       ;; A single string spec at the beginning of the spec.
 384       ((string-match "\\`%[sc][^%]+\\'" fstring)
 385        (list (car flist) (substring fstring 2)))
 386       ;; A single string spec in the middle of the spec.
 387       ((string-match "\\`\\([^%]+\\)%[sc]\\([^%]+\\)\\'" fstring)
 388        (list (match-string 1 fstring) (car flist) (match-string 2 fstring)))
 389       ;; A single string spec in the end of the spec.
 390       ((string-match "\\`\\([^%]+\\)%[sc]\\'" fstring)
 391        (list (match-string 1 fstring) (car flist)))
 392       ;; A more complex spec.
 393       (t
 394        (list (cons 'format (cons fstring (nreverse flist)))))))
 395
 396     (if insert
 397         (when result
 398           (if dontinsert
 399               result
 400             (cons 'insert result)))
 401       (cond ((stringp result)
 402              result)
 403             ((consp result)
 404              (cons 'concat result))
 405             (t "")))))
 406
 407 (defun gnus-eval-format (format &optional alist props)
 408   "Eval the format variable FORMAT, using ALIST.
 409 If PROPS, insert the result."
 410   (let ((form (gnus-parse-format format alist props)))
 411     (if props
 412         (gnus-add-text-properties (point) (progn (eval form) (point)) props)
 413       (eval form))))
 414
 415 (defun gnus-compile ()
 416   "Byte-compile the user-defined format specs."
 417   (interactive)
 418   (let ((entries gnus-format-specs)
 419         entry gnus-tmp-func)
 420     (save-excursion
 421       (gnus-message 7 "Compiling format specs...")
 422
 423       (while entries
 424         (setq entry (pop entries))
 425         (if (eq (car entry) 'version)
 426             (setq gnus-format-specs (delq entry gnus-format-specs))
 427           (when (and (listp (caddr entry))
 428                      (not (eq 'byte-code (caaddr entry))))
 429             (fset 'gnus-tmp-func
 430                   `(lambda () ,(caddr entry)))
 431             (byte-compile 'gnus-tmp-func)
 432             (setcar (cddr entry) (gnus-byte-code 'gnus-tmp-func)))))
 433
 434       (push (cons 'version emacs-version) gnus-format-specs)
 435       ;; Mark the .newsrc.eld file as "dirty".
 436       (gnus-dribble-enter " ")
 437       (gnus-message 7 "Compiling user specs...done"))))
 438
 439 (provide 'gnus-spec)
 440
 441 ;;; gnus-spec.el ends here