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 (eval-when-compile (require 'riece-inlines))
  28
  29 (require 'riece-globals)
  30
  31 (defun riece-find-server-name ()
  32   (or riece-overriding-server-name
  33                                         ;already in the server buffer
  34       (if (local-variable-p 'riece-server-name (current-buffer))
  35           riece-server-name
  36         (if riece-current-channel
  37             (riece-identity-server riece-current-channel)))))
  38
  39 (defun riece-find-server-process ()
  40   (let ((server-name (riece-find-server-name)))
  41     (if server-name
  42         (cdr (assoc server-name riece-server-process-alist))
  43       riece-server-process)))
  44
  45 (defmacro riece-with-server-buffer (&rest body)
  46   `(let ((process (riece-find-server-process)))
  47      (if process
  48          (with-current-buffer (process-buffer process)
  49            ,@body)
  50        (error "Server closed."))))
  51
  52 (defun riece-identity-prefix (identity)
  53   "Return the component sans its server from IDENTITY."
  54   (if (string-match " " identity)
  55       (substring identity 0 (match-beginning 0))
  56     identity))
  57
  58 (defun riece-identity-server (identity)
  59   "Return the server component in IDENTITY."
  60   (if (string-match " " identity)
  61       (substring identity (match-end 0))))
  62
  63 (defun riece-make-identity (prefix &optional server)
  64   "Make an identity object from PREFIX and SERVER."
  65   (if (riece-identity-server prefix)
  66       prefix
  67     (unless server
  68       (setq server (riece-find-server-name)))
  69     (if server
  70         (concat prefix " " server)
  71       prefix)))
  72
  73 (defun riece-identity-equal (ident1 ident2)
  74   "Return t, if IDENT1 and IDENT2 is equal."
  75   (and (riece-identity-equal-no-server
  76         (riece-identity-prefix ident1)
  77         (riece-identity-prefix ident2))
  78        (equal
  79         (riece-identity-server ident1)
  80         (riece-identity-server ident2))))
  81
  82 (defun riece-identity-equal-safe (ident1 ident2)
  83   "Return t, if IDENT1 and IDENT2 is equal.
  84 The only difference with `riece-identity-equal', this function appends
  85 server name before comparison."
  86   (riece-identity-equal
  87    (if (riece-identity-server ident1)
  88        ident1
  89      (riece-make-identity ident1))
  90    (if (riece-identity-server  ident2)
  91        ident2
  92      (riece-make-identity ident2))))
  93
  94 (defun riece-identity-canonicalize-prefix (prefix)
  95   "Canonicalize identity PREFIX.
  96 This function downcases PREFIX first, then does special treatment for
  97 Scandinavian alphabets.
  98
  99 RFC2812, 2.2 \"Character codes\" says:
 100    Because of IRC's Scandinavian origin, the characters {}|^ are
 101    considered to be the lower case equivalents of the characters []\~,
 102    respectively. This is a critical issue when determining the
 103    equivalence of two nicknames or channel names."
 104   (let* ((result (downcase prefix))
 105          (length (length result))
 106          (index 0))
 107     (while (< index length)
 108       (if (eq (aref result index) ?\[)
 109           (aset result index ?{)
 110         (if (eq (aref result index) ?\])
 111             (aset result index ?})
 112           (if (eq (aref result index) ?\\)
 113               (aset result index ?|)
 114             (if (eq (aref result index) ?~)
 115                 (aset result index ?^)))))
 116       (setq index (1+ index)))
 117     result))
 118
 119 (defun riece-identity-equal-no-server (prefix1 prefix2)
 120   "Return t, if IDENT1 and IDENT2 is equal without server."
 121   (equal (riece-identity-canonicalize-prefix prefix1)
 122          (riece-identity-canonicalize-prefix prefix2)))
 123
 124 (defun riece-identity-equal-no-server-safe (prefix1 prefix2)
 125   "Return t, if IDENT1 and IDENT2 is equal without server.
 126 The only difference with `riece-identity-no-server', this function removes
 127 server name before comparison."
 128   (equal (riece-identity-canonicalize-prefix
 129           (riece-identity-prefix prefix1))
 130          (riece-identity-canonicalize-prefix
 131           (riece-identity-prefix prefix2))))
 132
 133 (defun riece-identity-member (elt list)
 134   "Return non-nil if an identity ELT is an element of LIST."
 135   (catch 'found
 136     (while list
 137       (if (and (stringp (car list))
 138                (riece-identity-equal (car list) elt))
 139           (throw 'found list)
 140         (setq list (cdr list))))))
 141
 142 (defun riece-identity-member-safe (elt list)
 143   "Return non-nil if an identity ELT is an element of LIST.
 144 The only difference with `riece-identity-member', this function uses
 145 `riece-identity-equal-safe' for comparison."
 146   (catch 'found
 147     (while list
 148       (if (and (stringp (car list))
 149                (riece-identity-equal-safe (car list) elt))
 150           (throw 'found list)
 151         (setq list (cdr list))))))
 152
 153 (defun riece-identity-member-no-server (elt list)
 154   "Return non-nil if an identity ELT is an element of LIST.
 155 The only difference with `riece-identity-member', this function doesn't
 156 take server names into account."
 157   (catch 'found
 158     (while list
 159       (if (and (stringp (car list))
 160                (riece-identity-equal-no-server (car list) elt))
 161           (throw 'found list)
 162         (setq list (cdr list))))))
 163
 164 (defun riece-identity-member-no-server-safe (elt list)
 165   "Return non-nil if an identity ELT is an element of LIST.
 166 The only difference with `riece-identity-member-no-server', this function uses
 167 `riece-identity-equal-no-server-safe' for comparison."
 168   (catch 'found
 169     (while list
 170       (if (and (stringp (car list))
 171                (riece-identity-equal-no-server-safe (car list) elt))
 172           (throw 'found list)
 173         (setq list (cdr list))))))
 174
 175 (defun riece-identity-assoc (elt alist)
 176   "Return non-nil if an identity ELT matches the car of an element of ALIST."
 177   (catch 'found
 178     (while alist
 179       (if (riece-identity-equal (car (car alist)) elt)
 180           (throw 'found (car alist))
 181         (setq alist (cdr alist))))))
 182
 183 (defun riece-identity-assoc-safe (elt alist)
 184   "Return non-nil if an identity ELT matches the car of an element of ALIST.
 185 The only difference with `riece-identity-assoc', this function uses
 186 `riece-identity-equal-safe' for comparison."
 187   (catch 'found
 188     (while alist
 189       (if (riece-identity-equal-safe (car (car alist)) elt)
 190           (throw 'found (car alist))
 191         (setq alist (cdr alist))))))
 192
 193 (defun riece-identity-assign-binding (item list binding)
 194   (let ((slot (riece-identity-member-safe item binding))
 195         pointer)
 196     (unless list                        ;we need at least one room
 197       (setq list (list nil)))
 198     (setq pointer list)
 199     (if slot
 200         (while (not (eq binding slot))
 201           (unless (cdr pointer)
 202             (setcdr pointer (list nil)))
 203           (setq pointer (cdr pointer)
 204                 binding (cdr binding)))
 205       (while (or (car pointer) (car binding))
 206         (unless (cdr pointer)
 207           (setcdr pointer (list nil)))
 208         (setq pointer (cdr pointer)
 209               binding (cdr binding))))
 210     (setcar pointer item)
 211     list))
 212
 213 (defun riece-current-nickname ()
 214   "Return the current nickname."
 215   (riece-with-server-buffer
 216    (if riece-real-nickname
 217        (riece-make-identity riece-real-nickname))))
 218
 219 (provide 'riece-identity)
 220
 221 ;;; riece-identity.el ends here