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.
33 (require 'liece-compat)
34 (require 'liece-vars))
36 (eval-when-compile (ignore-errors (require 'image)))
41 (autoload 'bitmap-stipple-xbm-file-to-stipple "bitmap-stipple")
42 (autoload 'bitmap-stipple-insert-pixmap "bitmap-stipple"))
44 ;;; @ widget emulation
46 (defvar liece-widget-keymap nil)
48 (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 (defconst liece-splash-image
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)
102 :data (with-temp-buffer
103 (insert-file-contents-as-binary file)
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)))))))
110 (defun liece-emacs-splash (&optional arg)
112 (let* ((font (cdr (assq 'font (frame-parameters))))
113 (liece-insert-environment-version nil)
114 config buffer pixel-width pixel-height)
117 (setq config (current-window-configuration))
119 (setq buffer (generate-new-buffer
120 (concat (if arg "*" " *")
121 (liece-version) "*")))
122 (switch-to-buffer buffer)
125 ((and (fboundp 'image-type-available-p)
126 (image-type-available-p 'xpm))
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)
136 (frame-char-height)))
139 (make-string (max 0 (/ (- (frame-width)
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))
151 (bitmap-stipple-insert-pixmap liece-splash-image 'center)))
153 (insert-char ?\ (max 0 (/ (- (window-width)
154 (length (liece-version)))
156 (put-text-property (point) (prog2 (insert (liece-version))(point)
159 (or arg (sit-for 2)))
162 (set-window-configuration config)))))
164 ;;; @ modeline decoration
166 (defconst liece-mode-line-image nil)
168 (defun liece-emacs-create-mode-line-image ()
169 (static-when (fboundp 'image-type-available-p)
170 (let ((file (liece-locate-icon-file
172 ((image-type-available-p '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)))))
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)))
185 (add-text-properties 0 (length id)
187 liece-mode-line-image
188 'rear-nonsticky (list 'display))
193 (fset 'liece-mode-line-buffer-identification
194 'liece-emacs-mode-line-buffer-identification)
196 ;;; @ nick buffer decoration
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)))))
205 (defun liece-emacs-nick-image-region (start end)
212 (beginning-of-line 2)
216 (narrow-to-region start end)
217 (let ((buffer-read-only nil)
218 (inhibit-read-only t)
219 (case-fold-search nil)
221 (dolist (entry liece-nick-image-alist)
222 (setq mark (car entry)
226 (setcdr entry (liece-emacs-create-nick-image image))))
229 (when (eq (char-after) mark)
230 (add-text-properties (point) (1+ (point))
233 'rear-nonsticky (list 'display))))
234 (beginning-of-line 2)))))))
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)))))))
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))
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))))
263 (add-hook 'liece-nick-insert-hook 'liece-emacs-nick-image-region)
264 (add-hook 'liece-nick-replace-hook 'liece-emacs-nick-image-region)
266 (and liece-splash-image window-system
267 (liece-emacs-splash))
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)
273 (provide 'liece-emacs)
275 ;;; liece-emacs.el ends here