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
  31 (defun riece-identity-prefix (identity)
  32   "Return the component sans its server from IDENTITY."
  33   (aref identity 0))
  34
  35 (defun riece-identity-server (identity)
  36   "Return the server component in IDENTITY."
  37   (aref identity 1))
  38
  39 (defun riece-make-identity (prefix server)
  40   "Make an identity object from PREFIX and SERVER."
  41   (vector prefix server))
  42
  43 (defun riece-identity-equal (ident1 ident2)
  44   "Return t, if IDENT1 and IDENT2 is equal."
  45   (and (riece-identity-equal-no-server
  46         (riece-identity-prefix ident1)
  47         (riece-identity-prefix ident2))
  48        (equal
  49         (riece-identity-server ident1)
  50         (riece-identity-server ident2))))
  51
  52 (defun riece-identity-canonicalize-prefix (prefix)
  53   "Canonicalize identity PREFIX.
  54 This function downcases PREFIX first, then does special treatment for
  55 Scandinavian alphabets.
  56
  57 RFC2812, 2.2 \"Character codes\" says:
  58    Because of IRC's Scandinavian origin, the characters {}|^ are
  59    considered to be the lower case equivalents of the characters []\~,
  60    respectively. This is a critical issue when determining the
  61    equivalence of two nicknames or channel names."
  62   (let* ((result (downcase prefix))
  63          (length (length result))
  64          (index 0))
  65     (while (< index length)
  66       (if (eq (aref result index) ?\[)
  67           (aset result index ?{)
  68         (if (eq (aref result index) ?\])
  69             (aset result index ?})
  70           (if (eq (aref result index) ?\\)
  71               (aset result index ?|)
  72             (if (eq (aref result index) ?~)
  73                 (aset result index ?^)))))
  74       (setq index (1+ index)))
  75     result))
  76
  77 (defun riece-identity-equal-no-server (prefix1 prefix2)
  78   "Return t, if IDENT1 and IDENT2 is equal without server."
  79   (equal (riece-identity-canonicalize-prefix prefix1)
  80          (riece-identity-canonicalize-prefix prefix2)))
  81
  82 (defun riece-identity-member (elt list)
  83   "Return non-nil if an identity ELT is an element of LIST."
  84   (catch 'found
  85     (while list
  86       (if (and (vectorp (car list))
  87                (riece-identity-equal (car list) elt))
  88           (throw 'found list)
  89         (setq list (cdr list))))))
  90
  91 (defun riece-identity-member-no-server (elt list)
  92   "Return non-nil if an identity ELT is an element of LIST.
  93 The only difference with `riece-identity-member', this function doesn't
  94 take server names into account."
  95   (catch 'found
  96     (while list
  97       (if (and (vectorp (car list))
  98                (riece-identity-equal-no-server (car list) elt))
  99           (throw 'found list)
 100         (setq list (cdr list))))))
 101
 102 (defun riece-identity-assoc (elt alist)
 103   "Return non-nil if an identity ELT matches the car of an element of ALIST."
 104   (catch 'found
 105     (while alist
 106       (if (riece-identity-equal (car (car alist)) elt)
 107           (throw 'found (car alist))
 108         (setq alist (cdr alist))))))
 109
 110 (defun riece-identity-assign-binding (item list binding)
 111   (let ((slot (riece-identity-member item binding))
 112         pointer)
 113     (unless list                        ;we need at least one room
 114       (setq list (list nil)))
 115     (setq pointer list)
 116     (if slot
 117         (while (not (eq binding slot))
 118           (unless (cdr pointer)
 119             (setcdr pointer (list nil)))
 120           (setq pointer (cdr pointer)
 121                 binding (cdr binding)))
 122       (while (or (car pointer) (car binding))
 123         (unless (cdr pointer)
 124           (setcdr pointer (list nil)))
 125         (setq pointer (cdr pointer)
 126               binding (cdr binding))))
 127     (setcar pointer item)
 128     list))
 129
 130 (defmacro riece-with-identity-buffer (identity &rest body)
 131   `(let ((process (riece-server-process (riece-identity-server ,identity))))
 132      (if process
 133          (with-current-buffer (process-buffer process)
 134            ,@body)
 135        (error "Server closed."))))
 136
 137 (put 'riece-with-identity-buffer 'lisp-indent-function 1)
 138
 139 (defun riece-decode-identity (identity &optional prefix-only)
 140   (riece-with-identity-buffer identity
 141     (let ((prefix (riece-decode-coding-string
 142                    (riece-identity-prefix identity)))
 143           (server (riece-identity-server identity)))
 144       (if (or prefix-only (equal server ""))
 145           prefix
 146         (concat prefix " " server)))))
 147
 148 (defun riece-encode-identity (string)
 149   (let ((prefix (if (string-match " " string)
 150                     (substring string 0 (match-beginning 0))
 151                   string))
 152         (server (if (string-match " " string)
 153                     (substring string (match-end 0))
 154                   "")))
 155     (riece-with-server-buffer server
 156       (riece-make-identity (riece-encode-coding-string prefix) server))))
 157
 158 (defun riece-completing-read-identity (prompt table
 159                                               &optional predicate must-match)
 160   (let* ((decoded
 161           (completing-read
 162            prompt
 163            (mapcar (lambda (channel)
 164                      (list (riece-decode-identity channel)))
 165                    table)
 166            predicate must-match))
 167          (encoded
 168           (riece-encode-identity decoded)))
 169     (if (and (not (string-match "[ ,]" decoded))
 170              (string-match "[ ,]" (riece-identity-prefix encoded))
 171              (not (y-or-n-p (format "The encoded channel name contains illegal character \"%s\".  continue? "
 172                                     (match-string 0 (riece-identity-prefix encoded))))))
 173         (error "Invalid channel name!"))
 174     encoded))
 175
 176 (provide 'riece-identity)
 177
 178 ;;; riece-identity.el ends here