;;; Code:
(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)
+(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))
+
(defun riece-identity-prefix (identity)
"Return the component sans its server from IDENTITY."
- (if (string-match " " identity)
- (substring identity 0 (match-beginning 0))
- identity))
+ (aref identity 0))
(defun riece-identity-server (identity)
"Return the server component in IDENTITY."
- (if (string-match " " identity)
- (substring identity (match-end 0))))
+ (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)))
+ (vector prefix server))
(defun riece-identity-equal (ident1 ident2)
"Return t, if IDENT1 and IDENT2 is equal."
(riece-identity-server ident1)
(riece-identity-server ident2))))
-(defun riece-identity-equal-safe (ident1 ident2)
- "Return t, if IDENT1 and IDENT2 is equal.
-The only difference with `riece-identity-equal', this function appends
-server name before comparison."
- (riece-identity-equal
- (if (riece-identity-server ident1)
- ident1
- (riece-make-identity ident1))
- (if (riece-identity-server ident2)
- ident2
- (riece-make-identity ident2))))
-
(defun riece-identity-canonicalize-prefix (prefix)
"Canonicalize identity PREFIX.
-This function downcases PREFIX first, then does special treatment for
-Scandinavian alphabets.
+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* ((result (downcase prefix))
- (length (length result))
- (index 0))
- (while (< index length)
- (if (eq (aref result index) ?\[)
- (aset result index ?{)
- (if (eq (aref result index) ?\])
- (aset result index ?})
- (if (eq (aref result index) ?\\)
- (aset result index ?|)
- (if (eq (aref result index) ?~)
- (aset result index ?^)))))
- (setq index (1+ index)))
- result))
+ (let ((old-table (current-case-table)))
+ (unwind-protect
+ (progn
+ (set-case-table riece-identity-prefix-case-table)
+ (downcase prefix))
+ (set-case-table old-table))))
(defun riece-identity-equal-no-server (prefix1 prefix2)
"Return t, if IDENT1 and IDENT2 is equal without server."
(equal (riece-identity-canonicalize-prefix prefix1)
(riece-identity-canonicalize-prefix prefix2)))
-(defun riece-identity-equal-no-server-safe (prefix1 prefix2)
- "Return t, if IDENT1 and IDENT2 is equal without server.
-The only difference with `riece-identity-no-server', this function removes
-server name before comparison."
- (equal (riece-identity-canonicalize-prefix
- (riece-identity-prefix prefix1))
- (riece-identity-canonicalize-prefix
- (riece-identity-prefix prefix2))))
-
(defun riece-identity-member (elt list)
"Return non-nil if an identity ELT is an element of LIST."
(catch 'found
(while list
- (if (and (stringp (car list))
+ (if (and (vectorp (car list)) ;needed because
+ ;riece-current-channels
+ ;contains nil.
(riece-identity-equal (car list) elt))
(throw 'found list)
(setq list (cdr list))))))
-(defun riece-identity-member-safe (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-safe' for comparison."
- (catch 'found
- (while list
- (if (and (stringp (car list))
- (riece-identity-equal-safe (car list) elt))
- (throw 'found list)
- (setq list (cdr list))))))
-
-(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 doesn't
-take server names into account."
- (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-no-server-safe (elt list)
- "Return non-nil if an identity ELT is an element of LIST.
-The only difference with `riece-identity-member-no-server', this function uses
-`riece-identity-equal-no-server-safe' for comparison."
- (catch 'found
- (while list
- (if (and (stringp (car list))
- (riece-identity-equal-no-server-safe (car list) elt))
- (throw 'found list)
- (setq list (cdr list))))))
-
(defun riece-identity-assoc (elt alist)
"Return non-nil if an identity ELT matches the car of an element of ALIST."
(catch 'found
(throw 'found (car alist))
(setq alist (cdr alist))))))
-(defun riece-identity-assoc-safe (elt alist)
- "Return non-nil if an identity ELT matches the car of an element of ALIST.
-The only difference with `riece-identity-assoc', this function uses
-`riece-identity-equal-safe' for comparison."
- (catch 'found
- (while alist
- (if (riece-identity-equal-safe (car (car alist)) elt)
- (throw 'found (car alist))
- (setq alist (cdr alist))))))
-
(defun riece-identity-assign-binding (item list binding)
- (let ((slot (riece-identity-member-safe item binding))
+ (let ((slot (riece-identity-member item binding))
pointer)
(unless list ;we need at least one room
(setq list (list nil)))
(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)
+ (let ((string
+ (if (or prefix-only
+ (equal (riece-identity-server identity) ""))
+ (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)))
+
+(defun riece-parse-identity (string)
+ (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 must-match
+ initial)
+ (let* ((string
+ (completing-read
+ prompt
+ (mapcar (lambda (channel)
+ (list (riece-format-identity channel)))
+ (delq nil (copy-sequence (or channels
+ riece-current-channels))))
+ predicate must-match initial))
+ (identity
+ (riece-parse-identity string)))
+ (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