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