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