(require 'riece-globals)
(require 'riece-coding)
-(require 'riece-server)
-(require 'riece-compat) ;riece-set-case-syntax-pair
(defvar riece-abbrev-identity-string-function nil)
(defvar riece-expand-identity-string-function nil)
-(defvar riece-identity-prefix-case-table
- (let ((table (copy-case-table (standard-case-table))))
- (riece-set-case-syntax-pair ?\[ ?{ table)
- (riece-set-case-syntax-pair ?\] ?} table)
- (riece-set-case-syntax-pair ?\\ ?| table)
- (riece-set-case-syntax-pair ?~ ?^ table)
- table))
-
+(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."
+ "Return the component sans its server name from IDENTITY."
(aref identity 0))
(defun riece-identity-server (identity)
- "Return the server component in IDENTITY."
+ "Return the server name component in IDENTITY."
(aref identity 1))
(defun riece-make-identity (prefix server)
(vector prefix server))
(defun riece-identity-equal (ident1 ident2)
- "Return t, if IDENT1 and IDENT2 is equal."
+ "Return t, if IDENT1 and IDENT2 are equal."
(and (riece-identity-equal-no-server
(riece-identity-prefix ident1)
(riece-identity-prefix ident2))
(riece-identity-server ident2))))
(defun riece-identity-canonicalize-prefix (prefix)
- "Canonicalize identity PREFIX.
-This function downcases PREFIX with Scandinavian alphabet rule.
-
-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."
- (let ((old-table (current-case-table)))
- (unwind-protect
- (progn
- (set-case-table riece-identity-prefix-case-table)
- (downcase prefix))
- (set-case-table old-table))))
+ "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 is equal without server."
+ "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)
+(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 (vectorp (car list)) ;needed because
- ;riece-current-channels
- ;contains nil.
- (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 (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 (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))))))
list))
(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) ""))
- (riece-identity-prefix identity)
+ (copy-sequence (riece-identity-prefix identity))
(concat (riece-identity-prefix identity) " "
(riece-identity-server identity)))))
(if riece-abbrev-identity-string-function
- (funcall riece-abbrev-identity-string-function string)
- string)))
+ (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)
"")))
(defun riece-completing-read-identity (prompt channels
- &optional predicate must-match
- initial)
+ &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)))
+ (list (riece-format-identity channel no-server)))
(delq nil (copy-sequence (or channels
riece-current-channels))))
- predicate must-match initial))
+ 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!"))
+;;; (unless (string-match (concat "^\\(" riece-channel-regexp "\\|"
+;;; riece-user-regexp "\\)")
+;;; (riece-identity-prefix identity))
+;;; (error "Invalid channel name!"))
identity))
(provide 'riece-identity)
projects / riece / blobdiff