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)
33 (require 'liece-vars))
35 (eval-when-compile (ignore-errors (require 'image)))
40 (autoload 'bitmap-stipple-xbm-file-to-stipple "bitmap-stipple")
41 (autoload 'bitmap-stipple-insert-pixmap "bitmap-stipple"))
43 ;;; @ widget emulation
45 (defvar liece-widget-keymap nil)
47 (unless liece-widget-keymap
48 (setq liece-widget-keymap (copy-keymap widget-keymap))
49 (substitute-key-definition
50 'widget-button-click 'liece-widget-button-click
52 (define-key liece-widget-keymap [mouse-3]
53 'liece-widget-button-click))
55 (defun liece-emacs-widget-convert-button (type from to &rest args)
56 (apply 'widget-convert-button type from to args)
57 (let ((map (copy-keymap liece-widget-keymap)))
58 (set-keymap-parent map (current-local-map))
59 (overlay-put (make-overlay from to) 'local-map map)))
61 (defun liece-emacs-widget-button-click (event)
63 (let* ((window (posn-window (event-start event)))
64 (point (window-point window))
65 (buffer (window-buffer window)))
66 (with-current-buffer buffer
69 (goto-char (widget-event-point event))
72 ((> (point) (save-excursion
76 ((< (point) (save-excursion
80 (call-interactively (function widget-button-click)))
81 (if (windowp (setq window (get-buffer-window buffer)))
82 (set-window-point window point))))))
84 (fset 'liece-widget-convert-button
85 'liece-emacs-widget-convert-button)
86 (fset 'liece-widget-button-click
87 'liece-emacs-widget-button-click)
91 (defvar liece-splash-image
93 (let ((file (expand-file-name "liece.xpm" default-directory)))
94 (if (file-exists-p file)
96 (insert-file-contents-as-binary file)
99 (defun liece-emacs-splash-with-image ()
100 (or (eq (car-safe liece-splash-image) 'image)
101 (setq liece-splash-image
102 (create-image liece-splash-image 'xpm 'data)))
103 (setq cursor-type nil)
104 (when liece-splash-image
105 (let ((image-size (image-size liece-splash-image)))
106 (insert (make-string (max 0 (/ (- (window-height)
107 (floor (cdr image-size)))
110 (make-string (max 0 (/ (- (window-width)
111 (floor (car image-size)))
114 (insert-image liece-splash-image))))
116 (defun liece-emacs-splash-with-stipple ()
117 (bitmap-stipple-insert-pixmap
119 (let ((file (expand-file-name "liece.xbm" default-directory)))
120 (if (file-exists-p file)
121 (bitmap-stipple-xbm-file-to-stipple file))))
124 (defvar liece-splash-buffer nil)
126 (defvar liece-emacs-splash-function nil)
128 (defun liece-emacs-splash (&optional arg)
130 (unless (and liece-splash-buffer (buffer-live-p liece-splash-buffer))
131 (let ((liece-insert-environment-version nil))
133 (setq liece-splash-buffer (generate-new-buffer
134 (concat (if arg "*" " *")
135 (liece-version) "*")))
136 (push liece-splash-buffer liece-buffer-list)
137 (set-buffer liece-splash-buffer)
139 (funcall liece-emacs-splash-function)
140 (insert-char ?\ (max 0 (/ (- (window-width)
141 (length (liece-version)))
143 (put-text-property (point) (prog2 (insert (liece-version))(point)
147 (switch-to-buffer liece-splash-buffer)
148 (save-window-excursion
149 (switch-to-buffer liece-splash-buffer)
152 ;;; @ modeline decoration
154 (defvar liece-mode-line-image nil)
156 (defun liece-emacs-create-mode-line-image ()
157 (let ((file (liece-locate-icon-file "liece-pointer.xpm")))
158 (if (file-exists-p file)
159 (create-image file nil nil :ascent 99))))
161 (defun liece-emacs-mode-line-buffer-identification (line)
162 (let ((id (copy-sequence (car line))) image)
163 (or liece-mode-line-image
164 (setq liece-mode-line-image (liece-emacs-create-mode-line-image)))
165 (when (and liece-mode-line-image
166 (stringp id) (string-match "^Liece:" id))
167 (add-text-properties 0 (length id)
169 liece-mode-line-image
170 'rear-nonsticky (list 'display))
175 ;;; @ nick buffer decoration
177 (defun liece-emacs-create-nick-image (file)
178 (let ((file (liece-locate-icon-file file)))
179 (if (file-exists-p file)
180 (create-image file nil nil :ascent 99))))
182 (defun liece-emacs-nick-image-region (start end)
189 (beginning-of-line 2)
193 (narrow-to-region start end)
194 (let ((buffer-read-only nil)
195 (inhibit-read-only t)
196 (case-fold-search nil)
198 (dolist (entry liece-nick-image-alist)
199 (setq mark (car entry)
203 (setcdr entry (liece-emacs-create-nick-image image))))
206 (when (eq (char-after) mark)
207 (add-text-properties (point) (1+ (point))
210 'rear-nonsticky (list 'display))))
211 (beginning-of-line 2)))))))
215 (defun liece-emacs-unread-mark (chnl)
216 (if liece-display-unread-mark
217 (with-current-buffer liece-channel-list-buffer
218 (let ((buffer-read-only nil))
219 (goto-char (point-min))
220 (when (re-search-forward (concat "^ ?[0-9]+: " chnl "$") nil t)
221 (goto-char (match-end 0))
222 (insert (concat " " liece-channel-unread-character)))))))
224 (defun liece-emacs-read-mark (chnl)
225 (if liece-display-unread-mark
226 (with-current-buffer liece-channel-list-buffer
227 (let ((buffer-read-only nil))
228 (goto-char (point-min))
229 (when (re-search-forward
230 (concat "^ ?[0-9]+: " chnl " "
231 liece-channel-unread-character "$") nil t)
232 (goto-char (- (match-end 0) 2))
235 (defun liece-emacs-redisplay-unread-mark ()
236 (if liece-display-unread-mark
237 (dolist (chnl liece-channel-unread-list)
238 (liece-emacs-unread-mark chnl))))
240 (if (and (fboundp 'image-type-available-p)
241 (and (display-color-p)
242 (image-type-available-p 'xpm)))
244 (fset 'liece-mode-line-buffer-identification
245 'liece-emacs-mode-line-buffer-identification)
246 (setq liece-emacs-splash-function #'liece-emacs-splash-with-image)
247 (add-hook 'liece-nick-insert-hook 'liece-emacs-nick-image-region)
248 (add-hook 'liece-nick-replace-hook 'liece-emacs-nick-image-region))
249 (fset 'liece-mode-line-buffer-identification 'identity)
250 (setq liece-emacs-splash-function #'liece-emacs-splash-with-stipple))
252 (when (and (not liece-inhibit-startup-message) window-system)
253 (liece-emacs-splash))
255 (fset 'liece-redisplay-unread-mark 'liece-emacs-redisplay-unread-mark)
256 (add-hook 'liece-channel-unread-functions 'liece-emacs-unread-mark)
257 (add-hook 'liece-channel-read-functions 'liece-emacs-read-mark)
259 (provide 'liece-emacs)
261 ;;; liece-emacs.el ends here