cgit.sxemacs.org Git - riece/blob - lisp/riece-display.el

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