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