;;; liece-nick.el --- Various facility for nick operation.
;; Copyright (C) 1998-2000 Daiki Ueno

;; Author: Daiki Ueno <ueno@unixuser.org>
;; Created: 1998-09-28
;; Revised: 1998-11-25
;; Keywords: IRC, liece

;; This file is part of Liece.

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.	 See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.


;;; Commentary:
;; 

;;; Code:

(require 'liece-hilit)

(defalias 'liece-nick-set-operator 'liece-channel-set-operator)
(defalias 'liece-nick-set-voice 'liece-channel-set-voice)
(defalias 'liece-nick-equal 'string-equal-ignore-case)

(defun liece-nick-member (nick nicks)
  "Return non-nil if NICK is member of NICKS."
  (member-if
   (lambda (item)
     (and (stringp item) (liece-nick-equal nick item)))
   nicks))

(defvar liece-nick-insert-hook nil)
(defvar liece-nick-replace-hook nil)

(define-widget 'liece-nick-push-button 'push-button
  "A nick button."
  :action 'liece-nick-popup-menu)

(defcustom liece-nick-sort-nicks nil
  "If t, sort nick list in each time."
  :type 'boolean
  :group 'liece-vars)

(defcustom liece-nick-sort-predicate 'string-lessp
  "Function for sorting nick buffers."
  :type 'function
  :group 'liece-vars)

;;; @ internal access methods
;;;
(defmacro liece-nick-get-joined-channels (nick)
  "Return channels as list NICK is joined."
  `(get (intern ,nick liece-obarray) 'chnl))

(defmacro liece-nick-get-user-at-host (nick)
  "Return user-at-host as string NICK is joined."
  `(get (intern ,nick liece-obarray) 'user-at-host))

(defmacro liece-nick-set-user-at-host (nick uah)
  "Set user at host as string NICK is joined."
  `(put (intern ,nick liece-obarray) 'user-at-host ,uah))

(defmacro liece-nick-mark-as-apart (nick)
  "Mark NICK is temporary apart."
  `(put (intern ,nick liece-obarray) 'part t))

(defmacro liece-nick-unmark-as-apart (nick)
  "Mark NICK is temporary apart."
  `(put (intern ,nick liece-obarray) 'part nil))

(defmacro liece-nick-get-modes (nick)
  "Return modes as string NICK is joined."
  `(get (intern ,nick liece-obarray) 'mode))

(defmacro liece-nick-add-mode (mode &optional nick)
  "Add MODE as char to NICK."
  `(let* ((n (intern ,nick liece-obarray))
	  (modes (string-to-char-list (or (get n 'mode) ""))))
     (put n 'mode (mapconcat #'char-to-string
			     (or (memq ,mode modes)
				 (cons ,mode modes)) ""))))

(defmacro liece-nick-remove-mode (mode &optional nick)
  "Remove MODE as char to NICK."
  `(let* ((n (intern ,nick liece-obarray))
	  (modes (string-to-char-list (or (get n 'mode) ""))))
     (delq ,mode modes)
     (put n 'mode (mapconcat #'char-to-string modes ""))))

(defmacro liece-nick-set-mode (val mode &optional nick)
  "Set MODE as char to CHNL."
  `(if ,val
       (liece-nick-add-mode ,mode ,nick)
     (liece-nick-remove-mode ,mode ,nick)))

(defmacro liece-nick-strip (nick)
  `(if (and ,nick (memq (aref ,nick 0) '(?@ ?+ ? )))
       (substring ,nick 1)
     ,nick))

(defmacro liece-nick-normalize (nick)
  `(if (and ,nick (memq (aref ,nick 0) '(?@ ?+ ? )))
       ,nick
     (concat " " ,nick)))

;;; @ display
;;;
(defun liece-nick-insert (nick)
  ;; Find sorted position
  (cond
   ((and (eq liece-nick-sort-nicks t)
	 (liece-functionp liece-nick-sort-predicate))
    (let (nicks found)
      (goto-char (point-min))
      (while (and (not (eobp)) (not found))
	(if (condition-case nil
		(funcall liece-nick-sort-predicate
			 (liece-nick-strip nick)
			 (widget-value (widget-at (1+ (point)))))
	      (void-function nil))
	    (setq found t)
	  (beginning-of-line 2)))))
    ((eq liece-nick-sort-nicks 'reverse)
     (goto-char (point-min)))
    (t (goto-char (point-max))))

  (insert (substring nick 0 1))
  (let ((st (point)) (nick (liece-nick-strip nick)))
    (insert nick)
    (when liece-highlight-mode
      (liece-widget-convert-button
       'liece-nick-push-button st (point) nick))
    (insert "\n")
    (run-hook-with-args 'liece-nick-insert-hook st (point))))

(defun liece-nick-replace (old new &optional limit regexp)
  (if regexp
      (setq old (concat "^\\(" old "\\)$"))
    (setq old (concat "^\\([ @+]\\)\\(" (regexp-quote old) "\\)$")))
  (let (case-fold-search beg end)
    (when (re-search-forward old limit t)
      (unless regexp
	(setq new (concat (match-string 1) new)))
      (if (and (eq liece-nick-sort-nicks t)
	       (liece-functionp liece-nick-sort-predicate))
	  (progn
	    (delete-region (match-beginning 0)
			   (progn (goto-char (match-end 0))
				  (forward-char) (point)))
	    (liece-nick-insert new))
	(condition-case nil
	    (widget-delete (widget-at (1+ (point))))
	  (void-function nil))
	(replace-match new t t)
	(setq end (point)
	      beg (progn (beginning-of-line) (1+ (point))))
	(when liece-highlight-mode
	  (liece-widget-convert-button
	   'liece-nick-push-button beg end (substring new 1)))
	(run-hook-with-args 'liece-nick-replace-hook beg end)))))

;;;###liece-autoload
(defun liece-command-toggle-nick-buffer-mode ()
  (interactive)
  (when (and (eq liece-command-buffer-mode 'channel)
	     (get-buffer liece-nick-buffer))
    (setq liece-nick-buffer-mode (not liece-nick-buffer-mode)))
  (liece-configure-windows))

(defmacro liece-nick-buffer-create (chnl)
  `(with-current-buffer
       (liece-get-buffer-create (format liece-nick-buffer-format ,chnl))
     (unless (eq major-mode 'liece-nick-mode)
       (liece-nick-mode))
     (set-alist 'liece-nick-buffer-alist ,chnl (current-buffer))
     (current-buffer)))

(defun liece-change-nick-of-1 (old new nicks)
  (if new
      (do ((nicks nicks (cdr nicks)))
	  ((or (null nicks)
	       (if (liece-nick-equal (caar nicks) old)
		   (setcar (car nicks) new))))
	nil)
    (delete-if
     `(lambda (nick) (liece-nick-equal (car nick) ,old))
     nicks)))
  
(defun liece-change-nick-of-2 (old new nicks)
  (if new
      (do ((nicks nicks (cdr nicks)))
	  ((or (not nicks)
	       (if (liece-nick-equal (car nicks) old)
		   (setcar nicks new))))
	nil)
    (delete-if
     `(lambda (nick) (liece-nick-equal nick ,old))
     nicks)))

(defun liece-change-nick-of (old new)
  (liece-change-nick-of-1 old new liece-nick-alist)
  (let ((chnls (liece-nick-get-joined-channels old)))
    (dolist (chnl chnls)
      (liece-change-nick-of-2 old new (liece-channel-get-nicks chnl))
      (liece-change-nick-of-2 old new (liece-channel-get-operators chnl))
      (liece-change-nick-of-2 old new (liece-channel-get-voices chnl)))))

(defmacro liece-nick-join-1 (user chnl)
  "Add CHNL to list of channels USER belongs to."
  `(let* ((flag (string-to-char user))
	  (user (liece-nick-strip ,user))
	  (u (intern user liece-obarray))
	  (c (intern ,chnl liece-obarray)))
     (or (string-assoc-ignore-case user liece-nick-alist)
	 (push (list user) liece-nick-alist))
     (cond
      ((char-equal flag ?@)
       (liece-channel-set-operator ,chnl user t))
      ((char-equal flag ?+)
       (liece-channel-set-voice ,chnl user t)))
     (or (string-list-member-ignore-case ,chnl (get u 'chnl))
	 (put u 'chnl (cons ,chnl (get u 'chnl))))
     (or (string-list-member-ignore-case user (get c 'nick))
	 (put c 'nick (cons user (get c 'nick))))))
		
(defmacro liece-nick-part-1 (user chnl)
  "Remove USER information from his CHNL."
  `(let ((u (intern ,user liece-obarray))
	 (c (intern ,chnl liece-obarray)))
     (liece-channel-set-operator ,chnl ,user nil)
     (liece-channel-set-voice ,chnl ,user nil)
     (put u 'chnl (string-list-remove-ignore-case ,chnl (get u 'chnl)))
     (put c 'nick (string-list-remove-ignore-case ,user (get c 'nick)))))

;;;###liece-autoload
(defun liece-nick-join (user chnl)
  (liece-nick-join-1 user chnl)
  (let ((nbuf (cdr (string-assoc-ignore-case chnl liece-nick-buffer-alist))))
    (with-current-buffer nbuf
      (let (buffer-read-only)
	(liece-nick-insert (liece-nick-normalize user))))))

;;;###liece-autoload
(defun liece-nick-part (user chnl)
  (let ((nbuf (cdr (string-assoc-ignore-case chnl liece-nick-buffer-alist))))
    (setq user (liece-nick-strip user))
    (with-current-buffer nbuf
      (let ((case-fold-search t) buffer-read-only)
	(goto-char (point-min))
	(when (re-search-forward (concat "^." (regexp-quote user) "$") nil t)
	  (delete-region (match-beginning 0)
			 (progn (goto-char (match-end 0))
				(forward-char) (point)))
	  (liece-nick-part-1 user chnl))))))

;;;###liece-autoload
(defun liece-nick-change (old new)
  (let* ((old (liece-nick-strip old)) (new (liece-nick-strip new))
	 (chnls (get (intern old liece-obarray) 'chnl)) chnl nbuf)
    (liece-change-nick-of old new)
    (if new
	(put (intern new liece-obarray) 'chnl chnls))
    (unintern old liece-obarray)
    (dolist (chnl chnls)
      (if (null new)
	  (liece-nick-part old chnl)
	(setq nbuf (cdr (string-assoc-ignore-case
			 chnl liece-nick-buffer-alist)))
	(with-current-buffer nbuf
	  (let (buffer-read-only)
	    (goto-char (point-min))
	    (liece-nick-replace old new)))))))

;;;###liece-autoload
(defun liece-nick-update (chnl users)
  (let ((c (intern chnl liece-obarray))
	(nbuf (cdr (string-assoc-ignore-case chnl liece-nick-buffer-alist))))
    (mapcar (lambda (prop) (put c prop nil)) '(nick oper voice))
    (with-current-buffer nbuf
      (let (buffer-read-only)
	(liece-kill-all-overlays)
	(erase-buffer)))
    (when (and liece-nick-sort-nicks
	       (liece-functionp liece-nick-sort-predicate))
      (setq users (sort users
			(lambda (s1 s2)
			  (funcall liece-nick-sort-predicate
				   (liece-nick-strip s1)
				   (liece-nick-strip s2))))))
    (let (liece-nick-sort-predicate)
      (dolist (user users)
	(liece-nick-join user chnl)))))

(defvar liece-nick-region-nicks nil)

;;;###liece-autoload
(defun liece-nick-update-region ()
  (setq liece-nick-region-nicks nil)
  (save-excursion
    (let (region nick)
      (if (not (region-active-p))
	  (setq region (cons (line-beginning-position)
			     (line-beginning-position 2)))
	(setq region (cons (region-beginning) (region-end)))
	(goto-char (car region))
	(setcar region (line-beginning-position))
	(goto-char (cdr region))
	(if (eobp)
	    (setcdr region (line-beginning-position))
	  (setcdr region (line-beginning-position 2))))
      (save-restriction
	(narrow-to-region (car region) (cdr region))
	(goto-char (point-min))
	(while (not (eobp))
	  (setq nick (widget-value (widget-at (1+ (point)))))
	  (push nick liece-nick-region-nicks)
	  (beginning-of-line 2))))))

(defun liece-nick-add-buttons (start end)
  (save-excursion
    (goto-char start)
    (while (re-search-forward
	    (eval-when-compile
	      (concat "^\\(" liece-time-prefix-regexp "\\)?"
		      "[][=<>(][][=<>(]?\\([^:]*:\\)?\\([^][=<>(]+\\)"))
	    end t)
      (let* ((nick-start (match-beginning 3))
	     (nick-end (match-end 3))
	     (nick (buffer-substring nick-start nick-end)))
	(when liece-highlight-mode
	  (liece-widget-convert-button
	   'liece-nick-push-button nick-start nick-end nick))))))

;;;###liece-autoload
(defun liece-nick-redisplay-buffer (chnl)
  (let ((buffer
	 (cdr (string-assoc-ignore-case
	       chnl liece-nick-buffer-alist)))
	(window (liece-get-buffer-window liece-nick-buffer)))
    (and buffer window
	 (with-current-buffer buffer
	   (set-window-buffer window buffer)
	   (unless (liece-frozen buffer)
	     (set-window-start window (point-min)))
	   (setq liece-nick-buffer buffer)))))

(provide 'liece-nick)

;;; liece-nick.el ends here