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