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