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