lisp/liece-nick.el

   1 ;;; liece-nick.el --- Various facility for nick operation.
   2 ;; Copyright (C) 1998-2000 Daiki Ueno
   3
   4 ;; Author: Daiki Ueno <ueno@unixuser.org>
   5 ;; Created: 1998-09-28
   6 ;; Revised: 1998-11-25
   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 (require 'liece-hilit)
  33
  34 (defalias 'liece-nick-set-operator 'liece-channel-set-operator)
  35 (defalias 'liece-nick-set-voice 'liece-channel-set-voice)
  36 (defalias 'liece-nick-equal 'string-equal-ignore-case)
  37
  38 (defun liece-nick-member (nick nicks)
  39   "Return non-nil if NICK is member of NICKS."
  40   (member-if
  41    (lambda (item)
  42      (and (stringp item) (liece-nick-equal nick item)))
  43    nicks))
  44
  45 (defvar liece-nick-insert-hook nil)
  46 (defvar liece-nick-replace-hook nil)
  47
  48 (define-widget 'liece-nick-push-button 'push-button
  49   "A nick button."
  50   :action 'liece-nick-popup-menu)
  51
  52 (defcustom liece-nick-sort-nicks nil
  53   "If t, sort nick list in each time."
  54   :type 'boolean
  55   :group 'liece-vars)
  56
  57 (defcustom liece-nick-sort-predicate 'string-lessp
  58   "Function for sorting nick buffers."
  59   :type 'function
  60   :group 'liece-vars)
  61
  62 ;;; @ internal access methods
  63 ;;;
  64 (defmacro liece-nick-get-joined-channels (nick)
  65   "Return channels as list NICK is joined."
  66   `(get (intern ,nick liece-obarray) 'chnl))
  67
  68 (defmacro liece-nick-get-user-at-host (nick)
  69   "Return user-at-host as string NICK is joined."
  70   `(get (intern ,nick liece-obarray) 'user-at-host))
  71
  72 (defmacro liece-nick-set-user-at-host (nick uah)
  73   "Set user at host as string NICK is joined."
  74   `(put (intern ,nick liece-obarray) 'user-at-host ,uah))
  75
  76 (defmacro liece-nick-mark-as-apart (nick)
  77   "Mark NICK is temporary apart."
  78   `(put (intern ,nick liece-obarray) 'part t))
  79
  80 (defmacro liece-nick-unmark-as-apart (nick)
  81   "Mark NICK is temporary apart."
  82   `(put (intern ,nick liece-obarray) 'part nil))
  83
  84 (defmacro liece-nick-get-modes (nick)
  85   "Return modes as string NICK is joined."
  86   `(get (intern ,nick liece-obarray) 'mode))
  87
  88 (defmacro liece-nick-add-mode (mode &optional nick)
  89   "Add MODE as char to NICK."
  90   `(let* ((n (intern ,nick liece-obarray))
  91           (modes (string-to-char-list (or (get n 'mode) ""))))
  92      (put n 'mode (mapconcat #'char-to-string
  93                              (or (memq ,mode modes)
  94                                  (cons ,mode modes)) ""))))
  95
  96 (defmacro liece-nick-remove-mode (mode &optional nick)
  97   "Remove MODE as char to NICK."
  98   `(let* ((n (intern ,nick liece-obarray))
  99           (modes (string-to-char-list (or (get n 'mode) ""))))
 100      (delq ,mode modes)
 101      (put n 'mode (mapconcat #'char-to-string modes ""))))
 102
 103 (defmacro liece-nick-set-mode (val mode &optional nick)
 104   "Set MODE as char to CHNL."
 105   `(if ,val
 106        (liece-nick-add-mode ,mode ,nick)
 107      (liece-nick-remove-mode ,mode ,nick)))
 108
 109 (defmacro liece-nick-strip (nick)
 110   `(if (and ,nick (memq (aref ,nick 0) '(?@ ?+ ? )))
 111        (substring ,nick 1)
 112      ,nick))
 113
 114 (defmacro liece-nick-normalize (nick)
 115   `(if (and ,nick (memq (aref ,nick 0) '(?@ ?+ ? )))
 116        ,nick
 117      (concat " " ,nick)))
 118
 119 ;;; @ display
 120 ;;;
 121 (defun liece-nick-insert (nick)
 122   ;; Find sorted position
 123   (cond
 124    ((and (eq liece-nick-sort-nicks t)
 125          (liece-functionp liece-nick-sort-predicate))
 126     (let (nicks found)
 127       (goto-char (point-min))
 128       (while (and (not (eobp)) (not found))
 129         (if (condition-case nil
 130                 (funcall liece-nick-sort-predicate
 131                          (liece-nick-strip nick)
 132                          (widget-value (widget-at (1+ (point)))))
 133               (void-function nil))
 134             (setq found t)
 135           (beginning-of-line 2)))))
 136     ((eq liece-nick-sort-nicks 'reverse)
 137      (goto-char (point-min)))
 138     (t (goto-char (point-max))))
 139
 140   (insert (substring nick 0 1))
 141   (let ((st (point)) (nick (liece-nick-strip nick)))
 142     (insert nick)
 143     (when liece-highlight-mode
 144       (liece-widget-convert-button
 145        'liece-nick-push-button st (point) nick))
 146     (insert "\n")
 147     (run-hook-with-args 'liece-nick-insert-hook st (point))))
 148
 149 (defun liece-nick-replace (old new &optional limit regexp)
 150   (if regexp
 151       (setq old (concat "^\\(" old "\\)$"))
 152     (setq old (concat "^\\([ @+]\\)\\(" (regexp-quote old) "\\)$")))
 153   (let (case-fold-search beg end)
 154     (when (re-search-forward old limit t)
 155       (unless regexp
 156         (setq new (concat (match-string 1) new)))
 157       (if (and (eq liece-nick-sort-nicks t)
 158                (liece-functionp liece-nick-sort-predicate))
 159           (progn
 160             (delete-region (match-beginning 0)
 161                            (progn (goto-char (match-end 0))
 162                                   (forward-char) (point)))
 163             (liece-nick-insert new))
 164         (condition-case nil
 165             (widget-delete (widget-at (1+ (point))))
 166           (void-function nil))
 167         (replace-match new t t)
 168         (setq end (point)
 169               beg (progn (beginning-of-line) (1+ (point))))
 170         (when liece-highlight-mode
 171           (liece-widget-convert-button
 172            'liece-nick-push-button beg end (substring new 1)))
 173         (run-hook-with-args 'liece-nick-replace-hook beg end)))))
 174
 175 ;;;###liece-autoload
 176 (defun liece-command-toggle-nick-buffer-mode ()
 177   (interactive)
 178   (when (and (eq liece-command-buffer-mode 'channel)
 179              (get-buffer liece-nick-buffer))
 180     (setq liece-nick-buffer-mode (not liece-nick-buffer-mode)))
 181   (liece-configure-windows))
 182
 183 (defmacro liece-nick-buffer-create (chnl)
 184   `(with-current-buffer
 185        (liece-get-buffer-create (format liece-nick-buffer-format ,chnl))
 186      (unless (eq major-mode 'liece-nick-mode)
 187        (liece-nick-mode))
 188      (set-alist 'liece-nick-buffer-alist ,chnl (current-buffer))
 189      (current-buffer)))
 190
 191 (defun liece-change-nick-of-1 (old new nicks)
 192   (if new
 193       (do ((nicks nicks (cdr nicks)))
 194           ((or (null nicks)
 195                (if (liece-nick-equal (caar nicks) old)
 196                    (setcar (car nicks) new))))
 197         nil)
 198     (delete-if
 199      `(lambda (nick) (liece-nick-equal (car nick) ,old))
 200      nicks)))
 201
 202 (defun liece-change-nick-of-2 (old new nicks)
 203   (if new
 204       (do ((nicks nicks (cdr nicks)))
 205           ((or (not nicks)
 206                (if (liece-nick-equal (car nicks) old)
 207                    (setcar nicks new))))
 208         nil)
 209     (delete-if
 210      `(lambda (nick) (liece-nick-equal nick ,old))
 211      nicks)))
 212
 213 (defun liece-change-nick-of (old new)
 214   (liece-change-nick-of-1 old new liece-nick-alist)
 215   (let ((chnls (liece-nick-get-joined-channels old)))
 216     (dolist (chnl chnls)
 217       (liece-change-nick-of-2 old new (liece-channel-get-nicks chnl))
 218       (liece-change-nick-of-2 old new (liece-channel-get-operators chnl))
 219       (liece-change-nick-of-2 old new (liece-channel-get-voices chnl)))))
 220
 221 (defmacro liece-nick-join-1 (user chnl)
 222   "Add CHNL to list of channels USER belongs to."
 223   `(let* ((flag (string-to-char user))
 224           (user (liece-nick-strip ,user))
 225           (u (intern user liece-obarray))
 226           (c (intern ,chnl liece-obarray)))
 227      (or (string-assoc-ignore-case user liece-nick-alist)
 228          (push (list user) liece-nick-alist))
 229      (cond
 230       ((char-equal flag ?@)
 231        (liece-channel-set-operator ,chnl user t))
 232       ((char-equal flag ?+)
 233        (liece-channel-set-voice ,chnl user t)))
 234      (or (string-list-member-ignore-case ,chnl (get u 'chnl))
 235          (put u 'chnl (cons ,chnl (get u 'chnl))))
 236      (or (string-list-member-ignore-case user (get c 'nick))
 237          (put c 'nick (cons user (get c 'nick))))))
 238
 239 (defmacro liece-nick-part-1 (user chnl)
 240   "Remove USER information from his CHNL."
 241   `(let ((u (intern ,user liece-obarray))
 242          (c (intern ,chnl liece-obarray)))
 243      (liece-channel-set-operator ,chnl ,user nil)
 244      (liece-channel-set-voice ,chnl ,user nil)
 245      (put u 'chnl (string-list-remove-ignore-case ,chnl (get u 'chnl)))
 246      (put c 'nick (string-list-remove-ignore-case ,user (get c 'nick)))))
 247
 248 ;;;###liece-autoload
 249 (defun liece-nick-join (user chnl)
 250   (liece-nick-join-1 user chnl)
 251   (let ((nbuf (cdr (string-assoc-ignore-case chnl liece-nick-buffer-alist))))
 252     (with-current-buffer nbuf
 253       (let (buffer-read-only)
 254         (liece-nick-insert (liece-nick-normalize user))))))
 255
 256 ;;;###liece-autoload
 257 (defun liece-nick-part (user chnl)
 258   (let ((nbuf (cdr (string-assoc-ignore-case chnl liece-nick-buffer-alist))))
 259     (setq user (liece-nick-strip user))
 260     (with-current-buffer nbuf
 261       (let ((case-fold-search t) buffer-read-only)
 262         (goto-char (point-min))
 263         (when (re-search-forward (concat "^." (regexp-quote user) "$") nil t)
 264           (delete-region (match-beginning 0)
 265                          (progn (goto-char (match-end 0))
 266                                 (forward-char) (point)))
 267           (liece-nick-part-1 user chnl))))))
 268
 269 ;;;###liece-autoload
 270 (defun liece-nick-change (old new)
 271   (let* ((old (liece-nick-strip old)) (new (liece-nick-strip new))
 272          (chnls (get (intern old liece-obarray) 'chnl)) chnl nbuf)
 273     (liece-change-nick-of old new)
 274     (if new
 275         (put (intern new liece-obarray) 'chnl chnls))
 276     (unintern old liece-obarray)
 277     (dolist (chnl chnls)
 278       (if (null new)
 279           (liece-nick-part old chnl)
 280         (setq nbuf (cdr (string-assoc-ignore-case
 281                          chnl liece-nick-buffer-alist)))
 282         (with-current-buffer nbuf
 283           (let (buffer-read-only)
 284             (goto-char (point-min))
 285             (liece-nick-replace old new)))))))
 286
 287 ;;;###liece-autoload
 288 (defun liece-nick-update (chnl users)
 289   (let ((c (intern chnl liece-obarray))
 290         (nbuf (cdr (string-assoc-ignore-case chnl liece-nick-buffer-alist))))
 291     (mapcar (lambda (prop) (put c prop nil)) '(nick oper voice))
 292     (with-current-buffer nbuf
 293       (let (buffer-read-only)
 294         (liece-kill-all-overlays)
 295         (erase-buffer)))
 296     (when (and liece-nick-sort-nicks
 297                (liece-functionp liece-nick-sort-predicate))
 298       (setq users (sort users
 299                         (lambda (s1 s2)
 300                           (funcall liece-nick-sort-predicate
 301                                    (liece-nick-strip s1)
 302                                    (liece-nick-strip s2))))))
 303     (let (liece-nick-sort-predicate)
 304       (dolist (user users)
 305         (liece-nick-join user chnl)))))
 306
 307 (defvar liece-nick-region-nicks nil)
 308 (defvar liece-nick-region-opers nil)
 309 (defvar liece-nick-region-voices nil)
 310
 311 ;;;###liece-autoload
 312 (defun liece-nick-update-region ()
 313   (setq liece-nick-region-nicks nil
 314         liece-nick-region-opers nil
 315         liece-nick-region-voices nil)
 316   (save-excursion
 317     (let (region nick)
 318       (if (not (region-active-p))
 319           (setq region (cons (line-beginning-position)
 320                              (line-beginning-position 2)))
 321         (setq region (cons (region-beginning) (region-end)))
 322         (goto-char (car region))
 323         (setcar region (line-beginning-position))
 324         (goto-char (cdr region))
 325         (if (eobp)
 326             (setcdr region (line-beginning-position))
 327           (setcdr region (line-beginning-position 2))))
 328       (save-restriction
 329         (narrow-to-region (car region) (cdr region))
 330         (goto-char (point-min))
 331         (while (not (eobp))
 332           (setq nick (widget-value (widget-at (1+ (point)))))
 333           (push nick liece-nick-region-nicks)
 334           (if (memq (char-after) '(?@ ?+))
 335               (push nick liece-nick-region-voices))
 336           (if (eq ?@ (char-after))
 337               (push nick liece-nick-region-opers))
 338           (beginning-of-line 2))))))
 339
 340 (defun liece-nick-add-buttons (start end)
 341   (save-excursion
 342     (goto-char start)
 343     (while (re-search-forward
 344             (eval-when-compile
 345               (concat "^\\(" liece-time-prefix-regexp "\\)?"
 346                       "[][=<>(][][=<>(]?\\([^:]*:\\)?\\([^][=<>(]+\\)"))
 347             end t)
 348       (let* ((nick-start (match-beginning 3))
 349              (nick-end (match-end 3))
 350              (nick (buffer-substring nick-start nick-end)))
 351         (when liece-highlight-mode
 352           (liece-widget-convert-button
 353            'liece-nick-push-button nick-start nick-end nick))))))
 354
 355 ;;;###liece-autoload
 356 (defun liece-nick-redisplay-buffer (chnl)
 357   (let ((buffer
 358          (cdr (string-assoc-ignore-case
 359                chnl liece-nick-buffer-alist)))
 360         (window (liece-get-buffer-window liece-nick-buffer)))
 361     (and buffer window
 362          (with-current-buffer buffer
 363            (set-window-buffer window buffer)
 364            (unless (liece-frozen buffer)
 365              (set-window-start window (point-min)))
 366            (setq liece-nick-buffer buffer)))))
 367
 368 (provide 'liece-nick)
 369
 370 ;;; liece-nick.el ends here