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 This function is for internal use only."
  57   (vector function filter handback))
  58
  59 (defun riece-slot-function (slot)
  60   "Return the callback function of SLOT.
  61 This function is for internal use only."
  62   (aref slot 0))
  63
  64 (defun riece-slot-filter (slot)
  65   "Return the filter function of SLOT.
  66 This function is for internal use only."
  67   (aref slot 1))
  68
  69 (defun riece-slot-handback (slot)
  70   "Return the handback object of SLOT.
  71 This function is for internal use only."
  72   (aref slot 2))
  73
  74 (defun riece-make-signal (name &rest args)
  75   "Make an instance of signal object.
  76 The 1st arguments is the name of the signal and the rest of arguments
  77 are the data of the signal."
  78   (vector name args))
  79
  80 (defun riece-signal-name (signal)
  81   "Return the name of SIGNAL."
  82   (aref signal 0))
  83
  84 (defun riece-signal-args (signal)
  85   "Return the data of SIGNAL."
  86   (aref signal 1))
  87
  88 (defun riece-connect-signal (signal-name function &optional filter handback)
  89   "Add SLOT as a listener of a signal identified by SIGNAL-NAME."
  90   (let ((symbol (intern (symbol-name signal-name) riece-signal-slot-obarray)))
  91     (set symbol (cons (riece-make-slot function filter handback)
  92                       (if (boundp symbol)
  93                           (symbol-value symbol))))))
  94
  95 (defun riece-emit-signal (signal)
  96   "Emit SIGNAL."
  97   (let ((symbol (intern-soft (symbol-name (riece-signal-name signal))
  98                              riece-signal-slot-obarray))
  99         slots)
 100     (when symbol
 101       (setq slots (symbol-value symbol))
 102       (while slots
 103         (condition-case error
 104             (if (or (null (riece-slot-filter (car slots)))
 105                     (condition-case error
 106                         (funcall (riece-slot-filter (car slots)) signal)
 107                       (if riece-debug
 108                           (message
 109                            "Error occurred in signal filter for \"%S\": %S"
 110                            (riece-signal-name signal) error))
 111                       nil))
 112                 (funcall (riece-slot-function (car slots))
 113                          signal (riece-slot-handback (car slots))))
 114           (error
 115            (if riece-debug
 116                (message "Error occurred in slot function for \"%S\": %S"
 117                         (riece-signal-name signal) error))))
 118         (setq slots (cdr slots))))))
 119
 120 (defun riece-display-connect-signals ()
 121   (riece-connect-signal
 122    'switch-to-channel
 123    (lambda (signal handback)
 124      (riece-update-status-indicators)
 125      (riece-update-channel-indicator)
 126      (riece-update-long-channel-indicator)
 127      (save-excursion
 128        (set-buffer riece-user-list-buffer)
 129        (run-hooks 'riece-update-buffer-functions))
 130      (save-excursion
 131        (set-buffer riece-channel-list-buffer)
 132        (run-hooks 'riece-update-buffer-functions))
 133      (save-excursion
 134        (riece-redraw-layout))))
 135   (riece-connect-signal
 136    'names
 137    (lambda (signal handback)
 138      (save-excursion
 139        (set-buffer riece-user-list-buffer)
 140        (run-hooks 'riece-update-buffer-functions))))
 141   (riece-connect-signal
 142    'join
 143    (lambda (signal handback)
 144      (save-excursion
 145        (set-buffer riece-user-list-buffer)
 146        (run-hooks 'riece-update-buffer-functions)))
 147    (lambda (signal)
 148      (and (riece-identity-equal (nth 1 (riece-signal-args signal))
 149                                 riece-current-channel)
 150           (not (riece-identity-equal (car (riece-signal-args signal))
 151                                      (riece-current-nickname))))))
 152   (riece-connect-signal
 153    'part
 154    (lambda (signal handback)
 155      (save-excursion
 156        (set-buffer riece-user-list-buffer)
 157        (run-hooks 'riece-update-buffer-functions)))
 158    (lambda (signal)
 159      (and (riece-identity-equal (nth 1 (riece-signal-args signal))
 160                                 riece-current-channel)
 161           (not (riece-identity-equal (car (riece-signal-args signal))
 162                                      (riece-current-nickname))))))
 163   (riece-connect-signal
 164    'rename
 165    (lambda (signal handback)
 166      (save-excursion
 167        (set-buffer riece-user-list-buffer)
 168        (run-hooks 'riece-update-buffer-functions)))
 169    (lambda (signal)
 170      (and (equal (riece-identity-server (nth 1 (riece-signal-args signal)))
 171                  (riece-identity-server riece-current-channel))
 172           (riece-with-server-buffer (riece-identity-server
 173                                      riece-current-channel)
 174             (riece-identity-assoc
 175              (riece-identity-prefix (nth 1 (riece-signal-args signal)))
 176              (riece-channel-get-users (riece-identity-prefix
 177                                        riece-current-channel))
 178              t)))))
 179   (riece-connect-signal
 180    'rename
 181    (lambda (signal handback)
 182      (riece-update-status-indicators)
 183      (riece-update-channel-indicator))
 184    (lambda (signal)
 185      (riece-identity-equal (nth 1 (riece-signal-args signal))
 186                            (riece-current-nickname)))))
 187
 188 (defun riece-update-user-list-buffer ()
 189   (save-excursion
 190     (if (and riece-current-channel
 191              (riece-channel-p (riece-identity-prefix riece-current-channel)))
 192         (let* ((users
 193                 (riece-with-server-buffer (riece-identity-server
 194                                            riece-current-channel)
 195                   (riece-channel-get-users (riece-identity-prefix
 196                                             riece-current-channel))))
 197                (inhibit-read-only t)
 198                buffer-read-only)
 199           (erase-buffer)
 200           (riece-kill-all-overlays)
 201           (while users
 202             (insert (if (memq ?o (cdr (car users)))
 203                         "@"
 204                       (if (memq ?v (cdr (car users)))
 205                           "+"
 206                         " "))
 207                     (riece-format-identity
 208                      (riece-make-identity (car (car users))
 209                                           (riece-identity-server
 210                                            riece-current-channel))
 211                      t)
 212                     "\n")
 213             (setq users (cdr users)))))))
 214
 215 (defun riece-update-channel-list-buffer ()
 216   (save-excursion
 217     (let ((inhibit-read-only t)
 218           buffer-read-only
 219           (index 1)
 220           (channels riece-current-channels))
 221       (erase-buffer)
 222       (riece-kill-all-overlays)
 223       (while channels
 224         (if (car channels)
 225             (insert (riece-format-channel-list-line
 226                      index (car channels))))
 227         (setq index (1+ index)
 228               channels (cdr channels))))))
 229
 230 (defun riece-format-channel-list-line (index channel)
 231   (or (run-hook-with-args-until-success
 232        'riece-format-channel-list-line-functions index channel)
 233       (concat (format "%2d:%c" index
 234                       (if (riece-identity-equal channel riece-current-channel)
 235                           ?*
 236                         ? ))
 237               (riece-format-identity channel)
 238               "\n")))
 239
 240 (defun riece-update-channel-indicator ()
 241   (setq riece-channel-indicator
 242         (if riece-current-channel
 243             (riece-format-identity riece-current-channel)
 244           "None")))
 245
 246 (defun riece-update-long-channel-indicator ()
 247   (setq riece-long-channel-indicator
 248         (if riece-current-channel
 249             (if (riece-channel-p (riece-identity-prefix riece-current-channel))
 250                 (riece-concat-channel-modes
 251                  riece-current-channel
 252                  (riece-concat-channel-topic
 253                   riece-current-channel
 254                   (riece-format-identity riece-current-channel)))
 255               (riece-format-identity riece-current-channel))
 256           "None")))
 257
 258 (defun riece-update-channel-list-indicator ()
 259   (if (and riece-current-channels
 260            ;; There is at least one channel.
 261            (delq nil (copy-sequence riece-current-channels)))
 262       (let ((index 1))
 263         (setq riece-channel-list-indicator
 264               (mapconcat
 265                #'identity
 266                (delq nil
 267                      (mapcar
 268                       (lambda (channel)
 269                         (prog1
 270                             (if channel
 271                                 (format "%d:%s" index
 272                                         (riece-format-identity channel)))
 273                           (setq index (1+ index))))
 274                       riece-current-channels))
 275                ",")))
 276     (setq riece-channel-list-indicator "No channel")))
 277
 278 (defun riece-update-status-indicators ()
 279   (if riece-current-channel
 280       (with-current-buffer riece-command-buffer
 281         (riece-with-server-buffer (riece-identity-server riece-current-channel)
 282           (setq riece-away-indicator
 283                 (if (and riece-real-nickname
 284                          (riece-user-get-away riece-real-nickname))
 285                     "A"
 286                   "-")
 287                 riece-operator-indicator
 288                 (if (and riece-real-nickname
 289                          (riece-user-get-operator riece-real-nickname))
 290                     "O"
 291                   "-")
 292                 riece-user-indicator riece-real-nickname))))
 293   (setq riece-freeze-indicator
 294         (with-current-buffer (if (and riece-channel-buffer-mode
 295                                       riece-channel-buffer)
 296                                  riece-channel-buffer
 297                                riece-dialogue-buffer)
 298           (if (eq riece-freeze 'own)
 299               "f"
 300             (if riece-freeze
 301                 "F"
 302               "-")))))
 303
 304 (defun riece-update-buffers (&optional buffers)
 305   (unless buffers
 306     (setq buffers riece-buffer-list))
 307   (while buffers
 308     (save-excursion
 309       (set-buffer (car buffers))
 310       (run-hooks 'riece-update-buffer-functions))
 311     (setq buffers (cdr buffers)))
 312   (run-hooks 'riece-update-indicator-functions)
 313   (force-mode-line-update t)
 314   (run-hooks 'riece-update-buffer-hook))
 315
 316 (defun riece-channel-buffer-name (identity)
 317   (let ((channels (riece-identity-member identity riece-current-channels)))
 318     (if channels
 319         (setq identity (car channels))
 320       (if riece-debug
 321           (message "%S is not a member of riece-current-channels" identity)))
 322     (format riece-channel-buffer-format (riece-format-identity identity))))
 323
 324 (eval-when-compile
 325   (autoload 'riece-channel-mode "riece"))
 326 (defun riece-channel-buffer-create (identity)
 327   (with-current-buffer
 328       (riece-get-buffer-create (riece-channel-buffer-name identity)
 329                                'riece-channel-mode)
 330     (setq riece-channel-buffer-alist
 331           (cons (cons identity (current-buffer))
 332                 riece-channel-buffer-alist))
 333     (unless (eq major-mode 'riece-channel-mode)
 334       (riece-channel-mode)
 335       (let (buffer-read-only)
 336         (riece-insert-info (current-buffer)
 337                            (concat "Created on "
 338                                    (funcall riece-format-time-function
 339                                             (current-time))
 340                                    "\n"))
 341         (run-hook-with-args 'riece-channel-buffer-create-functions identity)))
 342     (current-buffer)))
 343
 344 (defun riece-channel-buffer (identity)
 345   (cdr (riece-identity-assoc identity riece-channel-buffer-alist)))
 346
 347 (defun riece-switch-to-channel (identity)
 348   (let ((last riece-current-channel))
 349     (setq riece-current-channel identity
 350           riece-channel-buffer (riece-channel-buffer riece-current-channel))
 351     (run-hook-with-args 'riece-after-switch-to-channel-functions last)
 352     (riece-emit-signal (riece-make-signal 'switch-to-channel))))
 353
 354 (defun riece-join-channel (identity)
 355   (unless (riece-identity-member identity riece-current-channels)
 356     (setq riece-current-channels
 357           (riece-identity-assign-binding
 358            identity riece-current-channels
 359            (mapcar
 360             (lambda (channel)
 361               (if channel
 362                   (riece-parse-identity channel)))
 363             riece-default-channel-binding)))
 364     (riece-channel-buffer-create identity)))
 365
 366 (defun riece-switch-to-nearest-channel (pointer)
 367   (let ((start riece-current-channels)
 368         identity)
 369     (while (and start (not (eq start pointer)))
 370       (if (car start)
 371           (setq identity (car start)))
 372       (setq start (cdr start)))
 373     (unless identity
 374       (while (and pointer
 375                   (null (car pointer)))
 376         (setq pointer (cdr pointer)))
 377       (setq identity (car pointer)))
 378     (if identity
 379         (riece-switch-to-channel identity)
 380       (let ((last riece-current-channel))
 381         (run-hook-with-args 'riece-after-switch-to-channel-functions last)
 382         (setq riece-current-channel nil)
 383         (riece-emit-signal (riece-make-signal 'switch-to-channel))))))
 384
 385 (defun riece-part-channel (identity)
 386   (let ((pointer (riece-identity-member identity riece-current-channels)))
 387     (if pointer
 388         (setcar pointer nil))
 389     (if (riece-identity-equal identity riece-current-channel)
 390         (riece-switch-to-nearest-channel pointer))))
 391
 392 (defun riece-redisplay-buffers (&optional force)
 393   (riece-update-buffers)
 394   (riece-redraw-layout force)
 395   (run-hooks 'riece-redisplay-buffers-hook))
 396
 397 (provide 'riece-display)
 398
 399 ;;; riece-display.el ends here