cgit.sxemacs.org Git - packages/blob - xemacs-packages/vm/lisp/vm-biff.el

   1 ;;; vm-biff.el --- a xlbiff like tool for VM
   2 ;;
   3 ;; Copyright (C) 2001 Robert Fenk
   4 ;;
   5 ;; Author:      Robert Fenk
   6 ;; Status:      Tested with XEmacs 21.4.15 & VM 7.18
   7 ;; Keywords:    VM helpers
   8 ;; X-URL:       http://www.robf.de/Hacking/elisp
   9
  10 ;; This program 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 of the License, or
  13 ;; (at your option) any later version.
  14 ;;
  15 ;; This program 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 along
  21 ;; with this program; if not, write to the Free Software Foundation, Inc.,
  22 ;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  23
  24 ;;; Commentary:
  25 ;;
  26 ;; Put this file into your load path and add the following line to your .vm
  27 ;; file
  28 ;;
  29 ;; (require 'vm-biff)
  30 ;;
  31 ;; Try: M-x customize-group vm-biff RET
  32 ;;
  33 ;; You should set `vm-auto-get-newmail', since otherwise this package
  34 ;; does not make any sense!  If getting mail is slow, use fetchmail to
  35 ;; retrieve it to a local file and uses that file as VM spool file!
  36 ;;
  37
  38
  39 (eval-when-compile
  40   (require 'cl))
  41
  42 (when vm-xemacs-p
  43   (require 'overlay))
  44
  45 (defgroup vm nil
  46   "VM"
  47   :group 'mail)
  48
  49 (defgroup vm-biff nil
  50   "The VM biff lib"
  51   :group 'vm)
  52
  53 (defcustom vm-biff-position 'center
  54   "*Position of the popup-frame."
  55   :group 'vm-biff
  56   :type '(choice (const :tag "center the popup frame" center)
  57                  (list  :tag "Position of the top-left corner."
  58                         :value (1 1)
  59                         (integer :tag "X")
  60                         (integer :tag "Y"))))
  61
  62
  63 (defcustom vm-biff-width 120
  64   "*Width of the popup-frame."
  65   :group 'vm-biff
  66   :type 'integer)
  67
  68 (defcustom vm-biff-max-height 10
  69   "*Maximum hight of the popup window."
  70   :group 'vm-biff
  71   :type 'integer)
  72
  73 (defcustom vm-biff-body-peek 50
  74   "*Maximum number of chractes to peek into the body of a message."
  75   :group 'vm-biff
  76   :type 'integer)
  77
  78
  79 (defcustom vm-biff-focus-popup nil
  80   "*t if popup window should get the focus after an update."
  81   :group 'vm-biff
  82   :type 'boolean)
  83
  84 (defcustom vm-biff-auto-remove nil
  85   "*Number of seconds after the popup window is automatically removed."
  86   :group 'vm-biff
  87   :type '(choice (integer :tag "Number of seconds" 10)
  88                  (const   :tag "Disable remove" nil)))
  89
  90 (defcustom vm-biff-summary-format nil
  91   "*Like `vm-summary-format' but for popup buffers."
  92   :group 'vm-biff
  93   :type '(choice (string :tag "Summary format")
  94                  (const  :tag "Disable own format" nil)))
  95
  96 (defcustom vm-biff-selector '(and (new)
  97                                   (not (deleted))
  98                                   (not (outgoing)))
  99   "*virtual folder selector matching messages to display in the pop-up."
 100   :group 'vm-biff
 101   :type 'sexp)
 102
 103 (defcustom vm-biff-place-frame-function 'vm-biff-place-frame
 104   "*Function that sets the popup frame position and size."
 105   :group 'vm-biff
 106   :type 'function)
 107
 108 (defcustom vm-biff-select-hook nil
 109   "*List of hook functions to be run when selection a message."
 110   :group 'vm-biff
 111   :type '(repeat (function)))
 112
 113 (defcustom vm-biff-select-frame-hook nil
 114   "*List of hook functions to be run when selection a message.
 115 You may want to add `vm-biff-fvwm-focus-vm-folder-frame'.
 116 "
 117   :group 'vm-biff
 118   :type '(repeat (function)))
 119
 120 (defcustom vm-biff-folder-list nil
 121   "*List of folders to generate a popup for.
 122 The default is all spool files listed in `vm-spool-files'.
 123 Testing is done by string-matching it against the current buffer-file-name.
 124
 125 Another form is an alist of elements (FODERNAME SELECTOR),
 126 where SELECTOR is a virtual folder selector matching the
 127 messges which should be displayed.  See `vm-biff-selector'
 128 for an example and `vm-virtual-folder-alist' on how virtual
 129 folder selectors work."
 130   :group 'vm-biff
 131   :type '(repeat (string)))
 132
 133 (defvar vm-biff-keymap nil
 134   "Keymap for vm-biff popup buffers.")
 135
 136 (when (not vm-biff-keymap)
 137   (setq vm-biff-keymap (make-sparse-keymap "VM Biff"))
 138   (define-key vm-biff-keymap "q" 'vm-biff-delete-popup)
 139   (define-key vm-biff-keymap " " 'vm-biff-delete-popup)
 140   (define-key vm-biff-keymap [(space)] 'vm-biff-delete-popup)
 141   (define-key vm-biff-keymap [(button1)] 'vm-biff-delete-popup)
 142   (define-key vm-biff-keymap [(mouse-1)] 'vm-biff-delete-popup)
 143   (define-key vm-biff-keymap [(return)] 'vm-biff-select-message)
 144   (define-key vm-biff-keymap [(button2)] 'vm-biff-select-message-mouse)
 145   (define-key vm-biff-keymap [(mouse-2)] 'vm-biff-select-message-mouse))
 146
 147 (defun vm-summary-function-V (msg)
 148   (let ((body-start (vm-text-of msg))
 149         (body-end (vm-end-of msg))
 150         peek)
 151     (if (< vm-biff-body-peek (- body-end body-start))
 152         (setq body-end (+ vm-biff-body-peek body-start)))
 153     (save-excursion
 154       (save-restriction
 155         (set-buffer (vm-buffer-of msg))
 156         (widen)
 157         (goto-char body-end)
 158         (re-search-forward "$" (point-max) t)
 159         (setq peek (vm-decode-mime-encoded-words-in-string
 160                     (buffer-substring body-start (point))))
 161         (let ((pos 0))
 162           (if (string-match "^\n+" peek pos)
 163               (setq peek (replace-match "" t t peek)))
 164           (while (setq pos (string-match "\n\n+" peek pos))
 165             (setq peek (replace-match "\n" t t peek)))
 166           (setq pos 0)
 167           (while (setq pos (string-match "\n" peek pos))
 168             (setq peek (replace-match "\n\t" t t peek)
 169                   pos (+ 2 pos))))
 170         (setq peek (concat "\t" peek))
 171         (put-text-property 0 (length peek) 'face 'bold peek)
 172         peek))))
 173
 174 (defun vm-biff-place-frame (&optional f)
 175   "Centers the frame and limits it to `vm-biff-max-height' lines."
 176   (let ((f (or f (selected-frame)))
 177         (height (1+ (count-lines (point-min) (point-max)))))
 178     (if (> height vm-biff-max-height)
 179         (setq height vm-biff-max-height))
 180     (set-frame-size f vm-biff-width height)
 181
 182     (if (eq 'center vm-biff-position)
 183         (set-frame-position
 184          f
 185          (/ (- (x-display-pixel-width) (frame-pixel-width f)) 2)
 186          (/ (- (x-display-pixel-height) (frame-pixel-height f)) 2))
 187       (apply 'set-frame-position f vm-biff-position))))
 188
 189 (defconst vm-biff-frame-properties
 190   '(;; common properties
 191     (name . "New Mail")
 192     (unsplittable . t)
 193     (minibuffer . nil)
 194     (user-position . t)
 195     (menubar-visible-p . nil)
 196     (default-toolbar-visible-p . nil)
 197 ;    (has-modeline-p . nil)
 198     (top . 1)
 199     (left . 1)
 200     ;; Xemacs properties
 201     (initially-unmapped . t)
 202     (modeline-shadow-thickness . 0)
 203     (vertical-scrollbar . nil)
 204     ;; GNU Emacs properties
 205     (vertical-scroll-bars . nil)
 206     (menu-bar-lines . 0)
 207     (tool-bar-lines . 0)
 208     (visibility . nil)
 209     )
 210   "Default properties for popup frame.")
 211
 212 (defvar vm-biff-message-pointer nil)
 213 (defvar vm-biff-folder-buffer nil)
 214 (defvar vm-biff-message-number nil)
 215 (defvar vm-biff-folder-frame nil)
 216 (defvar vm-biff--folder-window nil)
 217
 218 (defun vm-biff-x-p ()
 219   (if vm-xemacs-p
 220       (memq (console-type) '(x mswindows))
 221     t))
 222
 223 (defun vm-biff-get-buffer-window (buf)
 224   (if vm-xemacs-p
 225       (get-buffer-window buf (vm-biff-x-p) (frame-device))
 226     (get-buffer-window buf (vm-biff-x-p))))
 227
 228 (defun  vm-biff-find-folder-window (msg)
 229   (let ((buf (vm-buffer-of msg)))
 230     (save-excursion
 231       (set-buffer buf)
 232       (or (vm-biff-get-buffer-window buf)
 233           (and vm-presentation-buffer
 234                (vm-biff-get-buffer-window  vm-presentation-buffer))
 235           (and vm-summary-buffer
 236                (vm-biff-get-buffer-window vm-summary-buffer))))))
 237
 238 (defun  vm-biff-find-folder-frame (msg)
 239   (let ((ff (vm-biff-find-folder-window msg)))
 240     (if ff (window-frame ff))))
 241
 242 ;;;###autoload
 243 (defun vm-biff-select-message ()
 244   "Put focus on the folder frame and select the appropiate message."
 245   (interactive)
 246   (let* ((vm-biff-message-pointer
 247           (or (get-text-property (point) 'vm-message-pointer)
 248               vm-biff-message-pointer))
 249          (msg (car vm-biff-message-pointer))
 250          (vm-biff-message-number (vm-number-of msg))
 251          (vm-biff-folder-buffer (vm-buffer-of msg))
 252          (vm-biff-folder-window (vm-biff-find-folder-window msg))
 253          vm-biff-folder-frame)
 254
 255     (if vm-biff-folder-window
 256         (setq vm-biff-folder-frame (window-frame vm-biff-folder-window)))
 257
 258     (setq vm-biff-message-pointer nil)
 259     (vm-biff-delete-popup)
 260
 261     (cond ((and vm-biff-folder-frame (vm-biff-x-p))
 262            (select-frame vm-biff-folder-frame)
 263            (focus-frame vm-biff-folder-frame)
 264            (raise-frame vm-biff-folder-frame)
 265            (run-hooks 'vm-biff-select-frame-hook)
 266            (select-window vm-biff-folder-window))
 267           (vm-biff-folder-window
 268            (select-window vm-biff-folder-window))
 269           (t
 270            (bury-buffer)
 271            (switch-to-buffer vm-biff-folder-buffer)))
 272
 273     (sit-for 0)
 274
 275     (if vm-biff-message-number
 276         (vm-goto-message (string-to-number (vm-number-of msg))))
 277
 278     (run-hooks 'vm-biff-select-hook)))
 279
 280 ;;;###autoload
 281 (defun vm-biff-select-message-mouse (event)
 282   (interactive "e")
 283   (mouse-set-point event)
 284   (vm-biff-select-message))
 285
 286 (defcustom vm-biff-FvwmCommand-path "/usr/bin/FvwmCommand"
 287   "Full qualified path to FvwmCommand."
 288   :group 'vm-biff
 289   :type 'file)
 290
 291 ;;;###autoload
 292 (defun vm-biff-fvwm-focus-vm-folder-frame ()
 293   "Jumps to the frame containing the folder for the selected message.
 294
 295 1) Your Emacs frame needs to have the folder name in its title, see the
 296    variable `frame-title-format' on how to set this up.
 297
 298 2) You need to define the FVWM2 function SelectWindow and start the
 299    FvwmCommandS module.  Therefore, you will need the following lines
 300    in your .fvwm2rc file.
 301
 302 AddToFunc InitFunction
 303 + I Module FvwmCommandS
 304
 305 AddToFunc RestartFunction
 306 + I Module FvwmCommandS
 307
 308 AddToFunc SelectWindow
 309 + I Next ($0) Iconify false
 310 + I Next ($0) Raise
 311 + I Next ($0) WarpToWindow 10p 10p
 312 "
 313   (interactive)
 314   (let ((p (start-process "FvwmCommand"
 315                           " *FvwmCommand*"
 316                           vm-biff-FvwmCommand-path
 317                           "-c")))
 318     (process-send-string p (concat "SelectWindow *"
 319                                    (buffer-name vm-biff-folder-buffer)
 320                                    "*\n"))
 321     (process-send-eof p)))
 322
 323 ;;;###autoload
 324 (defun vm-biff-delete-popup (&optional wf)
 325   (interactive)
 326   (if (vm-biff-x-p)
 327       (delete-frame wf)
 328     (if (not (one-window-p))
 329         (delete-window wf)))
 330   (sit-for 0))
 331
 332 (defun vm-biff-timer-delete-popup (wf)
 333   (if (featurep 'itimer)
 334       (delete-itimer current-itimer))
 335   (vm-biff-delete-popup wf))
 336
 337 (defvar vm-biff-message-pointer nil)
 338 (make-variable-buffer-local 'vm-biff-message-pointer)
 339
 340 ;;;###autoload
 341 (defun vm-biff-popup (&optional force)
 342   "Scan the current VM folder for new messages and popup a summary frame."
 343   (interactive (list current-prefix-arg))
 344
 345   (save-excursion
 346     (vm-select-folder-buffer)
 347
 348     (when (not vm-biff-folder-list)
 349       (setq vm-biff-folder-list
 350             (if (stringp (car vm-spool-files))
 351                 (list (expand-file-name
 352                        vm-primary-inbox
 353                        vm-folder-directory))
 354               (mapcar (lambda (f)
 355                         (expand-file-name
 356                          (car f)
 357                          vm-folder-directory))
 358                       vm-spool-files))))
 359
 360     (let* ((mp vm-message-pointer)
 361            (folder (buffer-name))
 362            (do-mouse-track
 363             (and vm-mouse-track-summary
 364                  (vm-mouse-support-possible-p)))
 365            (buf (get-buffer-create
 366                  (concat " *new messages in VM folder: " folder "*")))
 367            selector msg new-messages wf)
 368
 369       (let ((fl vm-biff-folder-list))
 370         (while fl
 371           (if (stringp (car fl))
 372               (if (string-match (car fl) (or (buffer-file-name)
 373                                              (buffer-name)))
 374                   (setq selector (list vm-biff-selector) fl nil))
 375             (if (string-match (caar fl) (or (buffer-file-name)
 376                                             (buffer-name)))
 377                 (setq selector (cdar fl) fl nil)))
 378           (setq fl (cdr fl))))
 379
 380       (when selector
 381         ;; collect the new messages
 382         (set-buffer buf)
 383         (setq buffer-read-only nil)
 384         (erase-buffer)
 385
 386         (let (start)
 387           (while mp
 388             (setq msg (car mp))
 389             (when (apply 'vm-vs-or msg selector)
 390               (setq start (point))
 391               (vm-tokenized-summary-insert msg
 392                                            (vm-summary-sprintf
 393                                             (or vm-biff-summary-format
 394                                                 vm-summary-format)
 395                                             msg t))
 396               (put-text-property start (point) 'vm-message-pointer mp)
 397
 398               (vm-summary-highlight-region start (point)
 399                                            vm-summary-highlight-face)
 400
 401               (when do-mouse-track
 402                 (vm-mouse-set-mouse-track-highlight
 403                  start (point)))
 404
 405               (if (not new-messages) (setq new-messages mp)))
 406             (setq mp (cdr mp))))
 407
 408         (when (and new-messages
 409                    (or force
 410                        (not (equal new-messages vm-biff-message-pointer))))
 411           (setq msg (car new-messages))
 412           (backward-delete-char 1)
 413           (goto-char (point-min))
 414
 415           (setq truncate-lines t
 416                 buffer-read-only t)
 417           (use-local-map vm-biff-keymap)
 418           (setq vm-biff-message-pointer new-messages)
 419
 420           ;; if in the minibuffer then seletc a different window
 421           (if (active-minibuffer-window)
 422               (other-window))
 423
 424           ;; generate a own window/frame showing the messages
 425           (if (vm-biff-x-p)
 426               ;; X Window System or MS Windows
 427               (let* ((sf (selected-frame))
 428                      (ff (vm-biff-find-folder-frame msg))
 429                      (props (if ff
 430                                 (cons (cons 'popup ff)
 431                                       vm-biff-frame-properties)
 432                               vm-biff-frame-properties))
 433                      (mf (or (and (if vm-xemacs-p
 434                                       (get-buffer-window buf t (frame-device))
 435                                     (get-buffer-window buf t))
 436                                   (window-frame
 437                                    (vm-biff-get-buffer-window buf)))
 438                              (make-frame props))))
 439
 440                 (select-frame mf)
 441                 (switch-to-buffer buf)
 442                 (if vm-xemacs-p
 443                     (set-specifier horizontal-scrollbar-visible-p nil))
 444
 445                 (if (functionp vm-biff-place-frame-function)
 446                     (funcall vm-biff-place-frame-function))
 447
 448                 (make-frame-visible mf)
 449                 (setq wf mf)
 450
 451                 (if vm-biff-focus-popup (focus-frame mf)
 452                   (select-frame sf)))
 453
 454             ;; Terminal
 455             (let ((w (vm-get-buffer-window buf))
 456                   (window-min-height 2)
 457                   (h (count-lines (point-min) (point-max))))
 458               (if w
 459                   (if vm-biff-focus-popup (select-window w))
 460                 (setq wf (split-window (selected-window))))
 461               (sit-for 0)
 462               (switch-to-buffer buf)
 463               (if (> h vm-biff-max-height)
 464                   (setq h vm-biff-max-height))
 465               (setq h (- (window-displayed-height) h))
 466               (if (not (one-window-p))
 467                   (shrink-window h)))))
 468
 469         (if vm-biff-auto-remove
 470             (cond
 471                 ((condition-case nil
 472                      (progn (require 'itimer) t)
 473                    (error nil))
 474                  (start-itimer (buffer-name)
 475                                'vm-biff-timer-delete-popup
 476                                vm-biff-auto-remove
 477                                nil t t wf))
 478                 ((condition-case nil
 479                      (progn (require 'timer) t)
 480                    (error nil))
 481                  (run-at-time vm-biff-auto-remove nil
 482                               'vm-biff-timer-delete-popup wf))))))))
 483
 484 (add-hook 'vm-arrived-messages-hook 'vm-biff-popup t)
 485
 486 (provide 'vm-biff)