e025c608344ed38fdfc48d361f2aedbd6ddf064f
[riece] / lisp / riece-identity.el
1 ;;; riece-identity.el --- an identity object
2 ;; Copyright (C) 1998-2003 Daiki Ueno
3
4 ;; Author: Daiki Ueno <ueno@unixuser.org>
5 ;; Created: 1998-09-28
6 ;; Keywords: IRC, riece
7
8 ;; This file is part of Riece.
9
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)
13 ;; any later version.
14
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.
19
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.
24
25 ;;; Code:
26
27 (require 'riece-globals)
28 (require 'riece-coding)
29
30 (defvar riece-abbrev-identity-string-function nil)
31 (defvar riece-expand-identity-string-function nil)
32
33 (defconst riece-identity-prefix-case-pair-alist
34   '((?\[ . ?{)
35     (?\] . ?})
36     (?\\ . ?|)
37     (?~ . ?^))
38   "An alist used to canonicalize identity-prefix.
39 RFC2812, 2.2 \"Character codes\" says:
40    Because of IRC's Scandinavian origin, the characters {}|^ are
41    considered to be the lower case equivalents of the characters []\~,
42    respectively. This is a critical issue when determining the
43    equivalence of two nicknames or channel names.")
44
45 (defun riece-identity-prefix (identity)
46   "Return the component sans its server from IDENTITY."
47   (aref identity 0))
48
49 (defun riece-identity-server (identity)
50   "Return the server component in IDENTITY."
51   (aref identity 1))
52
53 (defun riece-make-identity (prefix server)
54   "Make an identity object from PREFIX and SERVER."
55   (vector prefix server))
56
57 (defun riece-identity-equal (ident1 ident2)
58   "Return t, if IDENT1 and IDENT2 is equal."
59   (and (riece-identity-equal-no-server
60         (riece-identity-prefix ident1)
61         (riece-identity-prefix ident2))
62        (equal
63         (riece-identity-server ident1)
64         (riece-identity-server ident2))))
65
66 (defun riece-identity-canonicalize-prefix (prefix)
67   "Canonicalize identity PREFIX."
68   (let ((i 0)
69         c)
70     (setq prefix (downcase prefix))
71     (while (< i (length prefix))
72       (if (setq c (cdr (assq (aref prefix i)
73                              riece-identity-prefix-case-pair-alist)))
74           (aset prefix i c))
75       (setq i (1+ i)))
76     prefix))
77
78 (defun riece-identity-equal-no-server (prefix1 prefix2)
79   "Return t, if IDENT1 and IDENT2 is equal without server part."
80   (equal (riece-identity-canonicalize-prefix prefix1)
81          (riece-identity-canonicalize-prefix prefix2)))
82
83 (defun riece-identity-member (elt list &optional no-server)
84   "Return non-nil if an identity ELT is an element of LIST."
85   (catch 'found
86     (while list
87       (if (and (car list)       ;needed because riece-current-channels
88                                 ;contains nil.
89                (if no-server
90                    (riece-identity-equal-no-server (car list) elt)
91                  (riece-identity-equal (car list) elt)))
92           (throw 'found list)
93         (setq list (cdr list))))))
94
95 (defun riece-identity-assoc (elt alist &optional no-server)
96   "Return non-nil if an identity ELT matches the car of an element of ALIST."
97   (catch 'found
98     (while alist
99       (if (if no-server
100               (riece-identity-equal-no-server (car (car alist)) elt)
101             (riece-identity-equal (car (car alist)) elt))
102           (throw 'found (car alist))
103         (setq alist (cdr alist))))))
104
105 (defun riece-identity-assign-binding (item list binding)
106   (let ((slot (riece-identity-member item binding))
107         pointer)
108     (unless list                        ;we need at least one room
109       (setq list (list nil)))
110     (setq pointer list)
111     (if slot
112         (while (not (eq binding slot))
113           (unless (cdr pointer)
114             (setcdr pointer (list nil)))
115           (setq pointer (cdr pointer)
116                 binding (cdr binding)))
117       (while (or (car pointer) (car binding))
118         (unless (cdr pointer)
119           (setcdr pointer (list nil)))
120         (setq pointer (cdr pointer)
121               binding (cdr binding))))
122     (setcar pointer item)
123     list))
124
125 (defun riece-format-identity (identity &optional prefix-only)
126   "Convert IDENTITY object to a string.
127 If the optional 2nd argument PREFIX-ONLY is non-nil, don't append
128 server part of the identity.
129
130 The returned string will be abbreviated by
131 `riece-abbrev-identity-string-function', and `riece-identity' property
132 will be added."
133   (let ((string
134          (if (or prefix-only
135                  (equal (riece-identity-server identity) ""))
136              (copy-sequence (riece-identity-prefix identity))
137            (concat (riece-identity-prefix identity) " "
138                    (riece-identity-server identity)))))
139     (if riece-abbrev-identity-string-function
140         (setq string (funcall riece-abbrev-identity-string-function string)))
141     (put-text-property 0 (length string) 'riece-identity identity string)
142     (if prefix-only
143         (put-text-property 0 (length string)
144                            'riece-format-identity-prefix-only t
145                            string))
146     string))
147
148 (defun riece-parse-identity (string)
149   "Convert STRING to an identity object.
150 The string will be expanded by
151 `riece-expand-identity-string-function'."
152   (if riece-expand-identity-string-function
153       (setq string (funcall riece-expand-identity-string-function string)))
154   (riece-make-identity (if (string-match " " string)
155                            (substring string 0 (match-beginning 0))
156                          string)
157                        (if (string-match " " string)
158                            (substring string (match-end 0))
159                          "")))
160
161 (defun riece-completing-read-identity (prompt channels
162                                               &optional predicate require-match
163                                               initial history default
164                                               no-server)
165   "Read an identity object in the minibuffer, with completion.
166 PROMPT is a string to prompt with; normally it ends in a colon and a space.
167 CHANNELS is a list of identity objects.
168 The rest of arguments are the same as `completing-read'."
169   (let* ((string
170           (completing-read
171            prompt
172            (mapcar (lambda (channel)
173                      (list (riece-format-identity channel no-server)))
174                    (delq nil (copy-sequence (or channels
175                                                 riece-current-channels))))
176            predicate require-match initial history default))
177          (identity
178           (riece-parse-identity string)))
179     (unless (string-match (concat "^\\(" riece-channel-regexp "\\|"
180                                   riece-user-regexp "\\)")
181                           (riece-identity-prefix identity))
182       (error "Invalid channel name!"))
183     identity))
184
185 (provide 'riece-identity)
186
187 ;;; riece-identity.el ends here