1 ;;; liece-emacs.el --- FSF Emacs specific routines.
2 ;; Copyright (C) 1999 Daiki Ueno
4 ;; Author: Daiki Ueno <ueno@unixuser.org>
8 ;; This file is part of Liece.
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)
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.
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.
32 (require 'liece-compat)
34 (require 'liece-misc))
36 (eval-when-compile (require 'cl))
37 (eval-when-compile (ignore-errors (require 'image)))
42 (autoload 'bitmap-stipple-xbm-file-to-stipple "bitmap-stipple")
43 (autoload 'bitmap-stipple-insert-pixmap "bitmap-stipple"))
45 ;;; @ widget emulation
47 (defvar liece-widget-keymap nil)
49 (unless liece-widget-keymap
50 (setq liece-widget-keymap (copy-keymap widget-keymap))
51 (substitute-key-definition
52 'widget-button-click 'liece-widget-button-click
54 (define-key liece-widget-keymap [mouse-3]
55 'liece-widget-button-click))
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)))
63 (defun liece-emacs-widget-button-click (event)
65 (let* ((window (posn-window (event-start event)))
66 (point (window-point window))
67 (buffer (window-buffer window)))
68 (with-current-buffer buffer
71 (goto-char (widget-event-point event))
74 ((> (point) (save-excursion
78 ((< (point) (save-excursion
82 (call-interactively (function widget-button-click)))
83 (if (windowp (setq window (get-buffer-window buffer)))
84 (set-window-point window point))))))
86 (fset 'liece-widget-convert-button
87 'liece-emacs-widget-convert-button)
88 (fset 'liece-widget-button-click
89 'liece-emacs-widget-button-click)
93 (defvar liece-splash-image
95 (let ((file (expand-file-name "liece.xpm" default-directory)))
96 (if (file-exists-p file)
98 (insert-file-contents file)
101 (defun liece-emacs-splash-with-image ()
102 (or (eq (car-safe liece-splash-image) 'image)
103 (setq liece-splash-image
104 (create-image liece-splash-image 'xpm 'data)))
105 (setq cursor-type nil)
106 (when liece-splash-image
107 (let ((image-size (image-size liece-splash-image)))
108 (insert (make-string (max 0 (/ (- (window-height)
109 (floor (cdr image-size)))
112 (make-string (max 0 (/ (- (window-width)
113 (floor (car image-size)))
116 (insert-image liece-splash-image))))
118 (defun liece-emacs-splash-with-stipple ()
119 (bitmap-stipple-insert-pixmap
121 (let ((file (expand-file-name "liece.xbm" default-directory)))
122 (if (file-exists-p file)
123 (bitmap-stipple-xbm-file-to-stipple file))))
126 (defvar liece-splash-buffer nil)
128 (defvar liece-emacs-splash-function nil)
130 (defun liece-emacs-splash (&optional arg)
132 (unless (and liece-splash-buffer (buffer-live-p liece-splash-buffer))
133 (let ((liece-insert-environment-version nil))
135 (setq liece-splash-buffer (generate-new-buffer
136 (concat (if arg "*" " *")
137 (liece-version) "*")))
138 (push liece-splash-buffer liece-buffer-list)
139 (set-buffer liece-splash-buffer)
141 (funcall liece-emacs-splash-function)
142 (insert-char ?\ (max 0 (/ (- (window-width)
143 (length (liece-version)))
145 (put-text-property (point) (prog2 (insert (liece-version))(point)
149 (switch-to-buffer liece-splash-buffer)
150 (save-window-excursion
151 (switch-to-buffer liece-splash-buffer)
154 ;;; @ modeline decoration
156 (defvar liece-mode-line-image nil)
158 (defun liece-emacs-create-mode-line-image ()
159 (let ((file (liece-locate-icon-file "liece-pointer.xpm")))
160 (if (file-exists-p file)
161 (create-image file nil nil :ascent 99))))
163 (defun liece-emacs-mode-line-buffer-identification (line)
164 (let ((id (copy-sequence (car line))) image)
165 (or liece-mode-line-image
166 (setq liece-mode-line-image (liece-emacs-create-mode-line-image)))
167 (when (and liece-mode-line-image
168 (stringp id) (string-match "^Liece:" id))
169 (add-text-properties 0 (length id)
171 liece-mode-line-image
172 'rear-nonsticky (list 'display))
177 ;;; @ nick buffer decoration
179 (defun liece-emacs-create-nick-image (file)
180 (let ((file (liece-locate-icon-file file)))
181 (if (file-exists-p file)
182 (create-image file nil nil :ascent 99))))
184 (defun liece-emacs-nick-image-region (start end)
191 (beginning-of-line 2)
195 (narrow-to-region start end)
196 (let ((buffer-read-only nil)
197 (inhibit-read-only t)
198 (case-fold-search nil)
200 (dolist (entry liece-nick-image-alist)
201 (setq mark (car entry)
205 (setcdr entry (liece-emacs-create-nick-image image))))
208 (when (eq (char-after) mark)
209 (add-text-properties (point) (1+ (point))
212 'rear-nonsticky (list 'display))))
213 (beginning-of-line 2)))))))
217 (defun liece-emacs-unread-mark (chnl)
218 (if liece-display-unread-mark
219 (with-current-buffer liece-channel-list-buffer
220 (let ((buffer-read-only nil))
221 (goto-char (point-min))
222 (when (re-search-forward (concat "^ ?[0-9]+: " chnl "$") nil t)
223 (goto-char (match-end 0))
224 (insert (concat " " liece-channel-unread-character)))))))
226 (defun liece-emacs-read-mark (chnl)
227 (if liece-display-unread-mark
228 (with-current-buffer liece-channel-list-buffer
229 (let ((buffer-read-only nil))
230 (goto-char (point-min))
231 (when (re-search-forward
232 (concat "^ ?[0-9]+: " chnl " "
233 liece-channel-unread-character "$") nil t)
234 (goto-char (- (match-end 0) 2))
237 (defun liece-emacs-redisplay-unread-mark ()
238 (if liece-display-unread-mark
239 (dolist (chnl liece-channel-unread-list)
240 (liece-emacs-unread-mark chnl))))
242 (if (and (fboundp 'image-type-available-p)
243 (and (display-color-p)
244 (image-type-available-p 'xpm)))
246 (fset 'liece-mode-line-buffer-identification
247 'liece-emacs-mode-line-buffer-identification)
248 (setq liece-emacs-splash-function #'liece-emacs-splash-with-image)
249 (add-hook 'liece-nick-insert-hook 'liece-emacs-nick-image-region)
250 (add-hook 'liece-nick-replace-hook 'liece-emacs-nick-image-region))
251 (fset 'liece-mode-line-buffer-identification 'identity)
252 (setq liece-emacs-splash-function #'liece-emacs-splash-with-stipple))
254 (when (and (not liece-inhibit-startup-message) window-system)
255 (liece-emacs-splash))
257 (fset 'liece-redisplay-unread-mark 'liece-emacs-redisplay-unread-mark)
258 (add-hook 'liece-channel-unread-functions 'liece-emacs-unread-mark)
259 (add-hook 'liece-channel-read-functions 'liece-emacs-read-mark)
261 (provide 'liece-emacs)
263 ;;; liece-emacs.el ends here