lisp/riece-display.el

   1 ;;; riece-display.el --- buffer arrangement
   2 ;; Copyright (C) 1998-2003 Daiki Ueno
   3
   4 ;; Author: Daiki Ueno <ueno@unixuser.org>
   5 ;; Created: 1998-09-28
   6 ;; Keywords: IRC, riece
   7
   8 ;; This file is part of Riece.
   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, or (at your option)
  13 ;; 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
  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 ;;; Code:
  26
  27 (require 'riece-options)
  28 (require 'riece-channel)
  29 (require 'riece-misc)
  30 (require 'riece-layout)
  31
  32 (defvar riece-channel-buffer-format "*Channel:%s*"
  33   "Format of channel message buffer.")
  34 (defvar riece-channel-buffer-alist nil
  35   "An alist mapping identities to channel buffers.")
  36
  37 (defvar riece-update-buffer-functions nil
  38   "Functions to redisplay the buffer.
  39 Local to the buffer in `riece-buffer-list'.")
  40
  41 (defvar riece-update-indicator-functions
  42   '(riece-update-status-indicators
  43     riece-update-channel-indicator
  44     riece-update-long-channel-indicator
  45     riece-update-channel-list-indicator)
  46   "Functions to update modeline indicators.")
  47
  48 ;;; Qt like "signal-slot" abstraction for routing display events.
  49 (defvar riece-signal-slot-obarray
  50   (make-vector 31 0))
  51
  52 (defun riece-make-slot (function &optional filter handback)
  53   "Make an instance of slot object.
  54 Arguments are corresponding to callback function, filter function, and
  55 a handback object, respectively."
  56   (vector function filter handback))
  57
  58 (defun riece-slot-function (slot)
  59   "Return the callback function of SLOT."
  60   (aref slot 0))
  61
  62 (defun riece-slot-filter (slot)
  63   "Return the filter function of SLOT."
  64   (aref slot 1))
  65
  66 (defun riece-slot-handback (slot)
  67   "Return the handback object of SLOT."
  68   (aref slot 2))
  69
  70 (defun riece-make-signal (name &rest args)
  71   "Make an instance of signal object.
  72 The 1st arguments is the name of the signal and the rest of arguments
  73 are the data of the signal."
  74   (vector name args))
  75
  76 (defun riece-signal-name (signal)
  77   "Return the name of SIGNAL."
  78   (aref signal 0))
  79
  80 (defun riece-signal-args (signal)
  81   "Return the data of SIGNAL."
  82   (aref signal 1))
  83
  84 (defun riece-connect-signal (signal-name slot)
  85   "Add SLOT as a listener of a signal identified by SIGNAL-NAME."
  86   (let ((symbol (intern (symbol-name signal-name) riece-signal-slot-obarray)))
  87     (set symbol (cons slot (if (boundp symbol)
  88                                (symbol-value symbol))))))
  89
  90 (defun riece-emit-signal (signal)
  91   "Emit SIGNAL."
  92   (let ((symbol (intern-soft (symbol-name (riece-signal-name signal))
  93                              riece-signal-slot-obarray))
  94         slots)
  95     (when symbol
  96       (setq slots (symbol-value symbol))
  97       (while slots
  98         (condition-case error
  99             (if (or (null (riece-slot-filter (car slots)))
 100                     (funcall (riece-slot-filter (car slots)) signal))
 101                 (funcall (riece-slot-function (car slots))
 102                          signal (riece-slot-handback (car slots))))
 103           (error
 104            (if riece-debug
 105                (message "Error occurred in slot function for signal \"%S\": %S"
 106                         (riece-signal-name signal) error))))
 107         (setq slots (cdr slots))))))
 108
 109 (defun riece-update-user-list-buffer ()
 110   (save-excursion
 111     (set-buffer riece-user-list-buffer)
 112     (if (and riece-current-channel
 113              (riece-channel-p (riece-identity-prefix riece-current-channel)))
 114         (let* ((users
 115                 (with-current-buffer (process-buffer (riece-server-process
 116                                                       (riece-identity-server
 117                                                        riece-current-channel)))
 118                   (riece-channel-get-users (riece-identity-prefix
 119                                             riece-current-channel))))
 120                (inhibit-read-only t)
 121                buffer-read-only)
 122           (erase-buffer)
 123           (riece-kill-all-overlays)
 124           (while users
 125             (insert (if (memq ?o (cdr (car users)))
 126                         "@"
 127                       (if (memq ?v (cdr (car users)))
 128                           "+"
 129                         " "))
 130                     (riece-format-identity
 131                      (riece-make-identity (car (car users))
 132                                           (riece-identity-server
 133                                            riece-current-channel))
 134                      t)
 135                     "\n")
 136             (setq users (cdr users)))))))
 137
 138 (defun riece-update-channel-list-buffer ()
 139   (save-excursion
 140     (set-buffer riece-channel-list-buffer)
 141     (let ((inhibit-read-only t)
 142           buffer-read-only
 143           (index 1)
 144           (channels riece-current-channels))
 145       (erase-buffer)
 146       (riece-kill-all-overlays)
 147       (while channels
 148         (if (car channels)
 149             (insert (riece-format-channel-list-line
 150                      index (car channels))))
 151         (setq index (1+ index)
 152               channels (cdr channels))))))
 153
 154 (defun riece-format-channel-list-line (index channel)
 155   (or (run-hook-with-args-until-success
 156        'riece-format-channel-list-line-functions index channel)
 157       (concat (format "%2d:%c" index
 158                       (if (riece-identity-equal channel riece-current-channel)
 159                           ?*
 160                         ? ))
 161               (riece-format-identity channel)
 162               "\n")))
 163
 164 (defun riece-update-channel-indicator ()
 165   (setq riece-channel-indicator
 166         (if riece-current-channel
 167             (riece-format-identity riece-current-channel)
 168           "None")))
 169
 170 (defun riece-update-long-channel-indicator ()
 171   (setq riece-long-channel-indicator
 172         (if riece-current-channel
 173             (if (riece-channel-p (riece-identity-prefix riece-current-channel))
 174                 (riece-concat-channel-modes
 175                  riece-current-channel
 176                  (riece-concat-channel-topic
 177                   riece-current-channel
 178                   (riece-format-identity riece-current-channel)))
 179               (riece-format-identity riece-current-channel))
 180           "None")))
 181
 182 (defun riece-update-channel-list-indicator ()
 183   (if (and riece-current-channels
 184            ;; There is at least one channel.
 185            (delq nil (copy-sequence riece-current-channels)))
 186       (let ((index 1))
 187         (setq riece-channel-list-indicator
 188               (mapconcat
 189                #'identity
 190                (delq nil
 191                      (mapcar
 192                       (lambda (channel)
 193                         (prog1
 194                             (if channel
 195                                 (format "%d:%s" index
 196                                         (riece-format-identity channel)))
 197                           (setq index (1+ index))))
 198                       riece-current-channels))
 199                ",")))
 200     (setq riece-channel-list-indicator "No channel")))
 201
 202 (defun riece-update-status-indicators ()
 203   (if riece-current-channel
 204       (with-current-buffer riece-command-buffer
 205         (riece-with-server-buffer (riece-identity-server riece-current-channel)
 206           (setq riece-away-indicator
 207                 (if (and riece-real-nickname
 208                          (riece-user-get-away riece-real-nickname))
 209                     "A"
 210                   "-")
 211                 riece-operator-indicator
 212                 (if (and riece-real-nickname
 213                          (riece-user-get-operator riece-real-nickname))
 214                     "O"
 215                   "-")
 216                 riece-user-indicator riece-real-nickname))))
 217   (setq riece-freeze-indicator
 218         (with-current-buffer (if (and riece-channel-buffer-mode
 219                                       riece-channel-buffer)
 220                                  riece-channel-buffer
 221                                riece-dialogue-buffer)
 222           (if (eq riece-freeze 'own)
 223               "f"
 224             (if riece-freeze
 225                 "F"
 226               "-")))))
 227
 228 (defun riece-update-buffers (&optional buffers)
 229   (unless buffers
 230     (setq buffers riece-buffer-list))
 231   (while buffers
 232     (save-excursion
 233       (set-buffer (car buffers))
 234       (run-hooks 'riece-update-buffer-functions))
 235     (setq buffers (cdr buffers)))
 236   (run-hooks 'riece-update-indicator-functions)
 237   (force-mode-line-update t)
 238   (run-hooks 'riece-update-buffer-hook))
 239
 240 (defun riece-channel-buffer-name (identity)
 241   (let ((channels (riece-identity-member identity riece-current-channels)))
 242     (if channels
 243         (setq identity (car channels))
 244       (if riece-debug
 245           (message "%S is not a member of riece-current-channels" identity)))
 246     (format riece-channel-buffer-format (riece-format-identity identity))))
 247
 248 (eval-when-compile
 249   (autoload 'riece-channel-mode "riece"))
 250 (defun riece-channel-buffer-create (identity)
 251   (with-current-buffer
 252       (riece-get-buffer-create (riece-channel-buffer-name identity)
 253                                'riece-channel-mode)
 254     (setq riece-channel-buffer-alist
 255           (cons (cons identity (current-buffer))
 256                 riece-channel-buffer-alist))
 257     (unless (eq major-mode 'riece-channel-mode)
 258       (riece-channel-mode)
 259       (let (buffer-read-only)
 260         (riece-insert-info (current-buffer)
 261                            (concat "Created on "
 262                                    (funcall riece-format-time-function
 263                                             (current-time))
 264                                    "\n"))
 265         (run-hook-with-args 'riece-channel-buffer-create-functions identity)))
 266     (current-buffer)))
 267
 268 (defun riece-channel-buffer (identity)
 269   (cdr (riece-identity-assoc identity riece-channel-buffer-alist)))
 270
 271 (defun riece-switch-to-channel (identity)
 272   (let ((last riece-current-channel))
 273     (setq riece-current-channel identity
 274           riece-channel-buffer (riece-channel-buffer riece-current-channel))
 275     (run-hook-with-args 'riece-after-switch-to-channel-functions last)))
 276
 277 (defun riece-join-channel (identity)
 278   (unless (riece-identity-member identity riece-current-channels)
 279     (setq riece-current-channels
 280           (riece-identity-assign-binding
 281            identity riece-current-channels
 282            (mapcar
 283             (lambda (channel)
 284               (if channel
 285                   (riece-parse-identity channel)))
 286             riece-default-channel-binding)))
 287     (riece-channel-buffer-create identity)))
 288
 289 (defun riece-switch-to-nearest-channel (pointer)
 290   (let ((start riece-current-channels)
 291         identity)
 292     (while (and start (not (eq start pointer)))
 293       (if (car start)
 294           (setq identity (car start)))
 295       (setq start (cdr start)))
 296     (unless identity
 297       (while (and pointer
 298                   (null (car pointer)))
 299         (setq pointer (cdr pointer)))
 300       (setq identity (car pointer)))
 301     (if identity
 302         (riece-switch-to-channel identity)
 303       (let ((last riece-current-channel))
 304         (run-hook-with-args 'riece-after-switch-to-channel-functions last)
 305         (setq riece-current-channel nil)))))
 306
 307 (defun riece-part-channel (identity)
 308   (let ((pointer (riece-identity-member identity riece-current-channels)))
 309     (if pointer
 310         (setcar pointer nil))
 311     (if (riece-identity-equal identity riece-current-channel)
 312         (riece-switch-to-nearest-channel pointer))))
 313
 314 (defun riece-redisplay-buffers (&optional force)
 315   (riece-update-buffers)
 316   (riece-redraw-layout force)
 317   (run-hooks 'riece-redisplay-buffers-hook))
 318
 319 (provide 'riece-display)
 320
 321 ;;; riece-display.el ends here