;; 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.
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
;;; Code:
-(eval-when-compile (require 'riece-inlines))
-
(require 'riece-globals)
-
-(defun riece-find-server-name ()
- (or riece-overriding-server-name
- ;already in the server buffer
- (if (local-variable-p 'riece-server-name (current-buffer))
- riece-server-name
- (if riece-current-channel
- (riece-identity-server riece-current-channel)))))
-
-(defun riece-find-server-process ()
- (let ((server-name (riece-find-server-name)))
- (if server-name
- (cdr (assoc server-name riece-server-process-alist))
- riece-server-process)))
-
-(defmacro riece-with-server-buffer (&rest body)
- `(let ((process (riece-find-server-process)))
- (if process
- (with-current-buffer (process-buffer process)
- ,@body)
- (error "Server closed."))))
+(require 'riece-coding)
+
+(defcustom riece-channel-coding-system-alist nil
+ "An alist mapping from channels to coding-systems."
+ :type '(repeat (cons (string :tag "Channel")
+ (symbol :tag "Coding system")))
+ :group 'riece-coding)
+
+(defvar riece-abbrev-identity-string-function nil)
+(defvar riece-expand-identity-string-function nil)
+
+(defconst riece-identity-prefix-case-pair-alist
+ '((?\[ . ?{)
+ (?\] . ?})
+ (?\\ . ?|)
+ (?~ . ?^))
+ "An alist used to canonicalize identity-prefix.
+RFC2812, 2.2 \"Character codes\" says:
+ Because of IRC's Scandinavian origin, the characters {}|^ are
+ considered to be the lower case equivalents of the characters []\~,
+ respectively. This is a critical issue when determining the
+ equivalence of two nicknames or channel names.")
(defun riece-identity-prefix (identity)
- "Return the component sans its server from IDENTITY."
- (if (string-match " " identity)
- (substring identity 0 (match-beginning 0))
- identity))
+ "Return the component sans its server name from IDENTITY."
+ (aref identity 0))
(defun riece-identity-server (identity)
- "Return the server component in IDENTITY."
- (if (string-match " " identity)
- (substring identity (match-end 0))))
+ "Return the server name component in IDENTITY."
+ (aref identity 1))
-(defun riece-make-identity (prefix &optional server)
+(defun riece-make-identity (prefix server)
"Make an identity object from PREFIX and SERVER."
- (if (riece-identity-server prefix)
- prefix
- (unless server
- (setq server (riece-find-server-name)))
- (if server
- (concat prefix " " server)
- prefix)))
-
-(defun riece-identity-equal-no-server (ident1 ident2)
- "Return t, if IDENT1 and IDENT2 is equal.
-The only difference with `riece-identity-equal', this function doesn't
-append server name before comparison."
- (and (string-equal-ignore-case
+ (vector prefix server))
+
+(defun riece-identity-equal (ident1 ident2)
+ "Return t, if IDENT1 and IDENT2 are equal."
+ (and (riece-identity-equal-no-server
(riece-identity-prefix ident1)
(riece-identity-prefix ident2))
(equal
(riece-identity-server ident1)
(riece-identity-server ident2))))
-(defun riece-identity-equal (ident1 ident2)
- "Return t, if IDENT1 and IDENT2 is equal."
- (riece-identity-equal-no-server
- (if (riece-identity-server ident1)
- ident1
- (riece-make-identity ident1))
- (if (riece-identity-server ident2)
- ident2
- (riece-make-identity ident2))))
-
-(defun riece-identity-member-no-server (elt list)
- "Return non-nil if an identity ELT is an element of LIST.
-The only difference with `riece-identity-member', this function uses
-`riece-identity-equal-no-server' for comparison."
- (catch 'found
- (while list
- (if (and (stringp (car list))
- (riece-identity-equal-no-server (car list) elt))
- (throw 'found list)
- (setq list (cdr list))))))
-
-(defun riece-identity-member (elt list)
+(defun riece-identity-canonicalize-prefix (prefix)
+ "Canonicalize identity PREFIX."
+ (let ((i 0)
+ c)
+ (setq prefix (downcase prefix))
+ (while (< i (length prefix))
+ (if (setq c (cdr (assq (aref prefix i)
+ riece-identity-prefix-case-pair-alist)))
+ (aset prefix i c))
+ (setq i (1+ i)))
+ prefix))
+
+(defun riece-identity-equal-no-server (prefix1 prefix2)
+ "Return t, if IDENT1 and IDENT2 are equal without server part."
+ (equal (riece-identity-canonicalize-prefix prefix1)
+ (riece-identity-canonicalize-prefix prefix2)))
+
+(defun riece-identity-member (elt list &optional no-server)
"Return non-nil if an identity ELT is an element of LIST."
(catch 'found
(while list
- (if (and (stringp (car list))
- (riece-identity-equal (car list) elt))
+ (if (and (car list) ;needed because riece-current-channels
+ ;contains nil.
+ (if no-server
+ (riece-identity-equal-no-server (car list) elt)
+ (riece-identity-equal (car list) elt)))
(throw 'found list)
(setq list (cdr list))))))
-(defun riece-identity-assoc-no-server (elt alist)
+(defun riece-identity-assoc (elt alist &optional no-server)
"Return non-nil if an identity ELT matches the car of an element of ALIST."
(catch 'found
(while alist
- (if (riece-identity-equal-no-server (car (car alist)) elt)
- (throw 'found (car alist))
- (setq alist (cdr alist))))))
-
-(defun riece-identity-assoc (elt alist)
- "Return non-nil if an identity ELT matches the car of an element of ALIST."
- (catch 'found
- (while alist
- (if (riece-identity-equal (car (car alist)) elt)
+ (if (if no-server
+ (riece-identity-equal-no-server (car (car alist)) elt)
+ (riece-identity-equal (car (car alist)) elt))
(throw 'found (car alist))
(setq alist (cdr alist))))))
(setcar pointer item)
list))
-(defun riece-current-nickname ()
- "Return the current nickname."
- (riece-with-server-buffer
- (if riece-real-nickname
- (riece-make-identity riece-real-nickname))))
+(defun riece-format-identity (identity &optional prefix-only)
+ "Convert IDENTITY object to a string.
+If the optional 2nd argument PREFIX-ONLY is non-nil, don't append
+server part of the identity.
+
+The returned string will be abbreviated by
+`riece-abbrev-identity-string-function', and `riece-identity' property
+will be added."
+ (let ((string
+ (if (or prefix-only
+ (equal (riece-identity-server identity) ""))
+ (copy-sequence (riece-identity-prefix identity))
+ (concat (riece-identity-prefix identity) " "
+ (riece-identity-server identity)))))
+ (if riece-abbrev-identity-string-function
+ (setq string (funcall riece-abbrev-identity-string-function string)))
+ (riece-put-text-property-nonsticky 0 (length string)
+ 'riece-identity identity
+ string)
+ (if prefix-only
+ (riece-put-text-property-nonsticky 0 (length string)
+ 'riece-format-identity-prefix-only t
+ string))
+ string))
+
+(defun riece-parse-identity (string)
+ "Convert STRING to an identity object.
+The string will be expanded by
+`riece-expand-identity-string-function'."
+ (if riece-expand-identity-string-function
+ (setq string (funcall riece-expand-identity-string-function string)))
+ (riece-make-identity (if (string-match " " string)
+ (substring string 0 (match-beginning 0))
+ string)
+ (if (string-match " " string)
+ (substring string (match-end 0))
+ "")))
+
+(defun riece-completing-read-identity (prompt channels
+ &optional predicate require-match
+ initial history default
+ no-server)
+ "Read an identity object in the minibuffer, with completion.
+PROMPT is a string to prompt with; normally it ends in a colon and a space.
+CHANNELS is a list of identity objects.
+The rest of arguments are the same as `completing-read'."
+ (let* ((string
+ (completing-read
+ prompt
+ (mapcar (lambda (channel)
+ (list (riece-format-identity channel no-server)))
+ (delq nil (copy-sequence (or channels
+ riece-current-channels))))
+ predicate require-match initial history default))
+ (identity
+ (riece-parse-identity string)))
+;;; (unless (string-match (concat "^\\(" riece-channel-regexp "\\|"
+;;; riece-user-regexp "\\)")
+;;; (riece-identity-prefix identity))
+;;; (error "Invalid channel name!"))
+ identity))
+
+(defun riece-coding-system-for-identity (identity)
+ (let ((alist riece-channel-coding-system-alist)
+ matcher)
+ (catch 'found
+ (while alist
+ (setq matcher (riece-parse-identity (car (car alist))))
+ (if (and (equal (riece-identity-server matcher)
+ (riece-identity-server identity))
+ (equal (riece-identity-prefix matcher)
+ (riece-identity-prefix identity)))
+ (throw 'found (cdr (car alist))))
+ (setq alist (cdr alist))))))
+
+(defun riece-decoded-string-for-identity (decoded identity)
+ "Return the string decoded for IDENTITY."
+ (let ((coding-system (riece-coding-system-for-identity identity)))
+ (if (and coding-system
+ (not (eq (riece-decoded-coding-system decoded)
+ (if (consp coding-system)
+ (car coding-system)
+ coding-system))))
+ (riece-decode-coding-string-1 (riece-decoded-encoded-string decoded)
+ coding-system)
+ decoded)))
+
+(defun riece-encode-coding-string-for-identity (string identity)
+ (let ((coding-system (riece-coding-system-for-identity identity)))
+ (if coding-system
+ (encode-coding-string string
+ (if (consp coding-system)
+ (cdr coding-system)
+ coding-system))
+ (riece-encode-coding-string string))))
(provide 'riece-identity)