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