cgit.sxemacs.org Git - riece/blob - lisp/riece-identity.el

   1 ;;; riece-identity.el --- an identity object
   2 ;; Copyright (C) 1998-2003 Daiki Ueno
   3
   4 ;; Author: Daiki Ueno <ueno@unixuser.org>
   5 ;; Created: 1998-09-28
   6 ;; Keywords: IRC, riece
   7
   8 ;; This file is part of Riece.
   9
  10 ;; This program is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; This program is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  23 ;; Boston, MA 02110-1301, USA.
  24
  25 ;;; Code:
  26
  27 (require 'riece-globals)
  28 (require 'riece-coding)
  29
  30 (defcustom riece-channel-coding-system-alist nil
  31   "An alist mapping from channels to coding-systems."
  32   :type '(repeat (cons (string :tag "Channel")
  33                        (symbol :tag "Coding system")))
  34   :group 'riece-coding)
  35
  36 (defvar riece-abbrev-identity-string-function nil)
  37 (defvar riece-expand-identity-string-function nil)
  38
  39 (defconst riece-identity-prefix-case-pair-alist
  40   '((?\[ . ?{)
  41     (?\] . ?})
  42     (?\\ . ?|)
  43     (?~ . ?^))
  44   "An alist used to canonicalize identity-prefix.
  45 RFC2812, 2.2 \"Character codes\" says:
  46    Because of IRC's Scandinavian origin, the characters {}|^ are
  47    considered to be the lower case equivalents of the characters []\~,
  48    respectively. This is a critical issue when determining the
  49    equivalence of two nicknames or channel names.")
  50
  51 (defun riece-identity-prefix (identity)
  52   "Return the component sans its server name from IDENTITY."
  53   (aref identity 0))
  54
  55 (defun riece-identity-server (identity)
  56   "Return the server name component in IDENTITY."
  57   (aref identity 1))
  58
  59 (defun riece-make-identity (prefix server)
  60   "Make an identity object from PREFIX and SERVER."
  61   (vector prefix server))
  62
  63 (defun riece-identity-equal (ident1 ident2)
  64   "Return t, if IDENT1 and IDENT2 are equal."
  65   (and (riece-identity-equal-no-server
  66         (riece-identity-prefix ident1)
  67         (riece-identity-prefix ident2))
  68        (equal
  69         (riece-identity-server ident1)
  70         (riece-identity-server ident2))))
  71
  72 (defun riece-identity-canonicalize-prefix (prefix)
  73   "Canonicalize identity PREFIX."
  74   (let ((i 0)
  75         c)
  76     (setq prefix (downcase prefix))
  77     (while (< i (length prefix))
  78       (if (setq c (cdr (assq (aref prefix i)
  79                              riece-identity-prefix-case-pair-alist)))
  80           (aset prefix i c))
  81       (setq i (1+ i)))
  82     prefix))
  83
  84 (defun riece-identity-equal-no-server (prefix1 prefix2)
  85   "Return t, if IDENT1 and IDENT2 are equal without server part."
  86   (equal (riece-identity-canonicalize-prefix prefix1)
  87          (riece-identity-canonicalize-prefix prefix2)))
  88
  89 (defun riece-identity-member (elt list &optional no-server)
  90   "Return non-nil if an identity ELT is an element of LIST."
  91   (catch 'found
  92     (while list
  93       (if (and (car list)       ;needed because riece-current-channels
  94                                 ;contains nil.
  95                (if no-server
  96                    (riece-identity-equal-no-server (car list) elt)
  97                  (riece-identity-equal (car list) elt)))
  98           (throw 'found list)
  99         (setq list (cdr list))))))
 100
 101 (defun riece-identity-assoc (elt alist &optional no-server)
 102   "Return non-nil if an identity ELT matches the car of an element of ALIST."
 103   (catch 'found
 104     (while alist
 105       (if (if no-server
 106               (riece-identity-equal-no-server (car (car alist)) elt)
 107             (riece-identity-equal (car (car alist)) elt))
 108           (throw 'found (car alist))
 109         (setq alist (cdr alist))))))
 110
 111 (defun riece-identity-assign-binding (item list binding)
 112   (let ((slot (riece-identity-member item binding))
 113         pointer)
 114     (unless list                        ;we need at least one room
 115       (setq list (list nil)))
 116     (setq pointer list)
 117     (if slot
 118         (while (not (eq binding slot))
 119           (unless (cdr pointer)
 120             (setcdr pointer (list nil)))
 121           (setq pointer (cdr pointer)
 122                 binding (cdr binding)))
 123       (while (or (car pointer) (car binding))
 124         (unless (cdr pointer)
 125           (setcdr pointer (list nil)))
 126         (setq pointer (cdr pointer)
 127               binding (cdr binding))))
 128     (setcar pointer item)
 129     list))
 130
 131 (defun riece-format-identity (identity &optional prefix-only)
 132   "Convert IDENTITY object to a string.
 133 If the optional 2nd argument PREFIX-ONLY is non-nil, don't append
 134 server part of the identity.
 135
 136 The returned string will be abbreviated by
 137 `riece-abbrev-identity-string-function', and `riece-identity' property
 138 will be added."
 139   (let ((string
 140          (if (or prefix-only
 141                  (equal (riece-identity-server identity) ""))
 142              (copy-sequence (riece-identity-prefix identity))
 143            (concat (riece-identity-prefix identity) " "
 144                    (riece-identity-server identity)))))
 145     (if riece-abbrev-identity-string-function
 146         (setq string (funcall riece-abbrev-identity-string-function string)))
 147     (riece-put-text-property-nonsticky 0 (length string)
 148                                        'riece-identity identity
 149                                        string)
 150     (if prefix-only
 151         (riece-put-text-property-nonsticky 0 (length string)
 152                                            'riece-format-identity-prefix-only t
 153                                            string))
 154     string))
 155
 156 (defun riece-parse-identity (string)
 157   "Convert STRING to an identity object.
 158 The string will be expanded by
 159 `riece-expand-identity-string-function'."
 160   (if riece-expand-identity-string-function
 161       (setq string (funcall riece-expand-identity-string-function string)))
 162   (riece-make-identity (if (string-match " " string)
 163                            (substring string 0 (match-beginning 0))
 164                          string)
 165                        (if (string-match " " string)
 166                            (substring string (match-end 0))
 167                          "")))
 168
 169 (defun riece-completing-read-identity (prompt channels
 170                                               &optional predicate require-match
 171                                               initial history default
 172                                               no-server)
 173   "Read an identity object in the minibuffer, with completion.
 174 PROMPT is a string to prompt with; normally it ends in a colon and a space.
 175 CHANNELS is a list of identity objects.
 176 The rest of arguments are the same as `completing-read'."
 177   (let* ((string
 178           (completing-read
 179            prompt
 180            (mapcar (lambda (channel)
 181                      (list (riece-format-identity channel no-server)))
 182                    (delq nil (copy-sequence (or channels
 183                                                 riece-current-channels))))
 184            predicate require-match initial history default))
 185          (identity
 186           (riece-parse-identity string)))
 187 ;;;    (unless (string-match (concat "^\\(" riece-channel-regexp "\\|"
 188 ;;;                               riece-user-regexp "\\)")
 189 ;;;                       (riece-identity-prefix identity))
 190 ;;;      (error "Invalid channel name!"))
 191     identity))
 192
 193 (defun riece-coding-system-for-identity (identity)
 194   (let ((alist riece-channel-coding-system-alist)
 195         matcher)
 196     (catch 'found
 197       (while alist
 198         (setq matcher (riece-parse-identity (car (car alist))))
 199         (if (and (equal (riece-identity-server matcher)
 200                         (riece-identity-server identity))
 201                  (equal (riece-identity-prefix matcher)
 202                         (riece-identity-prefix identity)))
 203             (throw 'found (cdr (car alist))))
 204         (setq alist (cdr alist))))))
 205
 206 (defun riece-decoded-string-for-identity (decoded identity)
 207   "Return the string decoded for IDENTITY."
 208   (let ((coding-system (riece-coding-system-for-identity identity)))
 209     (if (and coding-system
 210              (not (eq (riece-decoded-coding-system decoded)
 211                       (if (consp coding-system)
 212                           (car coding-system)
 213                         coding-system))))
 214         (riece-decode-coding-string-1 (riece-decoded-encoded-string decoded)
 215                                       coding-system)
 216       decoded)))
 217
 218 (defun riece-encode-coding-string-for-identity (string identity)
 219   (let ((coding-system (riece-coding-system-for-identity identity)))
 220     (if coding-system
 221         (encode-coding-string string
 222                               (if (consp coding-system)
 223                                   (cdr coding-system)
 224                                 coding-system))
 225       (riece-encode-coding-string string))))
 226
 227 (provide 'riece-identity)
 228
 229 ;;; riece-identity.el ends here