New feature: toggle visibility of mime buttons.
[more-wl.git] / wl / wl-demo.el
blobc9bbfe3396fc9693a61b3654bd52f46ccc3cc507
1 ;;; wl-demo.el --- Opening demo on Wanderlust
3 ;; Copyright (C) 1998,1999,2000,2001,2002,2003,2004
4 ;; Yuuichi Teranishi <teranisi@gohome.org>
5 ;; Copyright (C) 2000,2001,2004
6 ;; Katsumi Yamaoka <yamaoka@jpl.org>
8 ;; Author: Yuuichi Teranishi <teranisi@gohome.org>
9 ;; Katsumi Yamaoka <yamaoka@jpl.org>
10 ;; Keywords: mail, net news
12 ;; This file is part of Wanderlust (Yet Another Message Interface on Emacsen).
14 ;; This program is free software; you can redistribute it and/or modify
15 ;; it under the terms of the GNU General Public License as published by
16 ;; the Free Software Foundation; either version 2, or (at your option)
17 ;; any later version.
19 ;; This program is distributed in the hope that it will be useful,
20 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
22 ;; GNU General Public License for more details.
24 ;; You should have received a copy of the GNU General Public License
25 ;; along with GNU Emacs; see the file COPYING. If not, write to the
26 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
27 ;; Boston, MA 02111-1307, USA.
29 ;;; Commentary:
31 ;;; Code:
33 (defconst wl-demo-copyright-notice
34 "Copyright (C) 1998-2008 Yuuichi Teranishi <teranisi@gohome.org>"
35 "A declaration of the copyright on Wanderlust.")
37 (eval-when-compile
38 (require 'cl))
39 (require 'path-util)
40 (require 'wl-vars)
41 (require 'wl-version)
42 (require 'wl-highlight)
44 (defun wl-demo-icon-name ()
45 "A function to determine logo file name."
46 (catch 'found
47 (dolist (pair wl-demo-icon-name-alist)
48 (when (eval (car pair))
49 (throw 'found (eval (cdr pair)))))))
51 (defvar wl-logo-ascii "\
52 o$ oo$$$$$$ooo
53 oo$$$ o$$ o$$$\"\"\"\"\"\"$$$$$o
54 $$$$$$\" o$$$\" o$\"\" \"$$$
55 $$\" o$\"\" o$\" $$$
56 $\" oo$\" $\" $$$
57 o$ oo\"\"$$ $ $$
58 o$$ oo$\" \"$$$o $ o$$
59 $$$$\"\" \"$$oo$ o o$\"
60 \"$$o \"$$$o oooo$\"\"
61 $$ \"\"\"\"
62 Wanderlust
63 \"$
64 Yet Another Message Interface On Emacsen"
65 "Ascii picture used to splash the startup screen.")
67 (eval-and-compile
68 (when wl-on-emacs21
69 ;; `display-images-p' has not been available in Emacs versions
70 ;; prior to Emacs 21.0.105.
71 (defalias-maybe 'display-images-p 'display-graphic-p)))
73 ;; Avoid byte compile warnings.
74 (eval-when-compile
75 (autoload 'bitmap-insert-xbm-file "bitmap" nil t)
76 (autoload 'create-image "image")
77 (autoload 'device-on-window-system-p "device")
78 (autoload 'image-type-available-p "image")
79 (autoload 'insert-image "image")
80 (autoload 'make-glyph "glyphs")
81 (autoload 'set-glyph-face "glyphs")
82 (autoload 'set-specifier "specifier")
83 (defalias-maybe 'face-background-name 'ignore)
84 (defalias-maybe 'frame-char-height 'ignore)
85 (defalias-maybe 'frame-char-width 'ignore)
86 (defalias-maybe 'glyph-height 'ignore)
87 (defalias-maybe 'glyph-width 'ignore)
88 (defalias-maybe 'image-size 'ignore)
89 (defalias-maybe 'make-extent 'ignore)
90 (defalias-maybe 'propertize 'ignore)
91 (defalias-maybe 'set-extent-end-glyph 'ignore)
92 (defalias-maybe 'window-pixel-height 'ignore)
93 (defalias-maybe 'window-pixel-width 'ignore))
95 (defvar wl-demo-bitmap-mule-available-p 'unknown
96 "Internal variable to say whether the BITMAP-MULE package is available.")
98 (defun wl-demo-image-type-alist ()
99 "Return an alist of available logo image types on the current frame."
100 (if (or (and (featurep 'xemacs)
101 (device-on-window-system-p))
102 window-system)
103 (let ((xpm
104 (when (or (and (featurep 'xemacs)
105 (featurep 'xpm))
106 (and wl-on-emacs21
107 (display-images-p)
108 (image-type-available-p 'xpm)))
109 '("xpm" . xpm)))
110 (xbm
111 (when (or (featurep 'xemacs)
112 (and wl-on-emacs21
113 (display-images-p)
114 (image-type-available-p 'xbm))
115 (eq t wl-demo-bitmap-mule-available-p)
116 (and (eq 'unknown wl-demo-bitmap-mule-available-p)
117 (module-installed-p 'bitmap)
118 (setq wl-demo-bitmap-mule-available-p t)))
119 '("xbm" . xbm)))
120 (bitmap
121 (when (and (not (featurep 'xemacs))
122 (or (eq t wl-demo-bitmap-mule-available-p)
123 (and (eq 'unknown wl-demo-bitmap-mule-available-p)
124 (module-installed-p 'bitmap)
125 (setq wl-demo-bitmap-mule-available-p t))))
126 '("bitmap" . bitmap))))
127 (if (and wl-on-emacs21
128 (image-type-available-p 'xbm))
129 ;; Prefer xbm rather than bitmap on Emacs 21.
130 (delq nil (list xpm xbm bitmap '("ascii")))
131 (delq nil (list xpm bitmap xbm '("ascii")))))
132 '(("ascii"))))
134 (defun wl-demo-image-filter (file type)
135 "Get filtered image data.
136 FILE is the image file name.
137 TYPE is the filter function."
138 (let ((filter (catch 'found
139 (dolist (pair wl-demo-image-filter-alist)
140 (when (eq (car pair) type)
141 (throw 'found (cdr pair)))))))
142 (with-temp-buffer
143 (set-buffer-multibyte nil)
144 (insert-file-contents file)
145 (goto-char (point-min))
146 (when filter
147 (funcall filter))
148 (buffer-string))))
150 (defun wl-demo-insert-image (image-type)
151 "Insert a logo image at the point and position it to be centered.
152 IMAGE-TYPE specifies what a type of image should be displayed.
153 Return a number of lines that an image occupies in the buffer."
154 (let ((file (cond ((eq 'xpm image-type)
155 (concat (wl-demo-icon-name) ".xpm"))
156 ((eq 'bitmap image-type)
157 (concat (wl-demo-icon-name) ".img"))
158 ((eq 'xbm image-type)
159 (concat (wl-demo-icon-name) ".xbm"))))
160 image width height)
161 (when (featurep 'xemacs)
162 (when (boundp 'default-gutter-visible-p)
163 (set-specifier (symbol-value 'default-gutter-visible-p)
164 nil (current-buffer)))
165 (when (featurep 'scrollbar)
166 (set-specifier (symbol-value 'scrollbar-height) 0 (current-buffer))
167 (set-specifier (symbol-value 'scrollbar-width) 0 (current-buffer))))
168 (if (and file
169 (if (and wl-icon-directory
170 (file-directory-p wl-icon-directory))
171 (setq file (expand-file-name file wl-icon-directory))
172 (message "You have to specify the value of `wl-icon-directory'")
173 nil)
174 (if (file-exists-p file)
175 (if (file-readable-p file)
177 (message "Permission denied: %s" file)
178 nil)
179 (message "File not found: %s" file)
180 nil))
181 (progn
182 (cond ((featurep 'xemacs)
183 (setq width (window-pixel-width)
184 height (window-pixel-height)
185 image (make-glyph
186 (if (eq image-type 'xbm)
187 (vector image-type ':file file)
188 (vector image-type ':data
189 (wl-demo-image-filter
190 file image-type)))))
191 (when (eq 'xbm image-type)
192 (set-glyph-face image 'wl-highlight-logo-face))
193 (insert-char ?\ (max 0 (/ (+ (* (- width (glyph-width image))
194 (window-width)) width)
195 (* 2 width))))
196 (set-extent-end-glyph (make-extent (point) (point)) image)
197 (insert "\n")
198 (/ (+ (* 2 (glyph-height image) (window-height)) height)
199 (* 2 height)))
200 ((and wl-on-emacs21
201 (or (eq 'xpm image-type)
202 (and (eq 'xbm image-type)
203 (image-type-available-p 'xbm))))
204 ;; Use the new redisplay engine on Emacs 21.
205 (setq image (create-image (wl-demo-image-filter file
206 image-type)
207 image-type t)
208 width (image-size image)
209 height (cdr width)
210 width (car width))
211 (when (eq 'xbm image-type)
212 (let ((bg (face-background 'wl-highlight-demo-face))
213 (fg (face-foreground 'wl-highlight-logo-face)))
214 (when (stringp bg)
215 (plist-put (cdr image) ':background bg))
216 (when (stringp fg)
217 (plist-put (cdr image) ':foreground fg))))
218 (insert (propertize " " 'display
219 (list 'space ':align-to
220 (max 0 (round (- (window-width)
221 width)
222 2)))))
223 (insert-image image)
224 (insert "\n")
225 (round height))
226 ((eq 'bitmap image-type)
227 ;; Use ready-composed bitmap image.
228 (require 'bitmap)
229 (let ((coding-system-for-read 'iso-2022-7bit)
230 (input-coding-system '*iso-2022-jp*))
231 (insert-file-contents file))
232 (goto-char (point-max))
233 (unless (bolp)
234 (insert "\n"))
236 ;; Emacs 21.x may fail on computing the end of the
237 ;; column if there're bitmap characters.
238 ;;(setq width 0)
239 ;;(while (progn
240 ;; (end-of-line 0)
241 ;; (not (bobp)))
242 ;; (setq width (max width (current-column))))
243 (setq width 1024)
244 (while (progn
245 (end-of-line 0)
246 (not (bobp)))
247 (setq width (min width (current-column))))
249 ;; Emacs 21.1 would fail to decode composite chars
250 ;; if it has been built without fixing coding.c.
251 (when (and wl-on-emacs21
252 (>= width 80))
253 (erase-buffer)
254 (let ((coding-system-for-read 'raw-text))
255 (insert-file-contents file))
256 (goto-char (point-max))
257 (unless (bolp)
258 (insert "\n"))
259 (setq width 0)
260 (while (progn
261 (end-of-line 0)
262 (not (bobp)))
263 ;; Decode bitmap data line by line.
264 (decode-coding-region (line-beginning-position)
265 (point)
266 'iso-2022-7bit)
267 (setq width (max width (current-column)))))
268 (indent-rigidly (point-min) (point-max)
269 (max 0 (/ (1+ (- (window-width) width)) 2)))
270 (put-text-property (point-min) (point-max) 'fixed-width t)
271 (count-lines (point-min) (goto-char (point-max))))
272 ((eq 'xbm image-type)
273 (message "Composing a bitmap image...")
274 (require 'bitmap)
275 (bitmap-insert-xbm-file file)
276 (backward-char)
277 (indent-rigidly (point-min) (point-max)
278 (max 0 (/ (1+ (- (window-width)
279 (current-column)))
280 2)))
281 (put-text-property (point-min) (point-max) 'fixed-width t)
282 (message "Composing a bitmap image...done")
283 (count-lines (point-min) (goto-char (point-max))))))
284 (insert wl-logo-ascii)
285 (unless (bolp)
286 (insert "\n"))
287 (setq width 0)
288 (while (progn
289 (end-of-line 0)
290 (not (bobp)))
291 (setq width (max width (current-column))))
292 (indent-rigidly (point-min) (point-max)
293 (max 0 (/ (1+ (- (window-width) width)) 2)))
294 (put-text-property (point-min) (point-max) 'fixed-width t)
295 (count-lines (point-min) (goto-char (point-max))))))
297 (defun wl-demo-setup-properties ()
298 "Set up properties of the demo buffer."
299 (cond
300 (wl-on-emacs21
301 ;; I think there should be a better way to set face background
302 ;; for the buffer only. But I don't know how to do it on Emacs21.
303 (goto-char (point-max))
304 (dotimes (i (- (window-height)
305 (count-lines (point-min) (point))))
306 (insert ?\n))
307 (let* ((fg (face-foreground 'wl-highlight-demo-face))
308 (bg (face-background 'wl-highlight-demo-face))
309 (oblique (nconc '(variable-pitch :slant oblique)
310 (when (stringp bg)
311 (list ':background bg))
312 (when (stringp fg)
313 (list ':foreground fg))))
314 (start (text-property-any (point-min) (point-max) 'fixed-width t))
315 end)
316 (if start
317 (progn
318 (put-text-property (point-min) start 'face oblique)
319 (setq end (or (text-property-not-all start (point-max)
320 'fixed-width t)
321 (point-max)))
322 (put-text-property start end 'face
323 (nconc '(wl-highlight-logo-face)
324 (when (stringp bg)
325 (list ':background bg))))
326 (put-text-property end (point-max) 'face oblique))
327 (put-text-property (point-min) (point-max) 'face oblique))))
328 ((and (featurep 'xemacs)
329 (face-background-name 'wl-highlight-demo-face))
330 (set-face-background 'default
331 (face-background-name 'wl-highlight-demo-face)
332 (current-buffer)))
334 (goto-char (point-max))
335 (dotimes (i (- (window-height)
336 (count-lines (point-min) (point))))
337 (insert ?\n))
338 (let ((start (text-property-any (point-min) (point-max) 'fixed-width t))
339 end)
340 (if start
341 (progn
342 (put-text-property (point-min) start 'face 'wl-highlight-demo-face)
343 (setq end (or (text-property-not-all start (point-max)
344 'fixed-width t)
345 (point-max)))
346 (put-text-property start end 'face 'wl-highlight-logo-face)
347 (put-text-property end (point-max) 'face 'wl-highlight-demo-face))
348 (put-text-property (point-min) (point-max)
349 'face 'wl-highlight-demo-face))))))
351 (defun wl-demo-insert-text (height)
352 "Insert a version and the copyright message after a logo image. HEIGHT
353 should be a number of lines that an image occupies in the buffer."
354 (let* ((height (- (window-height) height 1))
355 (text (format (cond ((<= height 2)
356 "version %s - \"%s\"\n%s\n")
357 ((eq height 3)
358 "version %s - \"%s\"\n\n%s\n")
360 "\nversion %s - \"%s\"\n\n%s\n"))
361 (product-version-string (product-find 'wl-version))
362 (product-code-name (product-find 'wl-version))
363 wl-demo-copyright-notice))
364 start)
365 (goto-char (point-min))
366 (insert-char ?\n (max 0 (/ (- height 4) 2)))
367 (setq start (goto-char (point-max)))
368 (insert text)
369 (let ((fill-column (window-width)))
370 (center-region start (point)))))
372 (defun wl-demo (&optional image-type)
373 "Demo on the startup screen. IMAGE-TYPE should be a symbol which
374 overrides the variable `wl-demo-display-logo'. It will prompt user
375 for the type of image when it is called interactively with a prefix
376 argument."
377 (interactive "P")
378 (let ((selection (wl-demo-image-type-alist))
379 type)
380 (if (and image-type (interactive-p))
381 (setq type (completing-read "Image type: " selection nil t)
382 image-type (when (assoc type selection)
383 (cdr (assoc type selection))))
384 (if (setq type (assoc (format "%s" (or image-type wl-demo-display-logo))
385 selection))
386 (setq image-type (cdr type))
387 (setq image-type (when wl-demo-display-logo
388 (cdr (car selection)))))))
389 (let ((buffer (let ((default-enable-multibyte-characters t)
390 (default-mc-flag t)
391 (default-line-spacing 0))
392 (get-buffer-create "*WL Demo*"))))
393 (switch-to-buffer buffer)
394 (setq buffer-read-only nil)
395 (buffer-disable-undo)
396 (erase-buffer)
397 (setq truncate-lines t
398 tab-width 8)
399 (set (make-local-variable 'tab-stop-list)
400 '(8 16 24 32 40 48 56 64 72 80 88 96 104 112 120))
401 (wl-demo-insert-text (wl-demo-insert-image image-type))
402 (wl-demo-setup-properties)
403 (set-buffer-modified-p nil)
404 (goto-char (point-min))
405 (sit-for (if (featurep 'lisp-float-type)
406 (/ (float 5) (float 10))
408 buffer))
410 (require 'product)
411 (product-provide (provide 'wl-demo) (require 'wl-version))
413 ;;; wl-demo.el ends here