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