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