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., 51 Franklin Street, Fifth Floor,
23 ;; Boston, MA 02110-1301, USA.
27 (require 'riece-globals)
28 (require 'riece-coding)
30 (defcustom riece-channel-coding-system-alist nil
31 "An alist mapping from channels to coding-systems."
32 :type '(repeat (cons (string :tag "Channel")
33 (symbol :tag "Coding system")))
36 (defvar riece-abbrev-identity-string-function nil)
37 (defvar riece-expand-identity-string-function nil)
39 (defconst riece-identity-prefix-case-pair-alist
44 "An alist used to canonicalize identity-prefix.
45 RFC2812, 2.2 \"Character codes\" says:
46 Because of IRC's Scandinavian origin, the characters {}|^ are
47 considered to be the lower case equivalents of the characters []\~,
48 respectively. This is a critical issue when determining the
49 equivalence of two nicknames or channel names.")
51 (defun riece-identity-prefix (identity)
52 "Return the component sans its server name from IDENTITY."
55 (defun riece-identity-server (identity)
56 "Return the server name component in IDENTITY."
59 (defun riece-make-identity (prefix server)
60 "Make an identity object from PREFIX and SERVER."
61 (vector prefix server))
63 (defun riece-identity-equal (ident1 ident2)
64 "Return t, if IDENT1 and IDENT2 are equal."
65 (and (riece-identity-equal-no-server
66 (riece-identity-prefix ident1)
67 (riece-identity-prefix ident2))
69 (riece-identity-server ident1)
70 (riece-identity-server ident2))))
72 (defun riece-identity-canonicalize-prefix (prefix)
73 "Canonicalize identity PREFIX."
76 (setq prefix (downcase prefix))
77 (while (< i (length prefix))
78 (if (setq c (cdr (assq (aref prefix i)
79 riece-identity-prefix-case-pair-alist)))
84 (defun riece-identity-equal-no-server (prefix1 prefix2)
85 "Return t, if IDENT1 and IDENT2 are equal without server part."
86 (equal (riece-identity-canonicalize-prefix prefix1)
87 (riece-identity-canonicalize-prefix prefix2)))
89 (defun riece-identity-member (elt list &optional no-server)
90 "Return non-nil if an identity ELT is an element of LIST."
93 (if (and (car list) ;needed because riece-current-channels
96 (riece-identity-equal-no-server (car list) elt)
97 (riece-identity-equal (car list) elt)))
99 (setq list (cdr list))))))
101 (defun riece-identity-assoc (elt alist &optional no-server)
102 "Return non-nil if an identity ELT matches the car of an element of ALIST."
106 (riece-identity-equal-no-server (car (car alist)) elt)
107 (riece-identity-equal (car (car alist)) elt))
108 (throw 'found (car alist))
109 (setq alist (cdr alist))))))
111 (defun riece-identity-assign-binding (item list binding)
112 (let ((slot (riece-identity-member item binding))
114 (unless list ;we need at least one room
115 (setq list (list nil)))
118 (while (not (eq binding slot))
119 (unless (cdr pointer)
120 (setcdr pointer (list nil)))
121 (setq pointer (cdr pointer)
122 binding (cdr binding)))
123 (while (or (car pointer) (car binding))
124 (unless (cdr pointer)
125 (setcdr pointer (list nil)))
126 (setq pointer (cdr pointer)
127 binding (cdr binding))))
128 (setcar pointer item)
131 (defun riece-format-identity (identity &optional prefix-only)
132 "Convert IDENTITY object to a string.
133 If the optional 2nd argument PREFIX-ONLY is non-nil, don't append
134 server part of the identity.
136 The returned string will be abbreviated by
137 `riece-abbrev-identity-string-function', and `riece-identity' property
141 (equal (riece-identity-server identity) ""))
142 (copy-sequence (riece-identity-prefix identity))
143 (concat (riece-identity-prefix identity) " "
144 (riece-identity-server identity)))))
145 (if riece-abbrev-identity-string-function
146 (setq string (funcall riece-abbrev-identity-string-function string)))
147 (riece-put-text-property-nonsticky 0 (length string)
148 'riece-identity identity
151 (riece-put-text-property-nonsticky 0 (length string)
152 'riece-format-identity-prefix-only t
156 (defun riece-parse-identity (string)
157 "Convert STRING to an identity object.
158 The string will be expanded by
159 `riece-expand-identity-string-function'."
160 (if riece-expand-identity-string-function
161 (setq string (funcall riece-expand-identity-string-function string)))
162 (riece-make-identity (if (string-match " " string)
163 (substring string 0 (match-beginning 0))
165 (if (string-match " " string)
166 (substring string (match-end 0))
169 (defun riece-completing-read-identity (prompt channels
170 &optional predicate require-match
171 initial history default
173 "Read an identity object in the minibuffer, with completion.
174 PROMPT is a string to prompt with; normally it ends in a colon and a space.
175 CHANNELS is a list of identity objects.
176 The rest of arguments are the same as `completing-read'."
180 (mapcar (lambda (channel)
181 (list (riece-format-identity channel no-server)))
182 (delq nil (copy-sequence (or channels
183 riece-current-channels))))
184 predicate require-match initial history default))
186 (riece-parse-identity string)))
187 ;;; (unless (string-match (concat "^\\(" riece-channel-regexp "\\|"
188 ;;; riece-user-regexp "\\)")
189 ;;; (riece-identity-prefix identity))
190 ;;; (error "Invalid channel name!"))
193 (defun riece-coding-system-for-identity (identity)
194 (let ((alist riece-channel-coding-system-alist)
198 (setq matcher (riece-parse-identity (car (car alist))))
199 (if (and (equal (riece-identity-server matcher)
200 (riece-identity-server identity))
201 (equal (riece-identity-prefix matcher)
202 (riece-identity-prefix identity)))
203 (throw 'found (cdr (car alist))))
204 (setq alist (cdr alist))))))
206 (defun riece-decoded-string-for-identity (decoded identity)
207 "Return the string decoded for IDENTITY."
208 (let ((coding-system (riece-coding-system-for-identity identity)))
209 (if (and coding-system
210 (not (eq (riece-decoded-coding-system decoded)
211 (if (consp coding-system)
214 (riece-decode-coding-string-1 (riece-decoded-encoded-string decoded)
218 (defun riece-encode-coding-string-for-identity (string identity)
219 (let ((coding-system (riece-coding-system-for-identity identity)))
221 (encode-coding-string string
222 (if (consp coding-system)
225 (riece-encode-coding-string string))))
227 (provide 'riece-identity)
229 ;;; riece-identity.el ends here