1 ;;; riece-identity.el --- an identity object
2 ;; Copyright (C) 1998-2003 Daiki Ueno
4 ;; Author: Daiki Ueno <ueno@unixuser.org>
6 ;; Keywords: IRC, riece
8 ;; This file is part of Riece.
10 ;; This program is free software; you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation; either version 2, or (at your option)
15 ;; This program is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs; see the file COPYING. If not, write to the
22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23 ;; Boston, MA 02111-1307, USA.
27 (eval-when-compile (require 'riece-inlines))
29 (require 'riece-globals)
31 (defun riece-find-server-name ()
32 (or riece-overriding-server-name
33 ;already in the server buffer
34 (if (local-variable-p 'riece-server-name (current-buffer))
36 (if riece-current-channel
37 (riece-identity-server riece-current-channel)))))
39 (defun riece-find-server-process ()
40 (let ((server-name (riece-find-server-name)))
42 (cdr (assoc server-name riece-server-process-alist))
43 riece-server-process)))
45 (defmacro riece-with-server-buffer (&rest body)
46 `(let ((process (riece-find-server-process)))
48 (with-current-buffer (process-buffer process)
50 (error "Server closed."))))
52 (defun riece-identity-prefix (identity)
53 "Return the component sans its server from IDENTITY."
54 (if (string-match " " identity)
55 (substring identity 0 (match-beginning 0))
58 (defun riece-identity-server (identity)
59 "Return the server component in IDENTITY."
60 (if (string-match " " identity)
61 (substring identity (match-end 0))))
63 (defun riece-make-identity (prefix &optional server)
64 "Make an identity object from PREFIX and SERVER."
65 (if (riece-identity-server prefix)
68 (setq server (riece-find-server-name)))
70 (concat prefix " " server)
73 (defun riece-identity-equal-no-server (ident1 ident2)
74 "Return t, if IDENT1 and IDENT2 is equal.
75 The only difference with `riece-identity-equal', this function doesn't
76 append server name before comparison."
77 (and (string-equal-ignore-case
78 (riece-identity-prefix ident1)
79 (riece-identity-prefix ident2))
81 (riece-identity-server ident1)
82 (riece-identity-server ident2))))
84 (defun riece-identity-equal (ident1 ident2)
85 "Return t, if IDENT1 and IDENT2 is equal."
86 (riece-identity-equal-no-server
87 (if (riece-identity-server ident1)
89 (riece-make-identity ident1))
90 (if (riece-identity-server ident2)
92 (riece-make-identity ident2))))
94 (defun riece-identity-member-no-server (elt list)
95 "Return non-nil if an identity ELT is an element of LIST.
96 The only difference with `riece-identity-member', this function uses
97 `riece-identity-equal-no-server' for comparison."
100 (if (and (stringp (car list))
101 (riece-identity-equal-no-server (car list) elt))
103 (setq list (cdr list))))))
105 (defun riece-identity-member (elt list)
106 "Return non-nil if an identity ELT is an element of LIST."
109 (if (and (stringp (car list))
110 (riece-identity-equal (car list) elt))
112 (setq list (cdr list))))))
114 (defun riece-identity-assoc-no-server (elt alist)
115 "Return non-nil if an identity ELT matches the car of an element of ALIST."
118 (if (riece-identity-equal-no-server (car (car alist)) elt)
119 (throw 'found (car alist))
120 (setq alist (cdr alist))))))
122 (defun riece-identity-assoc (elt alist)
123 "Return non-nil if an identity ELT matches the car of an element of ALIST."
126 (if (riece-identity-equal (car (car alist)) elt)
127 (throw 'found (car alist))
128 (setq alist (cdr alist))))))
130 (defun riece-identity-assign-binding (item list binding)
131 (let ((slot (riece-identity-member item binding))
133 (unless list ;we need at least one room
134 (setq list (list nil)))
137 (while (not (eq binding slot))
138 (unless (cdr pointer)
139 (setcdr pointer (list nil)))
140 (setq pointer (cdr pointer)
141 binding (cdr binding)))
142 (while (or (car pointer) (car binding))
143 (unless (cdr pointer)
144 (setcdr pointer (list nil)))
145 (setq pointer (cdr pointer)
146 binding (cdr binding))))
147 (setcar pointer item)
150 (defun riece-current-nickname ()
151 "Return the current nickname."
152 (riece-with-server-buffer
153 (if riece-real-nickname
154 (riece-make-identity riece-real-nickname))))
156 (provide 'riece-identity)
158 ;;; riece-identity.el ends here