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