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-blackets
  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   "Blackets."
  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 (defvar liece-message-encrypted-p nil)
  76 (defvar liece-message-suspicious-p nil)
  77 (defvar liece-message-garbled-p nil)
  78 (defvar liece-message-fingerprint nil)
  79 (defvar liece-message-timestamp nil)
  80
  81 (defun liece-message-predicate (val)
  82   (cond
  83    ((null val)
  84     nil)
  85    ((eq val t)
  86     t)
  87    ((listp val)
  88     (let ((pred (pop val)))
  89       (cond
  90        ((eq pred 'or)
  91         (apply 'liece-or (mapcar 'liece-message-predicate val)))
  92        ((eq pred 'and)
  93         (apply 'liece-and (mapcar 'liece-message-predicate val)))
  94        ((eq pred 'not)
  95         (not (liece-message-predicate (car val))))
  96        ((eq pred 'type)
  97         (eq liece-message-type (car val)))
  98        ((eq pred 'direction)
  99         (cond
 100          ((eq (car val) 'outgoing)
 101           liece-message-direction)
 102          ((eq (car val) 'incoming)
 103           (not liece-message-direction))))
 104        ((eq pred 'mode)
 105         (eq liece-command-buffer-mode (car val)))
 106        ((eq pred 'range)
 107         (cond
 108          ((eq (car val) 'private)
 109           (not (liece-channel-p (liece-channel-real liece-message-target))))
 110          ((eq (car val) 'external)
 111           (not (liece-channel-member
 112                 liece-message-target (liece-nick-get-joined-channels
 113                                        liece-message-speaker))))))
 114        ((liece-functionp pred)
 115         (liece-eval-form (cons pred val)))
 116        (t
 117         (liece-message-predicate pred)))))
 118    (t
 119     (liece-eval-form val))))
 120
 121 (defun liece-message-blackets-function ()
 122   (let* ((specs liece-message-blackets) spec
 123          (blackets
 124           (catch 'found
 125             (while specs
 126               (setq spec (pop specs))
 127               (if (liece-message-predicate (car spec))
 128                   (throw 'found (cadr spec)))))))
 129     ;; if message is encrypted just concatenate each blacket, two times.
 130     (if liece-message-encrypted-p
 131         (setq blackets (mapcar (function (lambda (b) (concat b b)))
 132                                blackets)))
 133     blackets))
 134
 135 (defun liece-message-tags-function ()
 136   (let* ((specs liece-message-tags) spec
 137          (tags
 138           (catch 'found
 139             (while specs
 140               (setq spec (pop specs))
 141               (if (liece-message-predicate (car spec))
 142                   (throw 'found (cadr spec)))))))
 143     (list (eval (car tags)) (eval (cadr tags)))))
 144
 145 (defun liece-message-buffer-function ()
 146   (let* ((target (if (liece-message-predicate
 147                       '(and (range private) (direction incoming)))
 148                      liece-message-speaker
 149                    liece-message-target))
 150          (buffer (liece-pick-buffer target)))
 151     (cond
 152      ((car buffer) buffer)
 153      (liece-auto-join-partner
 154       (liece-channel-prepare-partner target)
 155       (liece-pick-buffer target)))))
 156
 157 (defun liece-message-parent-buffer (cbuffer)
 158   (if (or (and (car cbuffer) (liece-frozen (car cbuffer)))
 159           (and (eq liece-command-buffer-mode 'channel)
 160                liece-current-channel
 161                (not (liece-channel-equal liece-message-target
 162                                          liece-current-channel)))
 163           (and (eq liece-command-buffer-mode 'chat)
 164                liece-current-chat-partner
 165                (not (eq liece-message-direction 'outgoing))
 166                (or
 167                 (not (liece-nick-equal liece-message-speaker
 168                                        liece-current-chat-partner))
 169                 (not (liece-nick-equal liece-message-target
 170                                        (liece-current-nickname))))))
 171       (append liece-D-buffer liece-O-buffer)
 172     liece-D-buffer))
 173
 174 ;;;###liece-autoload
 175 (defun liece-display-message (temp)
 176   (let* ((blackets (liece-message-blackets-function))
 177          (tags (liece-message-tags-function))
 178          (buffer (liece-message-buffer-function))
 179          (parent (liece-message-parent-buffer buffer)))
 180     (liece-insert buffer
 181                    (concat (car blackets) (car tags) (cadr blackets)
 182                            " " temp "\n"))
 183     (liece-insert parent
 184                    (concat (car blackets) (cadr tags) (cadr blackets)
 185                            " " temp "\n"))
 186     (run-hook-with-args 'liece-display-message-hook temp)))
 187
 188 (provide 'liece-message)
 189
 190 ;;; liece-message.el ends here