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         chnl)
 367     (with-current-buffer liece-channel-list-buffer
 368       (let ((n 1) buffer-read-only)
 369         (erase-buffer)
 370         (dolist (chnl chnls)
 371           (when chnl
 372             (setq chnl (liece-channel-virtual chnl)
 373                   string (format "%s,%d:%s" string n chnl))
 374             (liece-channel-list-add-button n chnl))
 375           (incf n))))
 376     (if (string-equal string "")
 377         (if (eq liece-command-buffer-mode 'chat)
 378             (setq liece-channels-indicator "No partner")
 379           (setq liece-channels-indicator "No channel"))
 380       (setq liece-channels-indicator (substring string 1)))
 381     (liece-set-channel-indicator)
 382     (setq chnl (if (eq liece-command-buffer-mode 'chat)
 383                    liece-current-chat-partner
 384                  liece-current-channel))
 385     (when chnl
 386       (save-excursion
 387         (run-hook-with-args 'liece-redisplay-buffer-functions chnl)))
 388     (liece-redisplay-unread-mark)
 389     (liece-configure-windows)))
 390
 391 (defsubst liece-channel-set-operator-1 (chnl user val)
 392   (let* ((chnl (intern chnl liece-obarray)) (opers (get chnl 'oper)))
 393     (if val
 394         (or (string-list-member-ignore-case user opers)
 395             (put chnl 'oper (cons user opers)))
 396       (if (string-list-member-ignore-case user opers)
 397           (put chnl 'oper (string-list-remove-ignore-case user opers))))))
 398
 399 (defsubst liece-channel-set-voice-1 (chnl user val)
 400   (let* ((chnl (intern chnl liece-obarray)) (voices (get chnl 'voice)))
 401     (if val
 402         (or (string-list-member-ignore-case user voices)
 403             (put chnl 'voice (cons user voices)))
 404       (if (string-list-member-ignore-case user voices)
 405           (put chnl 'voice (string-list-remove-ignore-case user voices))))))
 406
 407 (defun liece-channel-set-operator (chnl user val)
 408   (let ((nbuf (cdr (string-assoc-ignore-case chnl liece-nick-buffer-alist)))
 409         (xuser user))
 410     (liece-channel-set-operator-1 chnl user val)
 411     (liece-channel-set-voice-1 chnl user val)
 412     (setq user (concat (if val "@" " ") user)
 413           xuser (concat (if val "[ +]" "@") (regexp-quote xuser)))
 414     (with-current-buffer nbuf
 415       (let (buffer-read-only)
 416         (goto-char (point-min))
 417         (liece-nick-replace xuser user nil t)))))
 418
 419 (defun liece-channel-set-voice (chnl user val)
 420   (let ((nbuf (cdr (string-assoc-ignore-case chnl liece-nick-buffer-alist)))
 421         (xuser user))
 422     (liece-channel-set-voice-1 chnl user val)
 423     (setq user (concat (if val "+" " ") user)
 424           xuser (concat (if val " " "\\+") (regexp-quote xuser)))
 425     (with-current-buffer nbuf
 426       (let (buffer-read-only)
 427         (goto-char (point-min))
 428         (liece-nick-replace xuser user nil t)))))
 429
 430 (defun liece-channel-prepare-partner (join-channel-var)
 431   (setq liece-current-chat-partner
 432         (or liece-current-chat-partner join-channel-var))
 433   (let ((liece-command-buffer-mode 'chat))
 434     (liece-channel-join join-channel-var t))
 435   (liece-channel-change))
 436
 437 (defun liece-channel-buffer-invisible-p (chnl mode)
 438   (let ((cbuf (liece-pick-buffer chnl)))
 439     (or (liece-frozen (car cbuf))
 440         (and (eq mode 'chat)
 441              (not (and (eq liece-command-buffer-mode 'chat)
 442                        liece-current-chat-partner
 443                        (string-equal-ignore-case
 444                         chnl liece-current-chat-partner))))
 445         (not (and (eq liece-command-buffer-mode 'channel)
 446                   liece-current-channel
 447                   (string-equal-ignore-case
 448                    chnl liece-current-channel))))))
 449
 450 (defun liece-channel-prepare-representation (chnl &optional method name)
 451   (cond
 452    ((eq method 'dcc)
 453     (format liece-dcc-channel-representation-format chnl))
 454    (name
 455     (format liece-default-channel-representation-format name chnl))
 456    (t chnl)))
 457
 458 (defun liece-channel-parse-representation (str)
 459   (cond
 460    ((string-match
 461      (format
 462       (regexp-quote liece-dcc-channel-representation-format)
 463       "\\([^ ]+\\)")
 464      str)
 465     (vector 'dcc nil (match-string 1 str)))
 466    ((string-match
 467      (format
 468       (regexp-quote liece-default-channel-representation-format)
 469       "\\([^ ]+\\)" "\\([^ ]+\\)")
 470      str)
 471     (vector 'irc (match-string 1 str) (match-string 2 str)))
 472    (t (vector 'irc nil str))))
 473
 474 (defun liece-channel-list-add-button (n chnl)
 475   (insert (format "%2d: " n))
 476   (if liece-highlight-mode
 477       (let ((st (point)))
 478         (insert chnl)
 479         (liece-widget-convert-button
 480          'liece-channel-push-button st (point) chnl))
 481     (insert chnl))
 482   (insert "\n"))
 483
 484 (defun liece-channel-add-buttons (start end)
 485   (save-excursion
 486     (goto-char start)
 487     (while (re-search-forward
 488             (eval-when-compile
 489               (concat "\\(^\\(" liece-time-prefix-regexp "\\)?"
 490                       "[][=<>(-][][=<>(-]?\\|\\s-+[+@]?\\)"
 491                       "\\([&#!%][^ :]*\\)"))
 492             end t)
 493       ;;(re-search-forward "\\s-+\\(\\)\\([-+]\\S-*\\)" end t)
 494       (let* ((chnl-start (match-beginning 3))
 495              (chnl-end (match-end 3))
 496              (chnl (buffer-substring chnl-start chnl-end)))
 497         (when liece-highlight-mode
 498           (liece-widget-convert-button
 499            'liece-channel-push-button chnl-start chnl-end chnl))))))
 500
 501 ;;;###liece-autoload
 502 (defun liece-channel-redisplay-buffer (chnl)
 503   (let ((buffer
 504          (cdr (string-assoc-ignore-case
 505                chnl liece-channel-buffer-alist)))
 506         (window (liece-get-buffer-window liece-channel-buffer)))
 507     (when (liece-channel-unread-p chnl)
 508       (setq liece-channel-unread-list
 509             (delete chnl liece-channel-unread-list))
 510       (run-hook-with-args 'liece-channel-read-hook chnl))
 511     (and buffer window
 512          (with-current-buffer buffer
 513            (set-window-buffer window buffer)
 514            (unless (liece-frozen buffer)
 515              (set-window-point window (point-max)))
 516            (setq liece-channel-buffer buffer)))))
 517
 518 ;;;###liece-autoload
 519 (defun liece-channel-list-redisplay-buffer (chnl)
 520   (let ((window (liece-get-buffer-window liece-channel-list-buffer)))
 521     (when window
 522       (save-selected-window
 523         (select-window window)
 524         (goto-char (point-min))
 525         (search-forward chnl nil t)
 526         (set-window-point window (match-beginning 0))
 527         (when liece-highlight-mode
 528           (let ((overlay (make-overlay (point)(match-end 0))))
 529             (liece-map-overlays
 530              (lambda (ovl)
 531                (if (overlay-get ovl 'liece-channel)
 532                    (delete-overlay ovl))))
 533             (overlay-put overlay 'face 'underline)
 534             (overlay-put overlay 'liece-channel t)))))))
 535
 536 (provide 'liece-channel)
 537
 538 ;;; liece-channel.el ends here