cgit.sxemacs.org Git - packages/blob - xemacs-packages/mail-lib/highlight-headers.el

   1 ;;; highlight-headers.el --- highlighting message headers.
   2
   3 ;; Copyright (C) 1992, 1993, 1994, 1995, 2002 Free Software Foundation, Inc.
   4 ;; Copyright (C) 1995 Tinker Systems
   5
   6 ;; Keywords: mail, news
   7
   8 ;; This file is part of XEmacs.
   9
  10 ;; XEmacs is free software; you can redistribute it and/or modify it
  11 ;; 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 ;; XEmacs is distributed in the hope that it will be useful, but
  16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  18 ;; General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with XEmacs; 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 ;;; Synched up with: Not in FSF.
  26
  27 ;; This code is shared by RMAIL and VM.
  28 ;;
  29 ;; Faces:
  30 ;;
  31 ;; message-headers                      the part before the colon
  32 ;; message-header-contents              the part after the colon
  33 ;; message-highlighted-header-contents  contents of "special" headers
  34 ;; message-cited-text                   quoted text from other messages
  35 ;;
  36 ;; Variables:
  37 ;;
  38 ;; highlight-headers-regexp                     what makes a "special" header
  39 ;; highlight-headers-citation-regexp            matches lines of quoted text
  40 ;; highlight-headers-citation-header-regexp     matches headers for quoted text
  41
  42 (defgroup highlight-headers nil
  43   "Fancify rfc822 documents."
  44   :group 'mail
  45   :group 'news)
  46
  47 (defgroup highlight-headers-faces nil
  48   "Faces of highlighted headers."
  49   :group 'highlight-headers
  50   :group 'faces)
  51
  52 (defface message-headers '((t (:bold t)))
  53   "Face used for header part before colon."
  54   :group 'highlight-headers-faces)
  55
  56 (defface message-header-contents '((t (:italic t)))
  57   "Face used for header part after colon."
  58   :group 'highlight-headers-faces)
  59
  60 (defface message-highlighted-header-contents '((t (:italic t :bold t)))
  61   "Face used for contents of \"special\" headers."
  62   :group 'highlight-headers-faces)
  63
  64 (defface message-cited-text '((t (:italic t)))
  65   "Face used for cited text."
  66   :group 'highlight-headers-faces)
  67
  68 (defface message-url '((t (:bold t)))
  69   "Face used for URLs."
  70   :group 'highlight-headers-faces)
  71
  72 (defface x-face '((t (:background "white" :foreground "black")))
  73   "Face used for X-Face icon."
  74   :group 'highlight-headers-faces)
  75
  76 ;;(condition-case nil
  77 ;;    (face-name 'message-addresses)
  78 ;;  (wrong-type-argument
  79 ;;   (make-face 'message-addresses)
  80 ;;   (or (face-differs-from-default-p 'message-addresses)
  81 ;;       (progn
  82 ;;       (copy-face 'bold-italic 'message-addresses)
  83 ;;       (set-face-underline-p 'message-addresses
  84 ;;                             (face-underline-p
  85 ;;                              'message-highlighted-header-contents))))))
  86
  87 (defcustom highlight-headers-regexp "Subject[ \t]*:"
  88   "*The headers whose contents should be emphasized more.
  89 The contents of these headers will be displayed in the face
  90 `message-highlighted-header-contents' instead of `message-header-contents'."
  91   :type 'regexp
  92   :group 'highlight-headers)
  93
  94 (defcustom highlight-headers-citation-regexp
  95   (concat "^\\("
  96           (mapconcat 'identity
  97            '("[ \t]*[a-zA-Z0-9_]+>+"    ; supercite
  98              "[ \t]*[>]+"               ; ">" with leading spaces
  99              "[]}<>|:]+[ \t]*"          ; other chars, no leading space
 100              )
 101            "\\|")
 102           "\\)[ \t]*")
 103   "*The pattern to match cited text.
 104 Text in the body of a message which matches this will be displayed in
 105 the face `message-cited-text'."
 106   :type 'regexp
 107   :group 'highlight-headers)
 108
 109 (defcustom highlight-headers-citation-header-regexp
 110   (concat "^In article\\|^In message\\|"
 111           "^[^ \t].*\\(writes\\|wrote\\|said\\):\n"
 112           (substring highlight-headers-citation-regexp 1))
 113   "*The pattern to match the prolog of a cited block.
 114 Text in the body of a message which matches this will be displayed in
 115 the `message-headers' face."
 116   :type 'regexp
 117   :group 'highlight-headers)
 118
 119 (defcustom highlight-headers-highlight-citation-too nil
 120   "*Whether the whole citation line should go in the `message-cited-text' face.
 121 If nil, the text matched by `highlight-headers-citation-regexp' is in the
 122 default face, and the remainder of the line is in the message-cited-text face."
 123   :type 'boolean
 124   :group 'highlight-headers)
 125
 126 (defcustom highlight-headers-max-message-size 10000
 127   "*If the message body is larger than this many chars, don't highlight it.
 128 This is to prevent us from wasting time trying to fontify things like
 129 uuencoded files and large digests.  If this is nil, all messages will
 130 be highlighted."
 131   :type '(choice integer
 132                  (const :tag "Highlight All" nil))
 133   :group 'highlight-headers)
 134
 135 (defcustom highlight-headers-hack-x-face-p (featurep 'xface)
 136   "*If true, then the bitmap in an X-Face header will be displayed
 137 in the buffer.  This assumes you have the `uncompface' and `icontopbm'
 138 programs on your path."
 139   :type 'boolean
 140   :group 'highlight-headers)
 141
 142 (defcustom highlight-headers-convert-quietly nil
 143   "*Non-nil inhibits the message that is normally displayed when external
 144 filters are used to convert an X-Face header.  This has no effect if
 145 XEmacs is compiled with internal support for x-faces."
 146   :type 'boolean
 147   :group 'highlight-headers)
 148
 149 (defcustom highlight-headers-invert-x-face-data nil
 150   "*If true, causes the foreground and background bits in an X-Face
 151 header to be flipped before the image is displayed. If you use a
 152 light foreground color on a dark background color, you probably want
 153 to set this to t. This assumes that you have the `pnminvert' program
 154 on your path.  This doesn't presently work with internal xface support."
 155   :type 'boolean
 156   :group 'highlight-headers)
 157
 158
 159 ;;;###autoload
 160 (defun highlight-headers (start end hack-sig)
 161   "Highlight message headers between start and end.
 162 Faces used:
 163   message-headers                       the part before the colon
 164   message-header-contents               the part after the colon
 165   message-highlighted-header-contents   contents of \"special\" headers
 166   message-cited-text                    quoted text from other messages
 167   message-url                           URLs (WWW uniform resource locators)
 168
 169 Variables used:
 170
 171   highlight-headers-regexp                      what makes a \"special\" header
 172   highlight-headers-citation-regexp             matches lines of quoted text
 173   highlight-headers-citation-header-regexp      matches headers for quoted text
 174
 175 If HACK-SIG is true,then we search backward from END for something that
 176 looks like the beginning of a signature block, and don't consider that a
 177 part of the message (this is because signatures are often incorrectly
 178 interpreted as cited text.)"
 179   (if (< end start)
 180       (let ((s start)) (setq start end end s)))
 181   (let* ((too-big (and highlight-headers-max-message-size
 182                        (> (- end start)
 183                           highlight-headers-max-message-size)))
 184          (real-end end)
 185          e p hend)
 186     ;; delete previous highlighting
 187     (map-extents (function (lambda (extent ignore)
 188                              (if (extent-property extent 'headers)
 189                                  (delete-extent extent))
 190                              nil))
 191                  (current-buffer) start end)
 192     (save-excursion
 193       (save-restriction
 194         (widen)
 195         ;; take off signature
 196         (if (and hack-sig (not too-big))
 197             (save-excursion
 198               (goto-char end)
 199               (if (re-search-backward "\n--+ *\n" start t)
 200                   (if (eq (char-after (point)) ?\n)
 201                       (setq end (1+ (point)))
 202                     (setq end (point))))))
 203         (narrow-to-region start end)
 204
 205         (save-restriction
 206           ;; narrow down to just the headers...
 207           (goto-char start)
 208           ;; If this search fails then the narrowing performed above
 209           ;; is sufficient
 210           (if (re-search-forward "^$" nil t)
 211               (narrow-to-region (point-min) (point)))
 212           (goto-char start)
 213           (while (not (eobp))
 214             (cond
 215              ((looking-at "^\\([^ \t\n:]+[ \t]*:\\) *\\(.*\\(\n[ \t].*\\)*\n\\)")
 216               (setq hend (match-end 0))
 217               (setq e (make-extent (match-beginning 1) (match-end 1)))
 218               (set-extent-face e 'message-headers)
 219               (set-extent-property e 'headers t)
 220               (setq p (match-end 1))
 221               (cond
 222                ((and highlight-headers-hack-x-face-p
 223                      (save-match-data (looking-at "^X-Face: *")))
 224                 ;; make the whole header invisible
 225                 (setq e (make-extent (match-beginning 0) (match-end 0)))
 226                 (set-extent-property e 'invisible t)
 227                 (set-extent-property e 'headers t)
 228                 ;; now extract the xface and put it somewhere interesting
 229                 (let ((xface (highlight-headers-x-face-to-pixmap
 230                               (match-beginning 2)
 231                               (match-end 2))))
 232                   (if (not xface)
 233                       nil               ; just leave the header invisible if
 234                                         ; we can't convert the face for some
 235                                         ; reason
 236                     (cond ((save-excursion
 237                              (goto-char (point-min))
 238                              (save-excursion (re-search-forward "^From: *"
 239                                                                 nil t)))
 240                            (setq e (make-extent (match-end 0)
 241                                                 (match-end 0))))
 242                           (t
 243                            ;; okay, make the beginning of the invisible
 244                            ;; move forward to only hide the modem noise...
 245                            (set-extent-endpoints e
 246                                                  (match-beginning 2)
 247                                                  (1- (match-end 2)))
 248                            ;; kludge: if a zero-length extent exists at the
 249                            ;; starting point of an invisible extent, then
 250                            ;; it's invisible... even if the invisible extent
 251                            ;; is start-open.
 252                            (setq e (make-extent (1- (match-beginning 2))
 253                                                 (match-beginning 2)))
 254                            ))
 255                     (set-extent-property e 'headers t)
 256                     (set-extent-end-glyph e xface))
 257                   ))
 258 ;;; I don't think this is worth the effort
 259 ;;;           ((looking-at "\\(From\\|Resent-From\\)[ \t]*:")
 260 ;;;            (setq current 'message-highlighted-header-contents)
 261 ;;;            (goto-char (match-end 0))
 262 ;;;            (or (looking-at ".*(\\(.*\\))")
 263 ;;;                (looking-at "\\(.*\\)<")
 264 ;;;                (looking-at "\\(.*\\)[@%]")
 265 ;;;                (looking-at "\\(.*\\)"))
 266 ;;;            (end-of-line)
 267 ;;;            (setq e (make-extent p (match-beginning 1)))
 268 ;;;            (set-extent-face e current)
 269 ;;;            (set-extent-property e 'headers t)
 270 ;;;            (setq e (make-extent (match-beginning 1) (match-end 1)))
 271 ;;;            (set-extent-face e 'message-addresses)
 272 ;;;            (set-extent-property e 'headers t)
 273 ;;;            (setq e (make-extent (match-end 1) (point)))
 274 ;;;            (set-extent-face e current)
 275 ;;;            (set-extent-property e 'headers t)
 276 ;;;            )
 277                ((and highlight-headers-regexp
 278                      (save-match-data (looking-at highlight-headers-regexp)))
 279                 (setq e (make-extent (match-beginning 2) (match-end 2)))
 280                 (set-extent-face e 'message-highlighted-header-contents)
 281                 (set-extent-property e 'headers t))
 282                (t
 283                 (setq e (make-extent (match-beginning 2) (match-end 2)))
 284                 (set-extent-face e 'message-header-contents)
 285                 (set-extent-property e 'headers t))
 286                )
 287               (goto-char hend))
 288              ;; ignore non-header field name lines
 289              (t (forward-line 1)))))
 290
 291         ;; now do the body, unless it's too big....
 292         (if too-big
 293             nil
 294           (while (not (eobp))
 295             (cond ((null highlight-headers-citation-regexp)
 296                    nil)
 297                   ((looking-at highlight-headers-citation-regexp)
 298                    (or highlight-headers-highlight-citation-too
 299                        (goto-char (match-end 0)))
 300                    (or (save-excursion
 301                          (beginning-of-line)
 302                          (let ((case-fold-search nil)) ; aaaaah, unix...
 303                            (looking-at "^>From ")))
 304                        (setq current 'message-cited-text)))
 305 ;;;                ((or (looking-at "^In article\\|^In message")
 306 ;;;                     (looking-at
 307 ;;;            "^[^ \t].*\\(writes\\|wrote\\|said\\):\n[ \t]+[A-Z]*[]}<>|]"))
 308 ;;;                 (setq current 'message-headers))
 309                   ((null highlight-headers-citation-header-regexp)
 310                    nil)
 311                   ((looking-at highlight-headers-citation-header-regexp)
 312                    (setq current 'message-headers))
 313                   (t (setq current nil)))
 314             (cond (current
 315                    (setq p (point))
 316                    (forward-line 1) ; this is to put the \n in the face too
 317                    (setq e (make-extent p (point)))
 318                    (forward-char -1)
 319                    (set-extent-face e current)
 320                    (set-extent-property e 'headers t)
 321                    ))
 322             (forward-line 1)))
 323         ))
 324     (save-excursion
 325       (save-restriction
 326         (widen)
 327         (narrow-to-region start real-end)
 328         (highlight-headers-mark-urls start real-end)))
 329     ))
 330
 331 \f
 332 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 333 ;;;
 334 ;;; X-Face header conversion:
 335
 336 ;;; This cache is only used if x-face conversion is done with external
 337 ;;; filters.  If XEmacs is compiled --with-xface, then it's better to
 338 ;;; convert it twice than to suck up memory for a potentially large cache of
 339 ;;; stuff that's not difficult to recreate.
 340 (defvar highlight-headers-x-face-to-pixmap-cache nil)
 341
 342 (defun highlight-headers-x-face-to-pixmap (start end)
 343   (let* ((string (if (stringp start) start (buffer-substring start end)))
 344          (data (assoc string highlight-headers-x-face-to-pixmap-cache)))
 345     (if (featurep 'xface)
 346         (let ((new-face (make-glyph (concat "X-Face: " string))))
 347           (set-glyph-face new-face 'x-face)
 348           new-face)
 349       ;; YUCK this is the old two-external-filters-plus-a-bunch-of-lisp method
 350       (if data
 351           (cdr data)
 352         (setq data (cons string
 353                          (condition-case c
 354                              (highlight-headers-parse-x-face-data start end)
 355                            (error
 356                             (display-error c nil)
 357                             (sit-for 2)
 358                             nil))))
 359         (setq highlight-headers-x-face-to-pixmap-cache
 360               (cons data highlight-headers-x-face-to-pixmap-cache))
 361         (cdr data)))
 362     ))
 363
 364 ;;; Kludge kludge kludge for displaying the bitmap in the X-Face header.
 365
 366 ;;; This depends on the following programs: icontopbm, from the pbmplus
 367 ;;; toolkit (available everywhere) and uncompface, which comes with
 368 ;;; several faces-related packages, and can also be had at ftp.clark.net
 369 ;;; in /pub/liebman/compface.tar.Z.  See also xfaces 3.*.  Not needed
 370 ;;; for this, but a very nice xbiff replacment.
 371
 372 (defconst highlight-headers-x-face-bitrev
 373   (purecopy
 374    (eval-when-compile
 375      (let* ((v (make-string 256 0))
 376             (i (1- (length v))))
 377        (while (>= i 0)
 378          (let ((j 7)
 379                (k 0))
 380            (while (>= j 0)
 381              (if (/= 0 (logand i (lsh 1 (- 7 j))))
 382                  (setq k (logior k (lsh 1 j))))
 383              (setq j (1- j)))
 384            (aset v i k))
 385          (setq i (1- i)))
 386        v))))
 387
 388 (defun highlight-headers-parse-x-face-data (start end)
 389   (save-excursion
 390     (let ((b (current-buffer))
 391           (lines 0)
 392           p)
 393       (or highlight-headers-convert-quietly
 394           (message "Converting X-Face header to pixmap ..."))
 395       (set-buffer (get-buffer-create " *x-face-tmp*"))
 396       (buffer-disable-undo (current-buffer))
 397       (erase-buffer)
 398       (if (stringp start)
 399           (insert start)
 400         (insert-buffer-substring b start end))
 401       (while (search-forward "\n" nil t)
 402         (skip-chars-backward " \t\n")
 403         (setq p (point))
 404         (skip-chars-forward " \t\n")
 405         (delete-region p (point)))
 406       (call-process-region (point-min) (point-max) "uncompface" t t nil)
 407       (goto-char (point-min))
 408       (while (not (eobp))
 409         (or (looking-at "0x....,0x....,0x...., *$")
 410             (error "unexpected uncompface output"))
 411         (forward-line 1)
 412         (setq lines (1+ lines))
 413         (delete-char -1))
 414       (goto-char (point-min))
 415       (insert (format "/* Format_version=1, Width=%d, Height=%d" lines lines))
 416       (insert ", Depth=1, Valid_bits_per_item=16\n */\n")
 417       (while (not (eobp))
 418         (insert ?\t)
 419         (forward-char 56) ; 7 groups per line
 420         (insert ?\n))
 421       (forward-char -1)
 422       (delete-char -1)  ; take off last comma
 423       ;;
 424       ;; Ok, now we've got the format that "icontopbm" knows about.
 425       (call-process-region (point-min) (point-max) "icontopbm" t t nil)
 426       ;; Invert the image if the user wants us to...
 427       (if highlight-headers-invert-x-face-data
 428           (call-process-region (point-min) (point-max) "pnminvert" t t nil))
 429       ;;
 430       ;; If PBM is using binary mode, we're winning.
 431       (goto-char (point-min))
 432       (let ((new-face))
 433         (cond ((looking-at "P4\n")
 434                (forward-line 2)
 435                (delete-region (point-min) (point))
 436                (while (not (eobp))
 437                  (insert (aref highlight-headers-x-face-bitrev
 438                                (following-char)))
 439                  (delete-char 1))
 440                (setq new-face (make-glyph
 441                                (vector 'xbm :data
 442                                        (list lines lines (prog1 (buffer-string)
 443                                                            (erase-buffer))))))
 444                (set-glyph-image new-face "[xface]" 'global 'tty)
 445                (set-glyph-face new-face 'x-face))
 446               (t ; fix me
 447                (error "I only understand binary-format PBM...")))
 448         (or highlight-headers-convert-quietly
 449             (message "Converting X-Face header to pixmap ... done."))
 450         new-face)
 451       )))
 452
 453 \f
 454 ;;; "The Internet's new BBS!" -Boardwatch Magazine
 455 ;;; URL support by jwz@jwz.org
 456
 457 (defcustom highlight-headers-mark-urls (string-match "XEmacs" emacs-version)
 458   "*Whether to make URLs clickable in message bodies."
 459   :type 'boolean
 460   :group 'highlight-headers)
 461
 462 ;; We use browse-url for opening the URLs.
 463
 464 (defvar highlight-headers-follow-url-function 'w3-fetch "Not used.")
 465 (make-obsolete-variable 'highlight-headers-follow-url-function
 466                         'browse-url-browser-function)
 467
 468 (defvar highlight-headers-follow-url-netscape-auto-raise t "Not used.")
 469 (make-obsolete-variable
 470  'highlight-headers-follow-url-netscape-auto-raise "see `browse-url-netscape'")
 471
 472 (define-obsolete-variable-alias
 473   'highlight-headers-follow-url-netscape-new-window
 474   'browse-url-new-window-flag)
 475
 476 ;;;###autoload
 477 (define-obsolete-function-alias
 478   'highlight-headers-follow-url-netscape 'browse-url-netscape)
 479
 480 ;;;###autoload
 481 (define-obsolete-function-alias
 482   'highlight-headers-follow-url-kfm 'browse-url-kde)
 483
 484 ;;;###autoload
 485 (define-obsolete-function-alias
 486   'highlight-headers-follow-url-mosaic 'browse-url-mosaic)
 487
 488 (defvar highlight-headers-url-keymap
 489   (let ((m (make-sparse-keymap)))
 490     (set-keymap-name m 'highlight-headers-url-keymap)
 491     (if (string-match "XEmacs" emacs-version)
 492         (progn
 493           (define-key m 'button2 'highlight-headers-follow-url)
 494           ))
 495     m))
 496
 497 ;;;###autoload
 498 (defun highlight-headers-follow-url (event)
 499   (interactive "e")
 500   (let* ((p (event-point event))
 501          (buffer (window-buffer (event-window event)))
 502          (extent (and p (extent-at p buffer 'highlight)))
 503          (url (and extent
 504                    (save-excursion
 505                      (set-buffer buffer)
 506                      (buffer-substring (extent-start-position extent)
 507                                        (extent-end-position extent))))))
 508     (if (and url (string-match "\\`<\\([^>]+\\)>\\'" url))
 509         (setq url (concat "news:"
 510                           (substring url (match-beginning 1) (match-end 1)))))
 511     (if url
 512         (browse-url url)
 513       (beep))))
 514
 515
 516 (defconst highlight-headers-url-pattern
 517   (concat
 518    "\\b\\(s?https?\\|ftp\\|file\\|gopher\\|s?news\\|telnet\\|mailbox\\):"
 519           "\\(//[-a-zA-Z0-9_.]+:[0-9]*\\)?"
 520           "[-a-zA-Z0-9_=?#$@~`%&*+|\\/.,]+"
 521           ))
 522
 523 (defun highlight-headers-mark-urls (start end)
 524   (cond
 525    (highlight-headers-mark-urls
 526     (save-excursion
 527       (goto-char start)
 528       (while (re-search-forward highlight-headers-url-pattern nil t)
 529         (let ((s (match-beginning 0))
 530               e
 531               extent)
 532           (goto-char (match-end 0))
 533           ;(skip-chars-forward "^ \t\n\r")
 534           (skip-chars-backward ".?#!*()")
 535           (setq e (point))
 536           (setq extent (make-extent s e))
 537           (set-extent-face extent 'bold)
 538           (set-extent-property extent 'highlight t)
 539           (set-extent-property extent 'headers t)
 540           (set-extent-property extent 'keymap highlight-headers-url-keymap)
 541           ))
 542
 543       (goto-char start)
 544       (while (re-search-forward "^Message-ID: \\(<[^>\n]+>\\)" nil t)
 545         (let ((s (match-beginning 1))
 546               (e (match-end 1))
 547               extent)
 548           (setq extent (make-extent s e))
 549           (set-extent-face extent 'message-url)
 550           (set-extent-property extent 'highlight t)
 551           (set-extent-property extent 'headers t)
 552           (set-extent-property extent 'keymap highlight-headers-url-keymap)))
 553       ))))
 554
 555 \f
 556 (provide 'highlight-headers)