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-no-server (ident1 ident2)
  74   "Return t, if IDENT1 and IDENT2 is equal.
  75 The only difference with `riece-identity-equal', this function doesn't
  76 append server name before comparison."
  77   (and (string-equal-ignore-case
  78         (riece-identity-prefix ident1)
  79         (riece-identity-prefix ident2))
  80        (equal
  81         (riece-identity-server ident1)
  82         (riece-identity-server ident2))))
  83
  84 (defun riece-identity-equal (ident1 ident2)
  85   "Return t, if IDENT1 and IDENT2 is equal."
  86   (riece-identity-equal-no-server
  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-member-no-server (elt list)
  95   "Return non-nil if an identity ELT is an element of LIST.
  96 The only difference with `riece-identity-member', this function uses
  97 `riece-identity-equal-no-server' for comparison."
  98   (catch 'found
  99     (while list
 100       (if (and (stringp (car list))
 101                (riece-identity-equal-no-server (car list) elt))
 102           (throw 'found list)
 103         (setq list (cdr list))))))
 104
 105 (defun riece-identity-member (elt list)
 106   "Return non-nil if an identity ELT is an element of LIST."
 107   (catch 'found
 108     (while list
 109       (if (and (stringp (car list))
 110                (riece-identity-equal (car list) elt))
 111           (throw 'found list)
 112         (setq list (cdr list))))))
 113
 114 (defun riece-identity-assoc-no-server (elt alist)
 115   "Return non-nil if an identity ELT matches the car of an element of ALIST."
 116   (catch 'found
 117     (while alist
 118       (if (riece-identity-equal-no-server (car (car alist)) elt)
 119           (throw 'found (car alist))
 120         (setq alist (cdr alist))))))
 121
 122 (defun riece-identity-assoc (elt alist)
 123   "Return non-nil if an identity ELT matches the car of an element of ALIST."
 124   (catch 'found
 125     (while alist
 126       (if (riece-identity-equal (car (car alist)) elt)
 127           (throw 'found (car alist))
 128         (setq alist (cdr alist))))))
 129
 130 (defun riece-identity-assign-binding (item list binding)
 131   (let ((slot (riece-identity-member item binding))
 132         pointer)
 133     (unless list                        ;we need at least one room
 134       (setq list (list nil)))
 135     (setq pointer list)
 136     (if slot
 137         (while (not (eq binding slot))
 138           (unless (cdr pointer)
 139             (setcdr pointer (list nil)))
 140           (setq pointer (cdr pointer)
 141                 binding (cdr binding)))
 142       (while (or (car pointer) (car binding))
 143         (unless (cdr pointer)
 144           (setcdr pointer (list nil)))
 145         (setq pointer (cdr pointer)
 146               binding (cdr binding))))
 147     (setcar pointer item)
 148     list))
 149
 150 (defun riece-current-nickname ()
 151   "Return the current nickname."
 152   (riece-with-server-buffer
 153    (if riece-real-nickname
 154        (riece-make-identity riece-real-nickname))))
 155
 156 (provide 'riece-identity)
 157
 158 ;;; riece-identity.el ends here