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