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