git.chise.org Git - elisp/gnus.git-/blob - lisp/gnus-spec.el

   1 ;;; gnus-spec.el --- format spec functions for Gnus
   2 ;; Copyright (C) 1996,97,98,99 Free Software Foundation, Inc.
   3
   4 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   5 ;;      Katsumi Yamaoka <yamaoka@jpl.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-format-specs-compiled nil
 131   "Alist of compiled format specs.")
 132
 133 (defvar gnus-article-mode-line-format-spec nil)
 134 (defvar gnus-summary-mode-line-format-spec nil)
 135 (defvar gnus-group-mode-line-format-spec nil)
 136
 137 ;;; Phew.  All that gruft is over, fortunately.
 138
 139 ;;;###autoload
 140 (defun gnus-update-format (var)
 141   "Update the format specification near point."
 142   (interactive
 143    (list
 144     (save-excursion
 145       (eval-defun nil)
 146       ;; Find the end of the current word.
 147       (re-search-forward "[ \t\n]" nil t)
 148       ;; Search backward.
 149       (when (re-search-backward "\\(gnus-[-a-z]+-line-format\\)" nil t)
 150         (match-string 1)))))
 151   (let* ((type (intern (progn (string-match "gnus-\\([-a-z]+\\)-line" var)
 152                               (match-string 1 var))))
 153          (entry (assq type gnus-format-specs))
 154          value spec)
 155     (when entry
 156       (setq gnus-format-specs (delq entry gnus-format-specs)))
 157     (set
 158      (intern (format "%s-spec" var))
 159      (gnus-parse-format (setq value (symbol-value (intern var)))
 160                         (symbol-value (intern (format "%s-alist" var)))
 161                         (not (string-match "mode" var))))
 162     (setq spec (symbol-value (intern (format "%s-spec" var))))
 163     (push (list type value spec) gnus-format-specs)
 164
 165     (pop-to-buffer "*Gnus Format*")
 166     (erase-buffer)
 167     (lisp-interaction-mode)
 168     (insert (pp-to-string spec))))
 169
 170 (defun gnus-update-format-specifications-1 (force types)
 171   "Update all (necessary) format specifications."
 172   ;; Make the indentation array.
 173   ;; See whether all the stored info needs to be flushed.
 174   (when (or force
 175             (not (equal emacs-version
 176                         (cdr (assq 'version gnus-format-specs))))
 177             (not (equal gnus-version gnus-newsrc-file-version)))
 178     (message "%s" "Force update format specs.")
 179     (setq gnus-format-specs nil
 180           gnus-newsrc-file-version gnus-version))
 181
 182   ;; Go through all the formats and see whether they need updating.
 183   (let (new-format entry type val)
 184     (while (setq type (pop types))
 185       ;; Jump to the proper buffer to find out the value of
 186       ;; the variable, if possible.  (It may be buffer-local.)
 187       (save-excursion
 188         (let ((buffer (intern (format "gnus-%s-buffer" type)))
 189               val)
 190           (when (and (boundp buffer)
 191                      (setq val (symbol-value buffer))
 192                      (gnus-buffer-exists-p val))
 193             (set-buffer val))
 194           (setq new-format (symbol-value
 195                             (intern (format "gnus-%s-line-format" type)))))
 196         (setq entry (cdr (assq type gnus-format-specs)))
 197         (if (and (car entry)
 198                  (equal (car entry) new-format))
 199             ;; Use the old format.
 200             (set (intern (format "gnus-%s-line-format-spec" type))
 201                  (cadr entry))
 202           ;; This is a new format.
 203           (setq val
 204                 (if (not (stringp new-format))
 205                     ;; This is a function call or something.
 206                     new-format
 207                   ;; This is a "real" format.
 208                   (gnus-parse-format
 209                    new-format
 210                    (symbol-value
 211                     (intern (format "gnus-%s-line-format-alist" type)))
 212                    (not (string-match "mode$" (symbol-name type))))))
 213           ;; Enter the new format spec into the list.
 214           (if entry
 215               (progn
 216                 (setcar (cdr entry) val)
 217                 (setcar entry new-format))
 218             (push (list type new-format val) gnus-format-specs))
 219           (set (intern (format "gnus-%s-line-format-spec" type)) val)))))
 220
 221   (unless (assq 'version gnus-format-specs)
 222     (push (cons 'version emacs-version) gnus-format-specs)))
 223
 224 (defun gnus-update-format-specifications (&optional force &rest types)
 225   "Update all (necessary) format specifications."
 226   (if gnus-format-specs-compiled
 227       (let ((gnus-format-specs gnus-format-specs-compiled))
 228         (gnus-update-format-specifications-1 force types))
 229     (gnus-update-format-specifications-1 force types)))
 230
 231 (defvar gnus-mouse-face-0 'highlight)
 232 (defvar gnus-mouse-face-1 'highlight)
 233 (defvar gnus-mouse-face-2 'highlight)
 234 (defvar gnus-mouse-face-3 'highlight)
 235 (defvar gnus-mouse-face-4 'highlight)
 236
 237 (defun gnus-mouse-face-function (form type)
 238   `(gnus-put-text-property
 239     (point) (progn ,@form (point))
 240     gnus-mouse-face-prop
 241     ,(if (equal type 0)
 242          'gnus-mouse-face
 243        `(quote ,(symbol-value (intern (format "gnus-mouse-face-%d" type)))))))
 244
 245 (defvar gnus-face-0 'bold)
 246 (defvar gnus-face-1 'italic)
 247 (defvar gnus-face-2 'bold-italic)
 248 (defvar gnus-face-3 'bold)
 249 (defvar gnus-face-4 'bold)
 250
 251 (defun gnus-face-face-function (form type)
 252   `(gnus-add-text-properties
 253     (point) (progn ,@form (point))
 254     '(gnus-face t face ,(symbol-value (intern (format "gnus-face-%d" type))))))
 255
 256 ;;; Avoid byte-compile warning.
 257 (defun gnus-tilde-pad-form (el pad-width)
 258   "Dummy function except for XEmacs-mule. It will be redefined
 259 by `gnus-xmas-redefine'."
 260   (let ((val (if (symbolp el) (eval el) el)))
 261     (` (, val))))
 262
 263 (defun gnus-balloon-face-function (form type)
 264   `(gnus-put-text-property
 265     (point) (progn ,@form (point))
 266     'balloon-help
 267     ,(intern (format "gnus-balloon-face-%d" type))))
 268
 269 (defun gnus-tilde-max-form (el max-width)
 270   "Return a form that limits EL to MAX-WIDTH."
 271   (let ((max (abs max-width)))
 272     (if (symbolp el)
 273         `(if (> (length ,el) ,max)
 274              ,(if (< max-width 0)
 275                   `(substring ,el (- (length el) ,max))
 276                 `(substring ,el 0 ,max))
 277            ,el)
 278       `(let ((val (eval ,el)))
 279          (if (> (length val) ,max)
 280              ,(if (< max-width 0)
 281                   `(substring val (- (length val) ,max))
 282                 `(substring val 0 ,max))
 283            val)))))
 284
 285 (defun gnus-tilde-cut-form (el cut-width)
 286   "Return a form that cuts CUT-WIDTH off of EL."
 287   (let ((cut (abs cut-width)))
 288     (if (symbolp el)
 289         `(if (> (length ,el) ,cut)
 290              ,(if (< cut-width 0)
 291                   `(substring ,el 0 (- (length el) ,cut))
 292                 `(substring ,el ,cut))
 293            ,el)
 294       `(let ((val (eval ,el)))
 295          (if (> (length val) ,cut)
 296              ,(if (< cut-width 0)
 297                   `(substring val 0 (- (length val) ,cut))
 298                 `(substring val ,cut))
 299            val)))))
 300
 301 (defun gnus-tilde-ignore-form (el ignore-value)
 302   "Return a form that is blank when EL is IGNORE-VALUE."
 303   (if (symbolp el)
 304       `(if (equal ,el ,ignore-value)
 305            "" ,el)
 306     `(let ((val (eval ,el)))
 307        (if (equal val ,ignore-value)
 308            "" val))))
 309
 310 (defun gnus-parse-format (format spec-alist &optional insert)
 311   ;; This function parses the FORMAT string with the help of the
 312   ;; SPEC-ALIST and returns a list that can be eval'ed to return the
 313   ;; string.  If the FORMAT string contains the specifiers %( and %)
 314   ;; the text between them will have the mouse-face text property.
 315   ;; If the FORMAT string contains the specifiers %[ and %], the text between
 316   ;; them will have the balloon-help text property.
 317   (if (string-match
 318        "\\`\\(.*\\)%[0-9]?[{(«]\\(.*\\)%[0-9]?[»})]\\(.*\n?\\)\\'"
 319        format)
 320       (gnus-parse-complex-format format spec-alist)
 321     ;; This is a simple format.
 322     (gnus-parse-simple-format format spec-alist insert)))
 323
 324 (defun gnus-parse-complex-format (format spec-alist)
 325   (save-excursion
 326     (gnus-set-work-buffer)
 327     (insert format)
 328     (goto-char (point-min))
 329     (while (re-search-forward "\"" nil t)
 330       (replace-match "\\\"" nil t))
 331     (goto-char (point-min))
 332     (insert "(\"")
 333     (while (re-search-forward "%\\([0-9]+\\)?\\([«»{}()]\\)" nil t)
 334       (let ((number (if (match-beginning 1)
 335                         (match-string 1) "0"))
 336             (delim (aref (match-string 2) 0)))
 337         (if (or (= delim ?\()
 338                 (= delim ?\{)
 339                 (= delim ?\«))
 340             (replace-match (concat "\"("
 341                                    (cond ((= delim ?\() "mouse")
 342                                          ((= delim ?\{) "face")
 343                                          (t "balloon"))
 344                                    " " number " \""))
 345           (replace-match "\")\""))))
 346     (goto-char (point-max))
 347     (insert "\")")
 348     (goto-char (point-min))
 349     (let ((form (read (current-buffer))))
 350       (cons 'progn (gnus-complex-form-to-spec form spec-alist)))))
 351
 352 (defun gnus-complex-form-to-spec (form spec-alist)
 353   (delq nil
 354         (mapcar
 355          (lambda (sform)
 356            (if (stringp sform)
 357                (gnus-parse-simple-format sform spec-alist t)
 358              (funcall (intern (format "gnus-%s-face-function" (car sform)))
 359                       (gnus-complex-form-to-spec (cddr sform) spec-alist)
 360                       (nth 1 sform))))
 361          form)))
 362
 363 (defun gnus-parse-simple-format (format spec-alist &optional insert)
 364   ;; This function parses the FORMAT string with the help of the
 365   ;; SPEC-ALIST and returns a list that can be eval'ed to return a
 366   ;; string.
 367   (let ((xemacs-mule-p (and gnus-xemacs (featurep 'mule)))
 368         max-width
 369         spec flist fstring elem result dontinsert user-defined
 370         type value pad-width spec-beg cut-width ignore-value
 371         tilde-form tilde elem-type)
 372     (save-excursion
 373       (gnus-set-work-buffer)
 374       (insert format)
 375       (goto-char (point-min))
 376       (while (search-forward "%" nil t)
 377         (setq user-defined nil
 378               spec-beg nil
 379               pad-width nil
 380               max-width nil
 381               cut-width nil
 382               ignore-value nil
 383               tilde-form nil)
 384         (setq spec-beg (1- (point)))
 385
 386         ;; Parse this spec fully.
 387         (while
 388             (cond
 389              ((looking-at "\\([-.0-9]+\\)\\(,[-0-9]+\\)?")
 390               (setq pad-width (string-to-number (match-string 1)))
 391               (when (match-beginning 2)
 392                 (setq max-width (string-to-number (buffer-substring
 393                                                    (1+ (match-beginning 2))
 394                                                    (match-end 2)))))
 395               (goto-char (match-end 0)))
 396              ((looking-at "~")
 397               (forward-char 1)
 398               (setq tilde (read (current-buffer))
 399                     type (car tilde)
 400                     value (cadr tilde))
 401               (cond
 402                ((memq type '(pad pad-left))
 403                 (setq pad-width value))
 404                ((eq type 'pad-right)
 405                 (setq pad-width (- value)))
 406                ((memq type '(max-right max))
 407                 (setq max-width value))
 408                ((eq type 'max-left)
 409                 (setq max-width (- value)))
 410                ((memq type '(cut cut-left))
 411                 (setq cut-width value))
 412                ((eq type 'cut-right)
 413                 (setq cut-width (- value)))
 414                ((eq type 'ignore)
 415                 (setq ignore-value
 416                       (if (stringp value) value (format "%s" value))))
 417                ((eq type 'form)
 418                 (setq tilde-form value))
 419                (t
 420                 (error "Unknown tilde type: %s" tilde)))
 421               t)
 422              (t
 423               nil)))
 424         ;; User-defined spec -- find the spec name.
 425         (when (eq (setq spec (char-after)) ?u)
 426           (forward-char 1)
 427           (setq user-defined (char-after)))
 428         (forward-char 1)
 429         (delete-region spec-beg (point))
 430
 431         ;; Now we have all the relevant data on this spec, so
 432         ;; we start doing stuff.
 433         (insert "%")
 434         (if (eq spec ?%)
 435             ;; "%%" just results in a "%".
 436             (insert "%")
 437           (cond
 438            ;; Do tilde forms.
 439            ((eq spec ?@)
 440             (setq elem (list tilde-form ?s)))
 441            ;; Treat user defined format specifiers specially.
 442            (user-defined
 443             (setq elem
 444                   (list
 445                    (list (intern (format "gnus-user-format-function-%c"
 446                                          user-defined))
 447                          'gnus-tmp-header)
 448                    ?s)))
 449            ;; Find the specification from `spec-alist'.
 450            ((setq elem (cdr (assq spec spec-alist))))
 451            (t
 452             (setq elem '("*" ?s))))
 453           (setq elem-type (cadr elem))
 454           ;; Insert the new format elements.
 455           (and pad-width (not xemacs-mule-p)
 456                (insert (number-to-string pad-width)))
 457           ;; Create the form to be evaled.
 458           (if (or max-width cut-width ignore-value
 459                   (and pad-width xemacs-mule-p))
 460               (progn
 461                 (insert ?s)
 462                 (let ((el (car elem)))
 463                   (cond ((= (cadr elem) ?c)
 464                          (setq el (list 'char-to-string el)))
 465                         ((= (cadr elem) ?d)
 466                          (setq el (list 'int-to-string el))))
 467                   (when ignore-value
 468                     (setq el (gnus-tilde-ignore-form el ignore-value)))
 469                   (when cut-width
 470                     (setq el (gnus-tilde-cut-form el cut-width)))
 471                   (when max-width
 472                     (setq el (gnus-tilde-max-form el max-width)))
 473                   (and pad-width xemacs-mule-p
 474                        (setq el (gnus-tilde-pad-form el pad-width)))
 475                   (push el flist)))
 476             (insert elem-type)
 477             (push (car elem) flist))))
 478       (setq fstring (buffer-string)))
 479
 480     ;; Do some postprocessing to increase efficiency.
 481     (setq
 482      result
 483      (cond
 484       ;; Emptyness.
 485       ((string= fstring "")
 486        nil)
 487       ;; Not a format string.
 488       ((not (string-match "%" fstring))
 489        (list fstring))
 490       ;; A format string with just a single string spec.
 491       ((string= fstring "%s")
 492        (list (car flist)))
 493       ;; A single character.
 494       ((string= fstring "%c")
 495        (list (car flist)))
 496       ;; A single number.
 497       ((string= fstring "%d")
 498        (setq dontinsert)
 499        (if insert
 500            (list `(princ ,(car flist)))
 501          (list `(int-to-string ,(car flist)))))
 502       ;; Just lots of chars and strings.
 503       ((string-match "\\`\\(%[cs]\\)+\\'" fstring)
 504        (nreverse flist))
 505       ;; A single string spec at the beginning of the spec.
 506       ((string-match "\\`%[sc][^%]+\\'" fstring)
 507        (list (car flist) (substring fstring 2)))
 508       ;; A single string spec in the middle of the spec.
 509       ((string-match "\\`\\([^%]+\\)%[sc]\\([^%]+\\)\\'" fstring)
 510        (list (match-string 1 fstring) (car flist) (match-string 2 fstring)))
 511       ;; A single string spec in the end of the spec.
 512       ((string-match "\\`\\([^%]+\\)%[sc]\\'" fstring)
 513        (list (match-string 1 fstring) (car flist)))
 514       ;; A more complex spec.
 515       (t
 516        (list (cons 'format (cons fstring (nreverse flist)))))))
 517
 518     (if insert
 519         (when result
 520           (if dontinsert
 521               result
 522             (cons 'insert result)))
 523       (cond ((stringp result)
 524              result)
 525             ((consp result)
 526              (cons 'concat result))
 527             (t "")))))
 528
 529 (defun gnus-eval-format (format &optional alist props)
 530   "Eval the format variable FORMAT, using ALIST.
 531 If PROPS, insert the result."
 532   (let ((form (gnus-parse-format format alist props)))
 533     (if props
 534         (gnus-add-text-properties (point) (progn (eval form) (point)) props)
 535       (eval form))))
 536
 537 (defun gnus-compile ()
 538   "Byte-compile the user-defined format specs."
 539   (interactive)
 540   (require 'bytecomp)
 541   (let ((entries gnus-format-specs)
 542         (byte-compile-warnings '(unresolved callargs redefine))
 543         entry gnus-tmp-func)
 544     (save-excursion
 545       (gnus-message 7 "Compiling format specs...")
 546
 547       (setq gnus-format-specs-compiled nil)
 548       (while entries
 549         (setq entry (pop entries))
 550         (if (memq (car entry) '(version gnus-version))
 551             (setq gnus-format-specs (delq entry gnus-format-specs))
 552           (let ((form (caddr entry)))
 553             (when (and (listp form)
 554                        ;; Under GNU Emacs, it's (byte-code ...)
 555                        (not (eq 'byte-code (car form)))
 556                        ;; Under XEmacs, it's (funcall #<compiled-function ...>)
 557                        (not (and (eq 'funcall (car form))
 558                                  (byte-code-function-p (cadr form)))))
 559               (fset 'gnus-tmp-func `(lambda () ,form))
 560               (byte-compile 'gnus-tmp-func)
 561               (push (nconc (butlast entry)
 562                            (list (gnus-byte-code 'gnus-tmp-func)))
 563                     gnus-format-specs-compiled)))))
 564
 565       (push (cons 'version emacs-version) gnus-format-specs)
 566       (push (cons 'version emacs-version) gnus-format-specs-compiled)
 567       (gnus-message 7 "Compiling user specs...done"))))
 568
 569 (defun gnus-set-format (type &optional insertable)
 570   (set (intern (format "gnus-%s-line-format-spec" type))
 571        (gnus-parse-format
 572         (symbol-value (intern (format "gnus-%s-line-format" type)))
 573         (symbol-value (intern (format "gnus-%s-line-format-alist" type)))
 574         insertable)))
 575
 576 (gnus-ems-redefine)
 577
 578 (provide 'gnus-spec)
 579
 580 ;; Local Variables:
 581 ;; coding: iso-8859-1
 582 ;; End:
 583
 584 ;;; gnus-spec.el ends here