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