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