cgit.sxemacs.org Git - riece/blob - 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., 51 Franklin Street, Fifth Floor,
  23 ;; Boston, MA 02110-1301, USA.
  24
  25 ;;; Code:
  26
  27 (require 'riece-options)
  28 (require 'riece-channel)
  29 (require 'riece-misc)
  30 (require 'riece-layout)
  31 (require 'riece-signal)
  32 (require 'riece-mcat)
  33
  34 (defvar riece-channel-buffer-format "*Channel:%s*"
  35   "Format of channel message buffer.")
  36 (defvar riece-channel-buffer-alist nil
  37   "An alist mapping identities to channel buffers.")
  38
  39 (defvar riece-update-buffer-functions nil
  40   "Functions to redisplay the buffer.
  41 Local to the buffer in `riece-buffer-list'.")
  42
  43 (defvar riece-update-indicator-functions
  44   '(riece-update-status-indicators
  45     riece-update-channel-status-indicator
  46     riece-update-channel-indicator
  47     riece-update-long-channel-indicator
  48     riece-update-channel-list-indicator)
  49   "Functions to update modeline indicators.")
  50
  51 (defun riece-display-connect-signals ()
  52   (riece-connect-signal
  53    'channel-list-changed
  54    (lambda (signal handback)
  55      (save-excursion
  56        (set-buffer riece-channel-list-buffer)
  57        (run-hooks 'riece-update-buffer-functions))
  58      (riece-update-channel-list-indicator)))
  59   (riece-connect-signal
  60    'user-list-changed
  61    (lambda (signal handback)
  62      (save-excursion
  63        (set-buffer riece-user-list-buffer)
  64        (run-hooks 'riece-update-buffer-functions)))
  65    (lambda (signal)
  66      (and riece-current-channel
  67           (riece-identity-equal (car (riece-signal-args signal))
  68                                 riece-current-channel))))
  69   (riece-connect-signal
  70    'channel-switched
  71    (lambda (signal handback)
  72      (riece-update-status-indicators)
  73      (riece-update-channel-status-indicator)
  74      (riece-update-channel-indicator)
  75      (riece-update-long-channel-indicator)
  76      (force-mode-line-update t)
  77      (riece-emit-signal 'channel-list-changed)
  78      (riece-emit-signal 'user-list-changed riece-current-channel)
  79      (save-excursion
  80        (riece-redraw-layout))))
  81   (riece-connect-signal
  82    'user-joined-channel
  83    (lambda (signal handback)
  84      (riece-emit-signal 'user-list-changed riece-current-channel))
  85    (lambda (signal)
  86      (and riece-current-channel
  87           (riece-identity-equal (nth 1 (riece-signal-args signal))
  88                                 riece-current-channel)
  89           (not (riece-identity-equal (car (riece-signal-args signal))
  90                                      (riece-current-nickname))))))
  91   (riece-connect-signal
  92    'user-joined-channel
  93    (lambda (signal handback)
  94      (riece-join-channel (nth 1 (riece-signal-args signal)))
  95      (riece-switch-to-channel (nth 1 (riece-signal-args signal)))
  96      (setq riece-join-channel-candidate nil))
  97    (lambda (signal)
  98      (riece-identity-equal (car (riece-signal-args signal))
  99                            (riece-current-nickname))))
 100   (riece-connect-signal
 101    'user-left-channel
 102    (lambda (signal handback)
 103      (riece-emit-signal 'user-list-changed riece-current-channel))
 104    (lambda (signal)
 105      (and riece-current-channel
 106           (riece-identity-equal (nth 1 (riece-signal-args signal))
 107                                 riece-current-channel)
 108           (not (riece-identity-equal (car (riece-signal-args signal))
 109                                      (riece-current-nickname))))))
 110   (riece-connect-signal
 111    'user-left-channel
 112    (lambda (signal handback)
 113      (riece-part-channel (nth 1 (riece-signal-args signal))))
 114    (lambda (signal)
 115      (riece-identity-equal (car (riece-signal-args signal))
 116                            (riece-current-nickname))))
 117   (riece-connect-signal
 118    'user-renamed
 119    (lambda (signal handback)
 120      (riece-emit-signal 'user-list-changed riece-current-channel))
 121    (lambda (signal)
 122      (and riece-current-channel
 123           (equal (riece-identity-server (nth 1 (riece-signal-args signal)))
 124                  (riece-identity-server riece-current-channel))
 125           (riece-with-server-buffer (riece-identity-server
 126                                      riece-current-channel)
 127             (when (riece-channel-p (riece-identity-prefix
 128                                     riece-current-channel))
 129               (riece-identity-assoc
 130                (riece-identity-prefix (nth 1 (riece-signal-args signal)))
 131                (riece-channel-get-users (riece-identity-prefix
 132                                          riece-current-channel))
 133                t))))))
 134   (riece-connect-signal
 135    'user-renamed
 136    (lambda (signal handback)
 137      (riece-update-status-indicators)
 138      (riece-update-channel-indicator)
 139      (force-mode-line-update t))
 140    (lambda (signal)
 141      (riece-identity-equal (nth 1 (riece-signal-args signal))
 142                            (riece-current-nickname))))
 143   (riece-connect-signal
 144    'user-renamed
 145    (lambda (signal handback)
 146      (riece-switch-to-channel (nth 1 (riece-signal-args signal))))
 147    (lambda (signal)
 148      (and riece-current-channel
 149           (riece-identity-equal (car (riece-signal-args signal))
 150                                 riece-current-channel))))
 151   (riece-connect-signal
 152    'user-renamed
 153    (lambda (signal handback)
 154      (let* ((old-identity (car (riece-signal-args signal)))
 155             (new-identity (nth 1 (riece-signal-args signal)))
 156             (pointer (riece-identity-member old-identity
 157                                             riece-current-channels)))
 158        ;; Rename the channel buffer.
 159        (when pointer
 160          (setcar pointer new-identity)
 161          (with-current-buffer (riece-channel-buffer old-identity)
 162            (rename-buffer (riece-channel-buffer-name new-identity) t)
 163            (setq riece-channel-buffer-alist
 164                  (cons (cons new-identity (current-buffer))
 165                        (delq (riece-identity-assoc old-identity
 166                                                    riece-channel-buffer-alist)
 167                              riece-channel-buffer-alist))))))))
 168   (riece-connect-signal
 169    'user-away-changed
 170    (lambda (signal handback)
 171      (riece-update-status-indicators)
 172      (force-mode-line-update t))
 173    (lambda (signal)
 174      (riece-identity-equal (car (riece-signal-args signal))
 175                            (riece-current-nickname))))
 176   (riece-connect-signal
 177    'user-operator-changed
 178    (lambda (signal handback)
 179      (riece-update-status-indicators)
 180      (force-mode-line-update t))
 181    (lambda (signal)
 182      (riece-identity-equal (car (riece-signal-args signal))
 183                            (riece-current-nickname))))
 184   (riece-connect-signal
 185    'channel-topic-changed
 186    (lambda (signal handback)
 187      (riece-update-long-channel-indicator)
 188      (force-mode-line-update t))
 189    (lambda (signal)
 190      (and riece-current-channel
 191           (riece-identity-equal (car (riece-signal-args signal))
 192                                 riece-current-channel))))
 193   (riece-connect-signal
 194    'channel-modes-changed
 195    (lambda (signal handback)
 196      (riece-update-long-channel-indicator)
 197      (force-mode-line-update t))
 198    (lambda (signal)
 199      (and riece-current-channel
 200           (riece-identity-equal (car (riece-signal-args signal))
 201                                 riece-current-channel))))
 202   (riece-connect-signal
 203    'channel-operators-changed
 204    (lambda (signal handback)
 205      (riece-update-channel-status-indicator)
 206      (riece-emit-signal 'user-list-changed riece-current-channel))
 207    (lambda (signal)
 208      (and riece-current-channel
 209           (riece-identity-equal (car (riece-signal-args signal))
 210                                 riece-current-channel))))
 211   (riece-connect-signal
 212    'channel-speakers-changed
 213    (lambda (signal handback)
 214      (riece-update-channel-status-indicator)
 215      (riece-emit-signal 'user-list-changed riece-current-channel))
 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    'buffer-freeze-changed
 222    (lambda (signal handback)
 223      (riece-update-status-indicators)
 224      (force-mode-line-update t))))
 225
 226 (defun riece-update-user-list-buffer ()
 227   (save-excursion
 228     (if (and riece-current-channel
 229              (riece-channel-p (riece-identity-prefix riece-current-channel)))
 230         (let* ((users
 231                 (riece-with-server-buffer (riece-identity-server
 232                                            riece-current-channel)
 233                   (riece-channel-get-users (riece-identity-prefix
 234                                             riece-current-channel))))
 235                (inhibit-read-only t)
 236                buffer-read-only)
 237           (erase-buffer)
 238           (riece-kill-all-overlays)
 239           (while users
 240             (insert (if (memq ?o (cdr (car users)))
 241                         "@"
 242                       (if (memq ?v (cdr (car users)))
 243                           "+"
 244                         " "))
 245                     (riece-format-identity
 246                      (riece-make-identity (car (car users))
 247                                           (riece-identity-server
 248                                            riece-current-channel))
 249                      t)
 250                     "\n")
 251             (setq users (cdr users)))))))
 252
 253 (defun riece-format-identity-for-channel-list-buffer (index identity)
 254   (or (run-hook-with-args-until-success
 255        'riece-format-identity-for-channel-list-buffer-functions index identity)
 256       (concat (format "%2d:%c" index
 257                       (if (riece-identity-equal identity riece-current-channel)
 258                           ?*
 259                         ? ))
 260               (riece-format-identity identity))))
 261
 262 (defun riece-update-channel-list-buffer ()
 263   (save-excursion
 264     (let ((inhibit-read-only t)
 265           buffer-read-only
 266           (index 1)
 267           (channels riece-current-channels))
 268       (erase-buffer)
 269       (riece-kill-all-overlays)
 270       (while channels
 271         (if (car channels)
 272             (insert (riece-format-identity-for-channel-list-buffer
 273                      index (car channels))
 274                     "\n"))
 275         (setq index (1+ index)
 276               channels (cdr channels))))))
 277
 278 (defun riece-update-channel-indicator ()
 279   (setq riece-channel-indicator
 280         (if riece-current-channel
 281             (riece-format-identity riece-current-channel)
 282           (riece-mcat "None"))))
 283
 284 (defun riece-update-long-channel-indicator ()
 285   (setq riece-long-channel-indicator
 286         (if riece-current-channel
 287             (if (riece-channel-p (riece-identity-prefix riece-current-channel))
 288                 (riece-concat-channel-topic
 289                  riece-current-channel
 290                  (riece-concat-channel-modes
 291                   riece-current-channel
 292                   (riece-format-identity riece-current-channel)))
 293               (riece-format-identity riece-current-channel))
 294           (riece-mcat "None"))))
 295
 296 (defun riece-format-identity-for-channel-list-indicator (index identity)
 297   (or (run-hook-with-args-until-success
 298        'riece-format-identity-for-channel-list-indicator-functions
 299        index identity)
 300       (let ((string (riece-format-identity identity))
 301             (start 0))
 302         ;; Escape % -> %%.
 303         (while (string-match "%" string start)
 304           (setq start (1+ (match-end 0))
 305                 string (replace-match "%%" nil nil string)))
 306         (format "%d:%s" index string))))
 307
 308 (defun riece-update-channel-list-indicator ()
 309   (if (and riece-current-channels
 310            ;; There is at least one channel.
 311            (delq nil (copy-sequence riece-current-channels)))
 312       (let ((index 1)
 313             pointer)
 314         (setq riece-channel-list-indicator
 315               (delq
 316                nil
 317                (mapcar
 318                 (lambda (channel)
 319                   (prog1
 320                       (if channel
 321                           (riece-format-identity-for-channel-list-indicator
 322                            index channel))
 323                     (setq index (1+ index))))
 324                 riece-current-channels))
 325               pointer riece-channel-list-indicator)
 326         (while pointer
 327           (if (cdr pointer)
 328               (setcdr pointer (cons "," (cdr pointer))))
 329           (setq pointer (cdr (cdr pointer))))
 330         (setq riece-channel-list-indicator
 331               (riece-normalize-modeline-string riece-channel-list-indicator)))
 332     (setq riece-channel-list-indicator (riece-mcat "No channel"))))
 333
 334 (defun riece-update-status-indicators ()
 335   (let ((server-name (riece-current-server-name)))
 336     (if server-name
 337         (with-current-buffer riece-command-buffer
 338           (riece-with-server-buffer server-name
 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                   )
 350             (if riece-real-nickname
 351                 (setq riece-user-indicator
 352                       (riece-format-identity
 353                        (riece-make-identity riece-real-nickname
 354                                             riece-server-name)
 355                        t)))))))
 356   (walk-windows
 357    (lambda (window)
 358      (with-current-buffer (window-buffer window)
 359        (if (riece-derived-mode-p 'riece-dialogue-mode)
 360            (setq riece-freeze-indicator
 361                  (if (eq riece-freeze 'own)
 362                      "f"
 363                    (if riece-freeze
 364                        "F"
 365                      "-"))))))))
 366
 367 (defun riece-update-channel-status-indicator ()
 368   (if (and riece-current-channel
 369            (riece-channel-p (riece-identity-prefix riece-current-channel)))
 370       (let ((users
 371              (riece-with-server-buffer (riece-identity-server
 372                                         riece-current-channel)
 373                (riece-channel-get-users (riece-identity-prefix
 374                                          riece-current-channel))))
 375             (nickname
 376              (riece-with-server-buffer (riece-identity-server
 377                                         riece-current-channel)
 378                riece-real-nickname)))
 379         (with-current-buffer riece-command-buffer
 380           (setq riece-channel-status-indicator
 381                 (if nickname
 382                     (let ((user (cdr (riece-identity-assoc nickname users t))))
 383                       (if (memq ?o user)
 384                           "@"
 385                         (if (memq ?v user)
 386                             "+"
 387                           "-")))
 388                   "-"))))))
 389
 390 (defun riece-update-buffers (&optional buffers)
 391   (unless buffers
 392     (setq buffers riece-buffer-list))
 393   (while buffers
 394     (if (buffer-live-p (car buffers))
 395         (save-excursion
 396           (set-buffer (car buffers))
 397           (run-hooks 'riece-update-buffer-functions)))
 398     (setq buffers (cdr buffers)))
 399   (run-hooks 'riece-update-indicator-functions)
 400   (force-mode-line-update t)
 401   (run-hooks 'riece-update-buffer-hook))
 402
 403 (defun riece-channel-buffer-name (identity)
 404   (let ((channels (riece-identity-member identity riece-current-channels)))
 405     (if channels
 406         (setq identity (car channels))
 407       (if riece-debug
 408           (riece-debug (format "%S is not a member of riece-current-channels"
 409                                identity))))
 410     (format riece-channel-buffer-format (riece-format-identity identity))))
 411
 412 (eval-when-compile
 413   (autoload 'riece-channel-mode "riece"))
 414 (defun riece-channel-buffer-create (identity)
 415   (with-current-buffer
 416       (riece-get-buffer-create (riece-channel-buffer-name identity)
 417                                'riece-channel-mode)
 418     (setq riece-channel-buffer-alist
 419           (cons (cons identity (current-buffer))
 420                 riece-channel-buffer-alist))
 421     (unless (eq major-mode 'riece-channel-mode)
 422       (riece-channel-mode)
 423       (let (buffer-read-only)
 424         (riece-insert-info (current-buffer)
 425                            (format (riece-mcat "Created on %s\n")
 426                                    (funcall riece-format-time-function
 427                                             (current-time))))
 428         (run-hook-with-args 'riece-channel-buffer-create-functions identity)))
 429     (current-buffer)))
 430
 431 (defun riece-channel-buffer (identity)
 432   (let ((entry (riece-identity-assoc identity riece-channel-buffer-alist)))
 433     (if entry
 434         (if (buffer-live-p (cdr entry))
 435             (cdr entry)
 436           (if riece-debug
 437               (riece-debug
 438                (format "riece-channel-buffer: nonexistent buffer: %s"
 439                        (riece-format-identity identity))))))))
 440
 441 (defun riece-switch-to-channel (identity)
 442   (let ((last riece-current-channel)
 443         window)
 444     (if (and riece-channel-buffer
 445              (setq window (get-buffer-window riece-channel-buffer)))
 446         (with-current-buffer riece-channel-buffer
 447           (setq riece-channel-buffer-window-point (window-point window))))
 448     (setq riece-current-channel identity
 449           riece-channel-buffer (riece-channel-buffer riece-current-channel))
 450     (run-hook-with-args 'riece-after-switch-to-channel-functions last)
 451     (riece-emit-signal 'channel-switched)))
 452
 453 (defun riece-join-channel (identity)
 454   (unless (riece-identity-member identity riece-current-channels)
 455     (setq riece-current-channels
 456           (riece-identity-assign-binding
 457            identity riece-current-channels
 458            (mapcar
 459             (lambda (channel)
 460               (if channel
 461                   (riece-parse-identity channel)))
 462             riece-default-channel-binding)))
 463     (riece-channel-buffer-create identity)))
 464
 465 (defun riece-switch-to-nearest-channel (pointer)
 466   (let ((start riece-current-channels)
 467         identity)
 468     (while (and start (not (eq start pointer)))
 469       (if (car start)
 470           (setq identity (car start)))
 471       (setq start (cdr start)))
 472     (unless identity
 473       (while (and pointer
 474                   (null (car pointer)))
 475         (setq pointer (cdr pointer)))
 476       (setq identity (car pointer)))
 477     (if identity
 478         (riece-switch-to-channel identity)
 479       (let ((last riece-current-channel))
 480         (run-hook-with-args 'riece-after-switch-to-channel-functions last)
 481         (setq riece-current-channel nil)
 482         (riece-emit-signal 'channel-switched)))))
 483
 484 (defun riece-part-channel (identity)
 485   (let ((pointer (riece-identity-member identity riece-current-channels)))
 486     (unless pointer
 487       (error "No such channel!"))
 488     (setcar pointer nil)
 489     (if (riece-identity-equal identity riece-current-channel)
 490         (riece-switch-to-nearest-channel pointer)
 491       (riece-emit-signal 'channel-list-changed))
 492     (funcall riece-buffer-dispose-function (riece-channel-buffer identity))))
 493
 494 (defun riece-redisplay-buffers (&optional force)
 495   (riece-update-buffers)
 496   (riece-redraw-layout force)
 497   (run-hooks 'riece-redisplay-buffers-hook))
 498
 499 (provide 'riece-display)
 500
 501 ;;; riece-display.el ends here