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    'riece-switch-to-channel
 123    (lambda (signal handback)
 124      (riece-update-status-indicators)
 125      (riece-update-channel-indicator)
 126      (riece-update-long-channel-indicator)
 127      (force-mode-line-update t)
 128      (save-excursion
 129        (set-buffer riece-user-list-buffer)
 130        (run-hooks 'riece-update-buffer-functions))
 131      (save-excursion
 132        (set-buffer riece-channel-list-buffer)
 133        (run-hooks 'riece-update-buffer-functions))
 134      (save-excursion
 135        (riece-redraw-layout))))
 136   (riece-connect-signal
 137    'riece-naming-assert-channel-users
 138    (lambda (signal handback)
 139      (save-excursion
 140        (set-buffer riece-user-list-buffer)
 141        (run-hooks 'riece-update-buffer-functions))))
 142   (riece-connect-signal
 143    'riece-naming-assert-join
 144    (lambda (signal handback)
 145      (save-excursion
 146        (set-buffer riece-user-list-buffer)
 147        (run-hooks 'riece-update-buffer-functions)))
 148    (lambda (signal)
 149      (and (riece-identity-equal (nth 1 (riece-signal-args signal))
 150                                 riece-current-channel)
 151           (not (riece-identity-equal (car (riece-signal-args signal))
 152                                      (riece-current-nickname))))))
 153   (riece-connect-signal
 154    'riece-naming-assert-part
 155    (lambda (signal handback)
 156      (save-excursion
 157        (set-buffer riece-user-list-buffer)
 158        (run-hooks 'riece-update-buffer-functions)))
 159    (lambda (signal)
 160      (and (riece-identity-equal (nth 1 (riece-signal-args signal))
 161                                 riece-current-channel)
 162           (not (riece-identity-equal (car (riece-signal-args signal))
 163                                      (riece-current-nickname))))))
 164   (riece-connect-signal
 165    'riece-naming-assert-rename
 166    (lambda (signal handback)
 167      (save-excursion
 168        (set-buffer riece-user-list-buffer)
 169        (run-hooks 'riece-update-buffer-functions)))
 170    (lambda (signal)
 171      (and (equal (riece-identity-server (nth 1 (riece-signal-args signal)))
 172                  (riece-identity-server riece-current-channel))
 173           (riece-with-server-buffer (riece-identity-server
 174                                      riece-current-channel)
 175             (riece-identity-assoc
 176              (riece-identity-prefix (nth 1 (riece-signal-args signal)))
 177              (riece-channel-get-users (riece-identity-prefix
 178                                        riece-current-channel))
 179              t)))))
 180   (riece-connect-signal
 181    'riece-naming-assert-rename
 182    (lambda (signal handback)
 183      (riece-update-status-indicators)
 184      (riece-update-channel-indicator)
 185      (force-mode-line-update t))
 186    (lambda (signal)
 187      (riece-identity-equal (nth 1 (riece-signal-args signal))
 188                            (riece-current-nickname))))
 189   (riece-connect-signal
 190    'riece-user-toggle-away
 191    (lambda (signal handback)
 192      (riece-update-status-indicators)
 193      (force-mode-line-update t))
 194    (lambda (signal)
 195      (riece-identity-equal (car (riece-signal-args signal))
 196                            (riece-current-nickname))))
 197   (riece-connect-signal
 198    'riece-user-toggle-operator
 199    (lambda (signal handback)
 200      (riece-update-status-indicators)
 201      (force-mode-line-update t))
 202    (lambda (signal)
 203      (riece-identity-equal (car (riece-signal-args signal))
 204                            (riece-current-nickname))))
 205   (riece-connect-signal
 206    'riece-channel-set-topic
 207    (lambda (signal handback)
 208      (riece-update-long-channel-indicator)
 209      (force-mode-line-update t))
 210    (lambda (signal)
 211      (riece-identity-equal (car (riece-signal-args signal))
 212                            riece-current-channel)))
 213   (riece-connect-signal
 214    'riece-channel-toggle-modes
 215    (lambda (signal handback)
 216      (riece-update-status-indicators)
 217      (force-mode-line-update t))
 218    (lambda (signal)
 219      (riece-identity-equal (car (riece-signal-args signal))
 220                            riece-current-channel)))
 221   (riece-connect-signal
 222    'riece-channel-toggle-operator
 223    (lambda (signal handback)
 224      (save-excursion
 225        (set-buffer riece-user-list-buffer)
 226        (run-hooks 'riece-update-buffer-functions)))
 227    (lambda (signal)
 228      (riece-identity-equal (car (riece-signal-args signal))
 229                            riece-current-channel)))
 230   (riece-connect-signal
 231    'riece-channel-toggle-speaker
 232    (lambda (signal handback)
 233      (save-excursion
 234        (set-buffer riece-user-list-buffer)
 235        (run-hooks 'riece-update-buffer-functions)))
 236    (lambda (signal)
 237      (riece-identity-equal (car (riece-signal-args signal))
 238                            riece-current-channel)))
 239   (riece-connect-signal
 240    'riece-buffer-toggle-freeze
 241    (lambda (signal handback)
 242      (riece-update-status-indicators)
 243      (force-mode-line-update t))))
 244
 245 (defun riece-update-user-list-buffer ()
 246   (save-excursion
 247     (if (and riece-current-channel
 248              (riece-channel-p (riece-identity-prefix riece-current-channel)))
 249         (let* ((users
 250                 (riece-with-server-buffer (riece-identity-server
 251                                            riece-current-channel)
 252                   (riece-channel-get-users (riece-identity-prefix
 253                                             riece-current-channel))))
 254                (inhibit-read-only t)
 255                buffer-read-only)
 256           (erase-buffer)
 257           (riece-kill-all-overlays)
 258           (while users
 259             (insert (if (memq ?o (cdr (car users)))
 260                         "@"
 261                       (if (memq ?v (cdr (car users)))
 262                           "+"
 263                         " "))
 264                     (riece-format-identity
 265                      (riece-make-identity (car (car users))
 266                                           (riece-identity-server
 267                                            riece-current-channel))
 268                      t)
 269                     "\n")
 270             (setq users (cdr users)))))))
 271
 272 (defun riece-update-channel-list-buffer ()
 273   (save-excursion
 274     (let ((inhibit-read-only t)
 275           buffer-read-only
 276           (index 1)
 277           (channels riece-current-channels))
 278       (erase-buffer)
 279       (riece-kill-all-overlays)
 280       (while channels
 281         (if (car channels)
 282             (insert (riece-format-channel-list-line
 283                      index (car channels))))
 284         (setq index (1+ index)
 285               channels (cdr channels))))))
 286
 287 (defun riece-format-channel-list-line (index channel)
 288   (or (run-hook-with-args-until-success
 289        'riece-format-channel-list-line-functions index channel)
 290       (concat (format "%2d:%c" index
 291                       (if (riece-identity-equal channel riece-current-channel)
 292                           ?*
 293                         ? ))
 294               (riece-format-identity channel)
 295               "\n")))
 296
 297 (defun riece-update-channel-indicator ()
 298   (setq riece-channel-indicator
 299         (if riece-current-channel
 300             (riece-format-identity riece-current-channel)
 301           "None")))
 302
 303 (defun riece-update-long-channel-indicator ()
 304   (setq riece-long-channel-indicator
 305         (if riece-current-channel
 306             (if (riece-channel-p (riece-identity-prefix riece-current-channel))
 307                 (riece-concat-channel-modes
 308                  riece-current-channel
 309                  (riece-concat-channel-topic
 310                   riece-current-channel
 311                   (riece-format-identity riece-current-channel)))
 312               (riece-format-identity riece-current-channel))
 313           "None")))
 314
 315 (defun riece-update-channel-list-indicator ()
 316   (if (and riece-current-channels
 317            ;; There is at least one channel.
 318            (delq nil (copy-sequence riece-current-channels)))
 319       (let ((index 1))
 320         (setq riece-channel-list-indicator
 321               (mapconcat
 322                #'identity
 323                (delq nil
 324                      (mapcar
 325                       (lambda (channel)
 326                         (prog1
 327                             (if channel
 328                                 (format "%d:%s" index
 329                                         (riece-format-identity channel)))
 330                           (setq index (1+ index))))
 331                       riece-current-channels))
 332                ",")))
 333     (setq riece-channel-list-indicator "No channel")))
 334
 335 (defun riece-update-status-indicators ()
 336   (if riece-current-channel
 337       (with-current-buffer riece-command-buffer
 338         (riece-with-server-buffer (riece-identity-server riece-current-channel)
 339           (setq riece-away-indicator
 340                 (if (and riece-real-nickname
 341                          (riece-user-get-away riece-real-nickname))
 342                     "A"
 343                   "-")
 344                 riece-operator-indicator
 345                 (if (and riece-real-nickname
 346                          (riece-user-get-operator riece-real-nickname))
 347                     "O"
 348                   "-")
 349                 riece-user-indicator riece-real-nickname))))
 350   (setq riece-freeze-indicator
 351         (with-current-buffer (if (and riece-channel-buffer-mode
 352                                       riece-channel-buffer)
 353                                  riece-channel-buffer
 354                                riece-dialogue-buffer)
 355           (if (eq riece-freeze 'own)
 356               "f"
 357             (if riece-freeze
 358                 "F"
 359               "-")))))
 360
 361 (defun riece-update-buffers (&optional buffers)
 362   (unless buffers
 363     (setq buffers riece-buffer-list))
 364   (while buffers
 365     (save-excursion
 366       (set-buffer (car buffers))
 367       (run-hooks 'riece-update-buffer-functions))
 368     (setq buffers (cdr buffers)))
 369   (run-hooks 'riece-update-indicator-functions)
 370   (force-mode-line-update t)
 371   (run-hooks 'riece-update-buffer-hook))
 372
 373 (defun riece-channel-buffer-name (identity)
 374   (let ((channels (riece-identity-member identity riece-current-channels)))
 375     (if channels
 376         (setq identity (car channels))
 377       (if riece-debug
 378           (message "%S is not a member of riece-current-channels" identity)))
 379     (format riece-channel-buffer-format (riece-format-identity identity))))
 380
 381 (eval-when-compile
 382   (autoload 'riece-channel-mode "riece"))
 383 (defun riece-channel-buffer-create (identity)
 384   (with-current-buffer
 385       (riece-get-buffer-create (riece-channel-buffer-name identity)
 386                                'riece-channel-mode)
 387     (setq riece-channel-buffer-alist
 388           (cons (cons identity (current-buffer))
 389                 riece-channel-buffer-alist))
 390     (unless (eq major-mode 'riece-channel-mode)
 391       (riece-channel-mode)
 392       (let (buffer-read-only)
 393         (riece-insert-info (current-buffer)
 394                            (concat "Created on "
 395                                    (funcall riece-format-time-function
 396                                             (current-time))
 397                                    "\n"))
 398         (run-hook-with-args 'riece-channel-buffer-create-functions identity)))
 399     (current-buffer)))
 400
 401 (defun riece-channel-buffer (identity)
 402   (cdr (riece-identity-assoc identity riece-channel-buffer-alist)))
 403
 404 (defun riece-switch-to-channel (identity)
 405   (let ((last riece-current-channel))
 406     (setq riece-current-channel identity
 407           riece-channel-buffer (riece-channel-buffer riece-current-channel))
 408     (run-hook-with-args 'riece-after-switch-to-channel-functions last)
 409     (riece-emit-signal (riece-make-signal 'riece-switch-to-channel))))
 410
 411 (defun riece-join-channel (identity)
 412   (unless (riece-identity-member identity riece-current-channels)
 413     (setq riece-current-channels
 414           (riece-identity-assign-binding
 415            identity riece-current-channels
 416            (mapcar
 417             (lambda (channel)
 418               (if channel
 419                   (riece-parse-identity channel)))
 420             riece-default-channel-binding)))
 421     (riece-channel-buffer-create identity)))
 422
 423 (defun riece-switch-to-nearest-channel (pointer)
 424   (let ((start riece-current-channels)
 425         identity)
 426     (while (and start (not (eq start pointer)))
 427       (if (car start)
 428           (setq identity (car start)))
 429       (setq start (cdr start)))
 430     (unless identity
 431       (while (and pointer
 432                   (null (car pointer)))
 433         (setq pointer (cdr pointer)))
 434       (setq identity (car pointer)))
 435     (if identity
 436         (riece-switch-to-channel identity)
 437       (let ((last riece-current-channel))
 438         (run-hook-with-args 'riece-after-switch-to-channel-functions last)
 439         (setq riece-current-channel nil)
 440         (riece-emit-signal (riece-make-signal 'riece-switch-to-channel))))))
 441
 442 (defun riece-part-channel (identity)
 443   (let ((pointer (riece-identity-member identity riece-current-channels)))
 444     (if pointer
 445         (setcar pointer nil))
 446     (if (riece-identity-equal identity riece-current-channel)
 447         (riece-switch-to-nearest-channel pointer))))
 448
 449 (defun riece-redisplay-buffers (&optional force)
 450   (riece-update-buffers)
 451   (riece-redraw-layout force)
 452   (run-hooks 'riece-redisplay-buffers-hook))
 453
 454 (provide 'riece-display)
 455
 456 ;;; riece-display.el ends here