675bfeb8f1881abcd82842c6ebc72fd4730ff940
[elisp/liece.git] / lisp / liece-emacs.el
1 ;;; liece-emacs.el --- FSF Emacs specific routines.
2 ;; Copyright (C) 1999 Daiki Ueno
3
4 ;; Author: Daiki Ueno <ueno@unixuser.org>
5 ;; Created: 1999-08-21
6 ;; Keywords: emulation
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
32   (require 'static)
33   (require 'liece-compat)
34   (require 'liece-vars))
35
36 (eval-when-compile (ignore-errors (require 'image)))
37
38 (require 'derived)
39
40 (eval-and-compile
41   (autoload 'bitmap-stipple-xbm-file-to-stipple "bitmap-stipple")
42   (autoload 'bitmap-stipple-insert-pixmap "bitmap-stipple"))
43
44 ;;; @ widget emulation
45 ;;; 
46 (defvar liece-widget-keymap nil)
47
48 (unless liece-widget-keymap
49   (require 'wid-edit)
50   (setq liece-widget-keymap (copy-keymap widget-keymap))
51   (substitute-key-definition
52    'widget-button-click 'liece-widget-button-click
53    liece-widget-keymap)
54   (define-key liece-widget-keymap [mouse-3]
55     'liece-widget-button-click))
56
57 (defun liece-emacs-widget-convert-button (type from to &rest args)
58   (apply 'widget-convert-button type from to args)
59   (let ((map (copy-keymap liece-widget-keymap)))
60     (set-keymap-parent map (current-local-map))
61     (overlay-put (make-overlay from to) 'local-map map)))
62
63 (defun liece-emacs-widget-button-click (event)
64   (interactive "e")
65   (let* ((window (posn-window (event-start event)))
66          (point (window-point window))
67          (buffer (window-buffer window)))
68     (with-current-buffer buffer
69       (unwind-protect
70           (progn
71             (goto-char (widget-event-point event))
72             (cond
73              ((widget-at (point)))
74              ((> (point) (save-excursion
75                            (widget-forward 0)
76                            (point)))
77               (widget-backward 0))
78              ((< (point) (save-excursion
79                            (widget-backward 0)
80                            (point)))
81               (widget-forward 0)))
82             (call-interactively (function widget-button-click)))
83         (if (windowp (setq window (get-buffer-window buffer)))
84             (set-window-point window point))))))
85
86 (fset 'liece-widget-convert-button
87       'liece-emacs-widget-convert-button)
88 (fset 'liece-widget-button-click
89       'liece-emacs-widget-button-click)
90
91 ;;; @ startup splash
92 ;;; 
93 (defconst liece-splash-image
94   (eval-when-compile
95     (cond
96      ((and (fboundp 'image-type-available-p)
97            (image-type-available-p 'xpm))
98       (let ((file (expand-file-name "liece.xpm" default-directory)))
99         (if (file-exists-p file)
100             (list 'image
101                   :type 'xpm
102                   :data (with-temp-buffer
103                           (insert-file-contents-as-binary file)
104                           (buffer-string))))))
105      ((fboundp 'set-face-stipple)
106       (let ((file (expand-file-name "liece.xbm" default-directory)))
107         (if (file-exists-p file)
108             (bitmap-stipple-xbm-file-to-stipple file)))))))
109
110 (defun liece-emacs-splash (&optional arg)
111   (interactive "P")
112   (let* ((font (cdr (assq 'font (frame-parameters))))
113          (liece-insert-environment-version nil)
114          config buffer pixel-width pixel-height)
115     (unwind-protect
116         (progn
117           (setq config (current-window-configuration))
118           (save-excursion
119             (setq buffer (generate-new-buffer
120                           (concat (if arg "*" " *")
121                                   (liece-version) "*")))
122             (switch-to-buffer buffer)
123             (erase-buffer)
124             (static-cond
125              ((and (fboundp 'image-type-available-p)
126                    (image-type-available-p 'xpm))
127               (with-temp-buffer
128                 (insert (plist-get (cdr liece-splash-image) :data))
129                 (goto-char (point-min))
130                 (skip-syntax-forward "^\"")
131                 (when (looking-at "\"[ \t]*\\([0-9]+\\)[ \t]*\\([0-9]+\\)")
132                   (setq pixel-width (string-to-int (match-string 1))
133                         pixel-height (string-to-int (match-string 2)))))
134               (insert (make-string (max 0 (/ (- (frame-height)
135                                                 (/ pixel-height
136                                                    (frame-char-height)))
137                                              2))
138                                    ?\n)
139                       (make-string (max 0 (/ (- (frame-width)
140                                                 (/ pixel-width
141                                                    (frame-char-width)))
142                                              2))
143                                    ?\ ))
144               (static-if (condition-case nil
145                              (progn (insert-image '(image)) nil)
146                            (wrong-number-of-arguments t))
147                   (insert-image liece-splash-image "x")
148                 (insert-image liece-splash-image))
149               (insert "\n"))
150              (t
151               (bitmap-stipple-insert-pixmap liece-splash-image 'center)))
152             (insert "\n")
153             (insert-char ?\  (max 0 (/ (- (window-width)
154                                           (length (liece-version)))
155                                        2)))
156             (put-text-property (point) (prog2 (insert (liece-version))(point)
157                                          (insert "\n"))
158                                'face 'underline))
159           (or arg (sit-for 2)))
160       (unless arg
161         (kill-buffer buffer)
162         (set-window-configuration config)))))
163
164 ;;; @ modeline decoration
165 ;;; 
166 (defconst liece-mode-line-image nil)
167
168 (defun liece-emacs-create-mode-line-image ()
169   (static-when (fboundp 'image-type-available-p)
170     (let ((file (liece-locate-icon-file
171                  (static-cond
172                   ((image-type-available-p 'xpm)
173                    "liece-pointer.xpm")
174                   ((image-type-available-p 'xbm)
175                    "liece-pointer.xbm")))))
176       (and file (file-exists-p file)
177            (create-image file nil nil :ascent 99)))))
178
179 (defun liece-emacs-mode-line-buffer-identification (line)
180   (let ((id (copy-sequence (car line))) image)
181     (if (and (stringp id) (string-match "^Liece:" id)
182              (setq liece-mode-line-image
183                    (liece-emacs-create-mode-line-image)))
184         (progn
185           (add-text-properties 0 (length id)
186                                (list 'display
187                                      liece-mode-line-image
188                                      'rear-nonsticky (list 'display))
189                                id)
190           (setcar line id)))
191     line))
192
193 (fset 'liece-mode-line-buffer-identification
194       'liece-emacs-mode-line-buffer-identification)
195
196 ;;; @ nick buffer decoration
197 ;;; 
198 (defun liece-emacs-create-nick-image (file)
199   (static-when (and (fboundp 'image-type-available-p)
200                     (image-type-available-p 'xpm))
201     (let ((file (liece-locate-icon-file file)))
202       (and file (file-exists-p file)
203            (create-image file nil nil :ascent 99)))))
204
205 (defun liece-emacs-nick-image-region (start end)
206   (save-excursion
207     (goto-char start)
208     (beginning-of-line)
209     (setq start (point))
210
211     (goto-char end)
212     (beginning-of-line 2)
213     (setq end (point))
214     
215     (save-restriction
216       (narrow-to-region start end)
217       (let ((buffer-read-only nil)
218             (inhibit-read-only t)
219             (case-fold-search nil)
220             mark image)
221         (dolist (entry liece-nick-image-alist)
222           (setq mark (car entry)
223                 image (cdr entry))
224           (if (stringp image)
225               (setq image
226                     (setcdr entry (liece-emacs-create-nick-image image))))
227           (goto-char start)
228           (while (not (eobp))
229             (when (eq (char-after) mark)
230               (add-text-properties (point) (1+ (point))
231                                    (list 'display
232                                          image
233                                          'rear-nonsticky (list 'display))))
234             (beginning-of-line 2)))))))
235
236 ;;; @ unread mark
237 ;;; 
238 (defun liece-emacs-unread-mark (chnl)
239   (if liece-display-unread-mark
240       (with-current-buffer liece-channel-list-buffer
241         (let ((buffer-read-only nil))
242           (goto-char (point-min))
243           (when (re-search-forward (concat "^ ?[0-9]+: " chnl "$") nil t)
244             (goto-char (match-end 0))
245             (insert (concat " " liece-channel-unread-character)))))))
246
247 (defun liece-emacs-read-mark (chnl)
248   (if liece-display-unread-mark
249       (with-current-buffer liece-channel-list-buffer
250         (let ((buffer-read-only nil))
251           (goto-char (point-min))
252           (when (re-search-forward
253                  (concat "^ ?[0-9]+: " chnl " "
254                          liece-channel-unread-character "$") nil t)
255             (goto-char (- (match-end 0) 2))
256             (delete-char 2))))))
257
258 (defun liece-emacs-redisplay-unread-mark ()
259   (if liece-display-unread-mark
260       (dolist (chnl liece-channel-unread-list)
261         (liece-emacs-unread-mark chnl))))
262
263 (add-hook 'liece-nick-insert-hook 'liece-emacs-nick-image-region)
264 (add-hook 'liece-nick-replace-hook 'liece-emacs-nick-image-region)
265        
266 (and liece-splash-image window-system
267      (liece-emacs-splash))
268
269 (fset 'liece-redisplay-unread-mark 'liece-emacs-redisplay-unread-mark)
270 (add-hook 'liece-channel-unread-hook 'liece-emacs-unread-mark)
271 (add-hook 'liece-channel-read-hook 'liece-emacs-read-mark)
272
273 (provide 'liece-emacs)
274
275 ;;; liece-emacs.el ends here