X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Friece-identity.el;h=098f50fe9b50f9f3c7e63320fde774558f4d04d4;hb=b9d6ae0d8aa0c6459bf6cccb8604ce4ff31bf66b;hp=69f742d7d48f8e9da687bf1ed5394b3388b0497a;hpb=3b8a533e6dcd10f11ab2929b69eae91bdbfa7888;p=riece diff --git a/lisp/riece-identity.el b/lisp/riece-identity.el index 69f742d..098f50f 100644 --- a/lisp/riece-identity.el +++ b/lisp/riece-identity.el @@ -24,154 +24,74 @@ ;;; 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) +(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." - (and (scandinavian-equal-ignore-case + (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-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 @@ -180,18 +100,8 @@ The only difference with `riece-identity-member-no-server', this function uses (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))) @@ -210,11 +120,46 @@ The only difference with `riece-identity-assoc', this function uses (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 + (setq string (funcall riece-abbrev-identity-string-function string))) + (put-text-property 0 (length string) 'riece-identity identity 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 require-match + initial history default) + (let* ((string + (completing-read + prompt + (mapcar (lambda (channel) + (list (riece-format-identity channel))) + (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)) (provide 'riece-identity)