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