cgit.sxemacs.org Git - packages/blob - xemacs-packages/liece/lisp/liece-message.el

   1 ;;; liece-message.el --- generate and display message line
   2 ;; Copyright (C) 1999 Daiki Ueno
   3
   4 ;; Author: Daiki Ueno <ueno@unixuser.org>
   5 ;; Created: 1999-05-30
   6 ;; Keywords: message
   7
   8 ;; This file is part of Liece.
   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
  26 ;;; Commentary:
  27 ;;
  28
  29 ;;; Code:
  30
  31 (eval-when-compile (require 'liece-misc))
  32
  33 (defgroup liece-message nil
  34   "Messages"
  35   :tag "Message"
  36   :prefix "liece-"
  37   :group 'liece)
  38
  39 (defcustom liece-message-brackets
  40   '(((type notice)
  41      ("-" "-"))
  42     ((and (type action) (direction outgoing))
  43      ("]" "["))
  44     ((type action)
  45      ("[" "]"))
  46     ((and (range private) (direction incoming))
  47      ("=" "="))
  48     ((direction outgoing)
  49      (">" "<"))
  50     ((range external)
  51      ("(" ")"))
  52     (t
  53      ("<" ">")))
  54   "Brackets."
  55   :group 'liece-message)
  56
  57 (defcustom liece-message-tags
  58   '(((and (direction outgoing) (range private))
  59      (liece-message-target liece-message-target))
  60     ((range private)
  61      (liece-message-speaker liece-message-speaker))
  62     (t
  63      (liece-message-speaker
  64       (concat liece-message-target ":" liece-message-speaker))))
  65   "Primary tags."
  66   :group 'liece-message)
  67
  68 (defcustom liece-message-empty-predicate
  69   (function (lambda (message) (string-equal "" message)))
  70   "Return non-nil if message is regarded as empty string."
  71   :group 'liece-message)
  72
  73 (defvar liece-message-type nil)
  74 (defvar liece-message-target nil)
  75 (defvar liece-message-speaker nil)
  76 (defvar liece-message-direction nil)
  77
  78 (defun liece-message-predicate (val)
  79   (cond
  80    ((null val)
  81     nil)
  82    ((eq val t)
  83     t)
  84    ((listp val)
  85     (let ((pred (pop val)))
  86       (cond
  87        ((eq pred 'or)
  88         (apply 'liece-or (mapcar 'liece-message-predicate val)))
  89        ((eq pred 'and)
  90         (apply 'liece-and (mapcar 'liece-message-predicate val)))
  91        ((eq pred 'not)
  92         (not (liece-message-predicate (car val))))
  93        ((eq pred 'type)
  94         (eq liece-message-type (car val)))
  95        ((eq pred 'direction)
  96         (cond
  97          ((eq (car val) 'outgoing)
  98           liece-message-direction)
  99          ((eq (car val) 'incoming)
 100           (not liece-message-direction))))
 101        ((eq pred 'mode)
 102         (eq liece-command-buffer-mode (car val)))
 103        ((eq pred 'range)
 104         (cond
 105          ((eq (car val) 'private)
 106           (not (liece-channel-p (liece-channel-real liece-message-target))))
 107          ((eq (car val) 'external)
 108           (not (liece-channel-member
 109                 liece-message-target (liece-nick-get-joined-channels
 110                                        liece-message-speaker))))))
 111        ((liece-functionp pred)
 112         (liece-eval-form (cons pred val)))
 113        (t
 114         (liece-message-predicate pred)))))
 115    (t
 116     (liece-eval-form val))))
 117
 118 (defun liece-message-brackets-function ()
 119   (let* ((specs liece-message-brackets) spec
 120          (brackets
 121           (catch 'found
 122             (while specs
 123               (setq spec (pop specs))
 124               (if (liece-message-predicate (car spec))
 125                   (throw 'found (cadr spec)))))))
 126     brackets))
 127
 128 (defun liece-message-tags-function ()
 129   (let* ((specs liece-message-tags) spec
 130          (tags
 131           (catch 'found
 132             (while specs
 133               (setq spec (pop specs))
 134               (if (liece-message-predicate (car spec))
 135                   (throw 'found (cadr spec)))))))
 136     (list (eval (car tags)) (eval (cadr tags)))))
 137
 138 (defun liece-message-buffer-function ()
 139   (let* ((target (if (liece-message-predicate
 140                       '(and (range private) (direction incoming)))
 141                      liece-message-speaker
 142                    liece-message-target))
 143          (buffer (liece-pick-buffer target)))
 144     (cond
 145      ((car buffer) buffer)
 146      (liece-auto-join-partner
 147       (liece-channel-prepare-partner target)
 148       (liece-pick-buffer target)))))
 149
 150 (defun liece-message-parent-buffer (cbuffer)
 151   (if (or (and (car cbuffer) (liece-frozen (car cbuffer)))
 152           (and (eq liece-command-buffer-mode 'channel)
 153                liece-current-channel
 154                (not (liece-channel-equal liece-message-target
 155                                          liece-current-channel)))
 156           (and (eq liece-command-buffer-mode 'chat)
 157                liece-current-chat-partner
 158                (not (eq liece-message-direction 'outgoing))
 159                (or
 160                 (not (liece-nick-equal liece-message-speaker
 161                                        liece-current-chat-partner))
 162                 (not (liece-nick-equal liece-message-target
 163                                        (liece-current-nickname))))))
 164       (append liece-D-buffer liece-O-buffer)
 165     liece-D-buffer))
 166
 167 ;;;###liece-autoload
 168 (defun liece-display-message (temp)
 169   (let* ((brackets (liece-message-brackets-function))
 170          (tags (liece-message-tags-function))
 171          (buffer (liece-message-buffer-function))
 172          (parent (liece-message-parent-buffer buffer)))
 173     (liece-insert buffer
 174                    (concat (car brackets) (car tags) (cadr brackets)
 175                            " " temp "\n"))
 176     (liece-insert parent
 177                   (concat (car brackets) (cadr tags) (cadr brackets)
 178                           " " temp "\n"))
 179     (run-hook-with-args 'liece-display-message-hook temp)))
 180
 181 (provide 'liece-message)
 182
 183 ;;; liece-message.el ends here