lisp/liece-channel.el

   1 ;;; liece-channel.el --- Various facility for channel operation.
   2 ;; Copyright (C) 1998-2000 Daiki Ueno
   3
   4 ;; Author: Daiki Ueno <ueno@unixuser.org>
   5 ;; Created: 1998-09-28
   6 ;; Revised: 1999-05-05
   7 ;; Keywords: IRC, liece
   8
   9 ;; This file is part of Liece.
  10
  11 ;; This program is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15
  16 ;; This program is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25
  26
  27 ;;; Commentary:
  28 ;;
  29
  30 ;;; Code:
  31
  32 (eval-when-compile (require 'liece-inlines))
  33 (eval-when-compile (require 'liece-misc))
  34
  35 (eval-when-compile (require 'liece-clfns))
  36
  37 (defconst liece-channel-regexp "[+&#!]")
  38 (defconst liece-channel-modeless-regexp "[+!]")
  39
  40 (defvar liece-default-channel-representation-format "%s+%s")
  41
  42 (defconst liece-dcc-channel-representation-format "=%s")
  43
  44 (define-widget 'liece-channel-push-button 'push-button
  45   "A channel button."
  46   :action 'liece-channel-push-button-action)
  47
  48 (defun liece-channel-push-button-action (widget &optional event)
  49   (let ((chnl (liece-channel-virtual (widget-value widget))))
  50     (if (or (liece-channel-member chnl liece-current-channels)
  51             (y-or-n-p (format "Do you really join %s? " chnl)))
  52         (liece-command-join chnl))))
  53
  54 ;;; Reader conventions
  55 (defun liece-channel-p (chnl)
  56   (string-match (concat "^" liece-channel-regexp) chnl))
  57
  58 (defun liece-channel-modeless-p (chnl)
  59   (string-match (concat "^" liece-channel-modeless-regexp) chnl))
  60
  61 (defun liece-channel-equal (c1 c2)
  62   (string-equal-ignore-case c1 c2))
  63
  64 (defun liece-channel-member (chnl chnls)
  65   "Return non-nil if CHNL is member of CHNLS."
  66   (member-if
  67    (lambda (item)
  68      (and (stringp item) (liece-channel-equal chnl item)))
  69    chnls))
  70
  71 (defun liece-channel-unread-p (chnl)
  72   "Return non-nil if CHNL is unread channel."
  73   (member-if
  74    (lambda (item)
  75      (and (stringp item) (liece-channel-equal chnl item)))
  76    liece-channel-unread-list))
  77
  78 (defun liece-channel-get-nicks (&optional chnl)
  79   "Return CHNL or current channels's members as list."
  80   (get (intern (or chnl liece-current-channel) liece-obarray) 'nick))
  81
  82 (defun liece-channel-get-operators (&optional chnl)
  83   "Return CHNL or current channels's operators as list."
  84   (get (intern (or chnl liece-current-channel) liece-obarray) 'oper))
  85
  86 (defun liece-channel-get-voices (&optional chnl)
  87   "Return CHNL or current channels's voices as list."
  88   (get (intern (or chnl liece-current-channel) liece-obarray) 'voice))
  89
  90 (defun liece-channel-get-topic (&optional chnl)
  91   "Return CHNL or current channels's topic."
  92   (get (intern (or chnl liece-current-channel) liece-obarray) 'topic))
  93
  94 (defun liece-channel-get-modes (&optional chnl)
  95   "Return CHNL or current channels's mode."
  96   (get (intern (or chnl liece-current-channel) liece-obarray) 'mode))
  97
  98 (defun liece-channel-get-bans (&optional chnl)
  99   "Return CHNL or current channels's ban list."
 100   (get (intern (or chnl liece-current-channel) liece-obarray) 'ban))
 101
 102 (defun liece-channel-get-invites (&optional chnl)
 103   "Return CHNL or current channels's invite list."
 104   (get (intern (or chnl liece-current-channel) liece-obarray) 'invite))
 105
 106 (defun liece-channel-get-exceptions (&optional chnl)
 107   "Return CHNL or current channels's exception list."
 108   (get (intern (or chnl liece-current-channel) liece-obarray) 'exception))
 109
 110 ;;; Channel status functions
 111 (defun liece-channel-remove (channel channels)
 112   "Remove CHANNEL from CHANNELS."
 113   (remove-if
 114    (lambda (item)
 115      (and (stringp item) (liece-channel-equal channel item)))
 116    channels))
 117
 118 (defun liece-channel-delete (channel channels)
 119   "Delete CHANNEL from CHANNELS."
 120   (delete-if
 121    (lambda (item)
 122      (and (stringp item) (liece-channel-equal channel item)))
 123    channels))
 124
 125 (defun liece-channel-set-topic (topic &optional channel)
 126   "Set CHANNEL's topic."
 127   (put (intern (or channel liece-current-channel) liece-obarray)
 128        'topic topic))
 129
 130 (defun liece-channel-add-mode (mode &optional channel)
 131   "Add MODE to CHANNEL.
 132 MODE is a string splitted into characters one by one."
 133   (let ((modes
 134          (liece-string-to-list
 135           (or (liece-channel-get-modes channel)
 136               ""))))
 137     (or (memq mode modes)
 138         (push mode modes))
 139     (put (intern (or channel liece-current-channel) liece-obarray)
 140          'mode (mapconcat #'char-to-string modes ""))))
 141
 142 (defun liece-channel-remove-mode (mode &optional channel)
 143   "Remove MODE from CHANNEL.
 144 MODE is a string splitted into characters one by one."
 145   (let ((modes
 146          (liece-string-to-list
 147           (or (liece-channel-get-modes channel)
 148               ""))))
 149     (delq mode modes)
 150     (put (intern (or channel liece-current-channel) liece-obarray)
 151          'mode (mapconcat #'char-to-string modes ""))))
 152
 153 (defun liece-channel-set-mode (channel mode flag)
 154   "Add or remove channel MODE of CHANNEL.
 155 MODE is a string splitted into characters one by one.
 156 If FLAG is non-nil, given modes are added to the channel.
 157 Otherwise they are removed from the channel."
 158   (if flag
 159       (liece-channel-add-mode mode channel)
 160     (liece-channel-remove-mode mode channel)))
 161
 162 (defun liece-channel-add-ban (pattern &optional channel)
 163   "Add ban PATTERN to CHANNEL."
 164   (let ((patterns (liece-channel-get-bans channel)))
 165     (or (string-list-member-ignore-case pattern patterns)
 166         (push pattern patterns))
 167     (put (intern (or channel liece-current-channel) liece-obarray)
 168          'ban patterns)))
 169
 170 (defun liece-channel-remove-ban (pattern &optional channel)
 171   "Remove ban PATTERN from CHANNEL."
 172   (let ((patterns
 173          (remove-if
 174           (lambda (elm) (string-equal pattern elm))
 175           (liece-channel-get-bans channel))))
 176     (put (intern (or channel liece-current-channel) liece-obarray)
 177          'ban patterns)))
 178
 179 (defun liece-channel-set-ban (channel pattern flag)
 180   "Add or remove ban PATTERN to CHANNEL.
 181 If FLAG is non-nil, given ban patterns are added to the channel.
 182 Otherwise they are removed from the channel."
 183   (if flag
 184       (liece-channel-add-ban pattern channel)
 185     (liece-channel-remove-ban pattern channel)))
 186
 187 (defun liece-channel-add-exception (pattern &optional channel)
 188   "Add exception PATTERN to CHANNEL."
 189   (let ((patterns (liece-channel-get-exceptions channel)))
 190     (or (string-list-member-ignore-case pattern patterns)
 191         (push pattern patterns))
 192     (put (intern (or channel liece-current-channel) liece-obarray)
 193          'exception patterns)))
 194
 195 (defun liece-channel-remove-exception (pattern &optional channel)
 196   "Remove exception PATTERN from CHANNEL."
 197   (let ((patterns
 198          (remove-if
 199           (lambda (elm) (string-equal pattern elm))
 200           (liece-channel-get-exceptions channel))))
 201     (put (intern (or channel liece-current-channel) liece-obarray)
 202          'exception patterns)))
 203
 204 (defun liece-channel-set-exception (channel pattern flag)
 205   "Add or remove exception PATTERN to CHANNEL.
 206 If FLAG is non-nil, given exception patterns are added to the channel.
 207 Otherwise they are removed from the channel."
 208   (if flag
 209       (liece-channel-add-exception pattern channel)
 210      (liece-channel-remove-exception pattern channel)))
 211
 212 (defun liece-channel-add-invite (pattern &optional channel)
 213   "Add invite PATTERN to CHANNEL."
 214   (let ((patterns (liece-channel-get-invites channel)))
 215     (or (string-list-member-ignore-case pattern patterns)
 216         (push pattern patterns))
 217     (put (intern (or channel liece-current-channel) liece-obarray)
 218          'invite patterns)))
 219
 220 (defun liece-channel-remove-invite (pattern &optional channel)
 221   "Remove invite PATTERN from CHANNEL."
 222   (let ((patterns
 223          (remove-if
 224           (lambda (elm) (string-equal pattern elm))
 225           (liece-channel-get-invites channel))))
 226     (put (intern (or channel liece-current-channel) liece-obarray)
 227          'invite patterns)))
 228
 229 (defun liece-channel-set-invite (channel pattern flag)
 230   "Add or remove invite PATTERN to CHANNEL.
 231 If FLAG is non-nil, given invite patterns are added to the channel.
 232 Otherwise they are removed from the channel."
 233   (if flag
 234       (liece-channel-add-invite pattern channel)
 235      (liece-channel-remove-invite pattern channel)))
 236
 237 (defun liece-channel-virtual (channel)
 238   "Convert channel name into internal representation.
 239 \(For example if CHANNEL is a string \"#...:*\", it will be converted into
 240 \"%...\"\)"
 241   (let ((mapping liece-channel-conversion-map) match)
 242     (while mapping
 243       (if (string-equal-ignore-case (caar mapping) channel)
 244           (setq match (cdar mapping)))
 245       (pop mapping))
 246     (if match
 247         match
 248       (save-match-data
 249         (cond
 250          ((string-match
 251            (format "^[#+]\\(.*\\):%s$"
 252                    (regexp-quote liece-channel-conversion-default-mask))
 253            channel)
 254           (if (eq ?+ (aref channel 0))
 255               (concat "-" (match-string 1 channel))
 256             (concat "%" (match-string 1 channel))))
 257 ;;;      ((and (not (equal channel "")) (eq ?! (aref channel 0)))
 258 ;;;       (concat "!" (substring channel (1+ liece-channel-id-length))))
 259          (t channel))))))
 260
 261 (defun liece-channel-real (channel)
 262   "Convert channel name into external representation.
 263 \(For example if CHANNEL is a string \"%...\", it will be converted into
 264 \"#...:*\"\)"
 265   (let ((mapping liece-channel-conversion-map) match)
 266     (while mapping
 267       (if (string-equal-ignore-case (cdar mapping) channel)
 268           (setq match (caar mapping)))
 269       (pop mapping))
 270     (cond
 271      (match match)
 272      ((eq ?% (aref channel 0))
 273       (concat "#" (substring channel 1) ":"
 274               liece-channel-conversion-default-mask))
 275      ((eq ?- (aref channel 0))
 276       (concat "+" (substring channel 1) ":"
 277               liece-channel-conversion-default-mask))
 278      (t channel))))
 279
 280 ;;;###liece-autoload
 281 (defun liece-command-toggle-channel-buffer-mode ()
 282   "Toggle visibility of channel buffer."
 283   (interactive)
 284   (if (get-buffer liece-channel-buffer)
 285       (setq liece-channel-buffer-mode (not liece-channel-buffer-mode)))
 286   (liece-configure-windows))
 287
 288 (defun liece-channel-buffer-create (chnl)
 289   "Create channel buffer of CHNL."
 290   (with-current-buffer
 291        (liece-get-buffer-create (format liece-channel-buffer-format chnl))
 292      (let (buffer-read-only)
 293        (liece-insert-info (current-buffer)
 294                            (concat (funcall liece-format-time-function
 295                                             (current-time))
 296                                    " Created.\n")))
 297      (unless (eq major-mode 'liece-channel-mode)
 298        (liece-channel-mode))
 299      (set-alist 'liece-channel-buffer-alist chnl (current-buffer))
 300      (current-buffer)))
 301
 302 (defun liece-channel-join-internal (item chnls &optional hints)
 303   (let (binding inserted)
 304     (if (liece-channel-member item hints)
 305         (do ((hint hints (cdr hint)) (chnl chnls (cdr chnl)))
 306             ((not (or hint chnl)))
 307           (if (and (car hint) (liece-channel-equal (car hint) item))
 308               (push item binding)
 309             (push (car chnl) binding)))
 310       (do ((hint hints (cdr hint)) (chnl chnls (cdr chnl)))
 311           ((not (or hint chnl)))
 312         (if (and (not inserted)
 313                  (not (or (car hint) (car chnl))))
 314             (progn
 315               (push item binding)
 316               (setq inserted t))
 317           (push (car chnl) binding))))
 318     (or (liece-channel-member item binding)
 319         (push item binding))
 320     (nreverse binding)))
 321
 322 (defun liece-channel-join (chnl &optional nosw)
 323   "Initialize channel variables of CHNL.
 324 If NOSW is non-nil do not switch to newly created channel."
 325   (let ((cbuf (cdr (string-assoc-ignore-case chnl liece-channel-buffer-alist)))
 326         (nbuf (cdr (string-assoc-ignore-case chnl liece-nick-buffer-alist))))
 327     (or cbuf
 328         (setq cbuf (liece-channel-buffer-create chnl)))
 329     (or nbuf
 330         (setq nbuf (liece-nick-buffer-create chnl)))
 331     (if (liece-channel-p (liece-channel-real chnl))
 332         (setq liece-current-channels
 333               (liece-channel-join-internal
 334                chnl liece-current-channels liece-default-channel-binding))
 335       (setq liece-current-chat-partners
 336             (liece-channel-join-internal chnl liece-current-chat-partners
 337                                           liece-default-partner-binding)))
 338     (unless nosw
 339       (liece-switch-to-channel chnl)
 340       (setq liece-channel-buffer cbuf
 341             liece-nick-buffer nbuf))
 342     (liece-channel-change)))
 343
 344 (defmacro liece-channel-switch-to-last (chnls)
 345   `(let ((chnl (liece-channel-last ,chnls)))
 346      (if chnl
 347          (liece-switch-to-channel chnl))
 348      (liece-channel-change)))
 349
 350 (defun liece-channel-part-internal (item chnls &optional hints)
 351   (if hints
 352       (mapcar
 353        (lambda (chnl)
 354          (if (and chnl (liece-channel-equal item chnl)) nil chnl))
 355        chnls)
 356     (liece-channel-remove item chnls)))
 357
 358 (defun liece-channel-part (chnl &optional nosw)
 359   "Finalize channel variables of CHNL.
 360 If NOSW is non-nil do not switch to newly created channel."
 361   (cond
 362    ((eq liece-command-buffer-mode 'chat)
 363     (setq liece-current-chat-partners
 364           (liece-channel-part-internal chnl liece-current-chat-partners
 365                                         liece-default-partner-binding))
 366     (unless nosw
 367       (liece-channel-switch-to-last liece-current-chat-partners)))
 368    (t
 369     (setq liece-current-channels
 370           (liece-channel-part-internal chnl liece-current-channels
 371                                        liece-default-channel-binding))
 372     (unless nosw
 373       (liece-channel-switch-to-last liece-current-channels)))))
 374
 375 (defun liece-channel-last (chnls)
 376   (car (last (delq nil (copy-sequence chnls)))))
 377
 378 (defun liece-channel-change ()
 379   (let ((chnls (if (eq liece-command-buffer-mode 'chat)
 380                    liece-current-chat-partners
 381                  liece-current-channels))
 382         (string "")
 383         chnl)
 384     (with-current-buffer liece-channel-list-buffer
 385       (let ((n 1) buffer-read-only)
 386         (erase-buffer)
 387         (dolist (chnl chnls)
 388           (when chnl
 389             (setq chnl (liece-channel-virtual chnl)
 390                   string (format "%s,%d:%s" string n chnl))
 391             (liece-channel-list-add-button n chnl))
 392           (incf n))))
 393     (if (string-equal string "")
 394         (if (eq liece-command-buffer-mode 'chat)
 395             (setq liece-channels-indicator "No partner")
 396           (setq liece-channels-indicator "No channel"))
 397       (setq liece-channels-indicator (substring string 1)))
 398     (liece-set-channel-indicator)
 399     (setq chnl (if (eq liece-command-buffer-mode 'chat)
 400                    liece-current-chat-partner
 401                  liece-current-channel))
 402     (when chnl
 403       (save-excursion
 404         (run-hook-with-args 'liece-redisplay-buffer-functions chnl)))
 405     (liece-redisplay-unread-mark)
 406     (liece-configure-windows)))
 407
 408 (defsubst liece-channel-set-operator-1 (chnl user val)
 409   (let* ((chnl (intern chnl liece-obarray)) (opers (get chnl 'oper)))
 410     (if val
 411         (or (string-list-member-ignore-case user opers)
 412             (put chnl 'oper (cons user opers)))
 413       (if (string-list-member-ignore-case user opers)
 414           (put chnl 'oper (string-list-remove-ignore-case user opers))))))
 415
 416 (defsubst liece-channel-set-voice-1 (chnl user val)
 417   (let* ((chnl (intern chnl liece-obarray)) (voices (get chnl 'voice)))
 418     (if val
 419         (or (string-list-member-ignore-case user voices)
 420             (put chnl 'voice (cons user voices)))
 421       (if (string-list-member-ignore-case user voices)
 422           (put chnl 'voice (string-list-remove-ignore-case user voices))))))
 423
 424 (defun liece-channel-set-operator (chnl user val)
 425   (let ((nbuf (cdr (string-assoc-ignore-case chnl liece-nick-buffer-alist)))
 426         (xuser user))
 427     (liece-channel-set-operator-1 chnl user val)
 428     (liece-channel-set-voice-1 chnl user val)
 429     (setq user (concat (if val "@" " ") user)
 430           xuser (concat (if val "[ +]" "@") (regexp-quote xuser)))
 431     (with-current-buffer nbuf
 432       (let (buffer-read-only)
 433         (goto-char (point-min))
 434         (liece-nick-replace xuser user nil t)))))
 435
 436 (defun liece-channel-set-voice (chnl user val)
 437   (let ((nbuf (cdr (string-assoc-ignore-case chnl liece-nick-buffer-alist)))
 438         (xuser user))
 439     (liece-channel-set-voice-1 chnl user val)
 440     (setq user (concat (if val "+" " ") user)
 441           xuser (concat (if val " " "\\+") (regexp-quote xuser)))
 442     (with-current-buffer nbuf
 443       (let (buffer-read-only)
 444         (goto-char (point-min))
 445         (liece-nick-replace xuser user nil t)))))
 446
 447 (defun liece-channel-prepare-partner (join-channel-var)
 448   (setq liece-current-chat-partner
 449         (or liece-current-chat-partner join-channel-var))
 450   (let ((liece-command-buffer-mode 'chat))
 451     (liece-channel-join join-channel-var t))
 452   (liece-channel-change))
 453
 454 (defun liece-channel-buffer-invisible-p (chnl mode)
 455   (let ((cbuf (liece-pick-buffer chnl)))
 456     (or (liece-frozen (car cbuf))
 457         (and (eq mode 'chat)
 458              (not (and (eq liece-command-buffer-mode 'chat)
 459                        liece-current-chat-partner
 460                        (string-equal-ignore-case
 461                         chnl liece-current-chat-partner))))
 462         (not (and (eq liece-command-buffer-mode 'channel)
 463                   liece-current-channel
 464                   (string-equal-ignore-case
 465                    chnl liece-current-channel))))))
 466
 467 (defun liece-channel-prepare-representation (chnl &optional method name)
 468   (cond
 469    ((eq method 'dcc)
 470     (format liece-dcc-channel-representation-format chnl))
 471    (name
 472     (format liece-default-channel-representation-format name chnl))
 473    (t chnl)))
 474
 475 (defun liece-channel-parse-representation (str)
 476   (cond
 477    ((string-match
 478      (format
 479       (regexp-quote liece-dcc-channel-representation-format)
 480       "\\([^ ]+\\)")
 481      str)
 482     (vector 'dcc nil (match-string 1 str)))
 483    ((string-match
 484      (format
 485       (regexp-quote liece-default-channel-representation-format)
 486       "\\([^ ]+\\)" "\\([^ ]+\\)")
 487      str)
 488     (vector 'irc (match-string 1 str) (match-string 2 str)))
 489    (t (vector 'irc nil str))))
 490
 491 (defun liece-channel-list-add-button (n chnl)
 492   (insert (format "%2d: " n))
 493   (if liece-highlight-mode
 494       (let ((st (point)))
 495         (insert chnl)
 496         (liece-widget-convert-button
 497          'liece-channel-push-button st (point) chnl))
 498     (insert chnl))
 499   (insert "\n"))
 500
 501 (defun liece-channel-add-buttons (start end)
 502   (save-excursion
 503     (goto-char start)
 504     (while (re-search-forward
 505             (eval-when-compile
 506               (concat "\\(^\\(" liece-time-prefix-regexp "\\)?"
 507                       "[][=<>(-][][=<>(-]?\\|\\s-+[+@]?\\)"
 508                       "\\([&#!%][^ :]*\\)"))
 509             end t)
 510       ;;(re-search-forward "\\s-+\\(\\)\\([-+]\\S-*\\)" end t)
 511       (let* ((chnl-start (match-beginning 3))
 512              (chnl-end (match-end 3))
 513              (chnl (buffer-substring chnl-start chnl-end)))
 514         (when liece-highlight-mode
 515           (liece-widget-convert-button
 516            'liece-channel-push-button chnl-start chnl-end chnl))))))
 517
 518 ;;;###liece-autoload
 519 (defun liece-channel-redisplay-buffer (chnl)
 520   (let ((buffer
 521          (cdr (string-assoc-ignore-case
 522                chnl liece-channel-buffer-alist)))
 523         (window (liece-get-buffer-window liece-channel-buffer)))
 524     (when (liece-channel-unread-p chnl)
 525       (setq liece-channel-unread-list
 526             (delete chnl liece-channel-unread-list))
 527       (run-hook-with-args 'liece-channel-read-functions chnl))
 528     (and buffer window
 529          (with-current-buffer buffer
 530            (set-window-buffer window buffer)
 531            (unless (liece-frozen buffer)
 532              (set-window-point window (point-max)))
 533            (setq liece-channel-buffer buffer)))))
 534
 535 ;;;###liece-autoload
 536 (defun liece-channel-list-redisplay-buffer (chnl)
 537   (let ((window (liece-get-buffer-window liece-channel-list-buffer)))
 538     (when window
 539       (save-selected-window
 540         (select-window window)
 541         (goto-char (point-min))
 542         (search-forward chnl nil t)
 543         (set-window-point window (match-beginning 0))
 544         (when liece-highlight-mode
 545           (let ((overlay (make-overlay (point)(match-end 0))))
 546             (liece-map-overlays
 547              (lambda (ovl)
 548                (if (overlay-get ovl 'liece-channel)
 549                    (delete-overlay ovl))))
 550             (overlay-put overlay 'face 'underline)
 551             (overlay-put overlay 'liece-channel t)))))))
 552
 553 (provide 'liece-channel)
 554
 555 ;;; liece-channel.el ends here