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., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Code:
  26
  27 (require 'riece-globals)
  28 (require 'riece-coding)
  29 (require 'riece-compat)                 ;riece-set-case-syntax-pair
  30
  31 (defvar riece-abbrev-identity-string-function nil)
  32 (defvar riece-expand-identity-string-function nil)
  33
  34 (defvar riece-identity-prefix-case-table
  35   (let ((table (riece-copy-case-table (standard-case-table))))
  36     (riece-set-case-syntax-pair ?\[ ?{ table)
  37     (riece-set-case-syntax-pair ?\] ?} table)
  38     (riece-set-case-syntax-pair ?\\ ?| table)
  39     (riece-set-case-syntax-pair ?~ ?^ table)
  40     table))
  41
  42 (defun riece-identity-prefix (identity)
  43   "Return the component sans its server from IDENTITY."
  44   (aref identity 0))
  45
  46 (defun riece-identity-server (identity)
  47   "Return the server component in IDENTITY."
  48   (aref identity 1))
  49
  50 (defun riece-make-identity (prefix server)
  51   "Make an identity object from PREFIX and SERVER."
  52   (vector prefix server))
  53
  54 (defun riece-identity-equal (ident1 ident2)
  55   "Return t, if IDENT1 and IDENT2 is equal."
  56   (and (riece-identity-equal-no-server
  57         (riece-identity-prefix ident1)
  58         (riece-identity-prefix ident2))
  59        (equal
  60         (riece-identity-server ident1)
  61         (riece-identity-server ident2))))
  62
  63 (defun riece-identity-canonicalize-prefix (prefix)
  64   "Canonicalize identity PREFIX.
  65 This function downcases PREFIX with Scandinavian alphabet rule.
  66
  67 RFC2812, 2.2 \"Character codes\" says:
  68    Because of IRC's Scandinavian origin, the characters {}|^ are
  69    considered to be the lower case equivalents of the characters []\~,
  70    respectively. This is a critical issue when determining the
  71    equivalence of two nicknames or channel names."
  72   (let ((old-table (current-case-table)))
  73     (unwind-protect
  74         (progn
  75           (set-case-table riece-identity-prefix-case-table)
  76           (downcase prefix))
  77       (set-case-table old-table))))
  78
  79 (defun riece-identity-equal-no-server (prefix1 prefix2)
  80   "Return t, if IDENT1 and IDENT2 is equal without server part."
  81   (equal (riece-identity-canonicalize-prefix prefix1)
  82          (riece-identity-canonicalize-prefix prefix2)))
  83
  84 (defun riece-identity-member (elt list &optional no-server)
  85   "Return non-nil if an identity ELT is an element of LIST."
  86   (catch 'found
  87     (while list
  88       (if (and (car list)       ;needed because riece-current-channels
  89                                 ;contains nil.
  90                (if no-server
  91                    (riece-identity-equal-no-server (car list) elt)
  92                  (riece-identity-equal (car list) elt)))
  93           (throw 'found list)
  94         (setq list (cdr list))))))
  95
  96 (defun riece-identity-assoc (elt alist &optional no-server)
  97   "Return non-nil if an identity ELT matches the car of an element of ALIST."
  98   (catch 'found
  99     (while alist
 100       (if (if no-server
 101               (riece-identity-equal-no-server (car (car alist)) elt)
 102             (riece-identity-equal (car (car alist)) elt))
 103           (throw 'found (car alist))
 104         (setq alist (cdr alist))))))
 105
 106 (defun riece-identity-assign-binding (item list binding)
 107   (let ((slot (riece-identity-member item binding))
 108         pointer)
 109     (unless list                        ;we need at least one room
 110       (setq list (list nil)))
 111     (setq pointer list)
 112     (if slot
 113         (while (not (eq binding slot))
 114           (unless (cdr pointer)
 115             (setcdr pointer (list nil)))
 116           (setq pointer (cdr pointer)
 117                 binding (cdr binding)))
 118       (while (or (car pointer) (car binding))
 119         (unless (cdr pointer)
 120           (setcdr pointer (list nil)))
 121         (setq pointer (cdr pointer)
 122               binding (cdr binding))))
 123     (setcar pointer item)
 124     list))
 125
 126 (defun riece-format-identity (identity &optional prefix-only)
 127   "Convert IDENTITY object to a string.
 128 If the optional 2nd argument PREFIX-ONLY is non-nil, don't append
 129 server part of the identity.
 130
 131 The returned string will be abbreviated by
 132 `riece-abbrev-identity-string-function', and `riece-identity' property
 133 will be added."
 134   (let ((string
 135          (if (or prefix-only
 136                  (equal (riece-identity-server identity) ""))
 137              (copy-sequence (riece-identity-prefix identity))
 138            (concat (riece-identity-prefix identity) " "
 139                    (riece-identity-server identity)))))
 140     (if riece-abbrev-identity-string-function
 141         (setq string (funcall riece-abbrev-identity-string-function string)))
 142     (put-text-property 0 (length string) 'riece-identity identity string)
 143     string))
 144
 145 (defun riece-parse-identity (string)
 146   "Convert STRING to an identity object.
 147 The string will be expanded by
 148 `riece-expand-identity-string-function'."
 149   (if riece-expand-identity-string-function
 150       (setq string (funcall riece-expand-identity-string-function string)))
 151   (riece-make-identity (if (string-match " " string)
 152                            (substring string 0 (match-beginning 0))
 153                          string)
 154                        (if (string-match " " string)
 155                            (substring string (match-end 0))
 156                          "")))
 157
 158 (defun riece-completing-read-identity (prompt channels
 159                                               &optional predicate require-match
 160                                               initial history default)
 161   "Read an identity object in the minibuffer, with completion.
 162 PROMPT is a string to prompt with; normally it ends in a colon and a space.
 163 CHANNELS is a list of identity objects.
 164 The rest of arguments are the same as `completing-read'."
 165   (let* ((string
 166           (completing-read
 167            prompt
 168            (mapcar (lambda (channel)
 169                      (list (riece-format-identity channel)))
 170                    (delq nil (copy-sequence (or channels
 171                                                 riece-current-channels))))
 172            predicate require-match initial history default))
 173          (identity
 174           (riece-parse-identity string)))
 175     (unless (string-match (concat "^\\(" riece-channel-regexp "\\|"
 176                                   riece-user-regexp "\\)")
 177                           (riece-identity-prefix identity))
 178       (error "Invalid channel name!"))
 179     identity))
 180
 181 (provide 'riece-identity)
 182
 183 ;;; riece-identity.el ends here