X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Friece-identity.el;h=b1a2f340d299db7ab9d16e5f2015c4518c52cc5d;hb=bec819837ccfdacf776ca820fa54e8b48adf67fa;hp=c01c45473cbdb7082e2030c8e2bb53686e283bd7;hpb=da90e3c6815f79db698d4fd073311d5f8dd922d9;p=elisp%2Friece.git diff --git a/lisp/riece-identity.el b/lisp/riece-identity.el index c01c454..b1a2f34 100644 --- a/lisp/riece-identity.el +++ b/lisp/riece-identity.el @@ -19,32 +19,41 @@ ;; 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: (require 'riece-globals) (require 'riece-coding) -(require 'riece-compat) ;riece-set-case-syntax-pair + +(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) -(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) @@ -52,7 +61,7 @@ (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)) @@ -61,23 +70,19 @@ (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 part." + "Return t, if IDENT1 and IDENT2 are equal without server part." (equal (riece-identity-canonicalize-prefix prefix1) (riece-identity-canonicalize-prefix prefix2))) @@ -139,7 +144,13 @@ will be added." (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) + (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) @@ -157,7 +168,8 @@ The string will be expanded by (defun riece-completing-read-identity (prompt channels &optional predicate require-match - initial history default) + 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. @@ -166,18 +178,52 @@ The rest of arguments are the same as `completing-read'." (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 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)) +(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) ;;; riece-identity.el ends here