X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=wl%2Fwl-demo.el;h=f4f32e2022aee2d0d4753560301c01703ca5989f;hb=8d25169967ab8fef4e06c6674be1021311db0820;hp=6b7959049016da96e14d1b50ac7c3673d8a8baad;hpb=6a2945d56ce47bfe301babfef0c41a1070ff22ef;p=elisp%2Fwanderlust.git

diff --git a/wl/wl-demo.el b/wl/wl-demo.el
index 6b79590..f4f32e2 100644
--- a/wl/wl-demo.el
+++ b/wl/wl-demo.el
@@ -1,7 +1,9 @@
-;;; wl-demo.el -- Opening demo on Wanderlust.
+;;; wl-demo.el --- Opening demo on Wanderlust
 
-;; Copyright (C) 1998,1999,2000,2001 Yuuichi Teranishi <teranisi@gohome.org>
-;; Copyright (C) 2000,2001 Katsumi Yamaoka <yamaoka@jpl.org>
+;; Copyright (C) 1998,1999,2000,2001,2002,2003,2004
+;;      Yuuichi Teranishi <teranisi@gohome.org>
+;; Copyright (C) 2000,2001,2004
+;;      Katsumi Yamaoka <yamaoka@jpl.org>
 
 ;; Author: Yuuichi Teranishi <teranisi@gohome.org>
 ;;	Katsumi Yamaoka <yamaoka@jpl.org>
@@ -13,61 +15,41 @@
 ;; it under the terms of the GNU General Public License as published by
 ;; the Free Software Foundation; either version 2, or (at your option)
 ;; any later version.
-;;
+
 ;; This program is distributed in the hope that it will be useful,
 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 ;; GNU General Public License for more details.
-;;
+
 ;; You should have received a copy of the GNU General Public License
 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
 ;; Boston, MA 02111-1307, USA.
-;;
 
 ;;; Commentary:
-;;
 
 ;;; Code:
-;;
 
 (defconst wl-demo-copyright-notice
-  "Copyright (C) 1998-2001 Yuuichi Teranishi <teranisi@gohome.org>")
+  "Copyright (C) 1998-2006 Yuuichi Teranishi <teranisi@gohome.org>"
+  "A declaration of the copyright on Wanderlust.")
 
+(eval-when-compile
+  (require 'cl))
+(require 'path-util)
 (require 'wl-vars)
 (require 'wl-version)
 (require 'wl-highlight)
 
-(defconst wl-demo-icon-name (concat "wl-" (wl-version-status) "-logo"))
-
-;; Avoid byte compile warnings.
-(eval-when-compile
-  (defalias-maybe 'bitmap-compose 'ignore)
-  (defalias-maybe 'bitmap-decode-xbm 'ignore)
-  (defalias-maybe 'bitmap-read-xbm-buffer 'ignore)
-  (defalias-maybe 'bitmap-read-xbm-file 'ignore)
-  (defalias-maybe 'create-image 'ignore)
-  (defalias-maybe 'device-on-window-system-p 'ignore)
-  (defalias-maybe 'display-graphic-p 'ignore)
-  (defalias-maybe 'frame-char-height 'ignore)
-  (defalias-maybe 'frame-char-width 'ignore)
-  (defalias-maybe 'frame-parameter 'ignore)
-  (defalias-maybe 'image-type-available-p 'ignore)
-  (defalias-maybe 'insert-image 'ignore)
-  (defalias-maybe 'make-extent 'ignore)
-  (defalias-maybe 'make-glyph 'ignore)
-  (defalias-maybe 'propertize 'ignore)
-  (defalias-maybe 'set-extent-end-glyph 'ignore)
-  (defalias-maybe 'set-glyph-face 'ignore)
-  (defalias-maybe 'set-specifier 'ignore)
-  (defalias-maybe 'window-pixel-height 'ignore)
-  (defalias-maybe 'window-pixel-width 'ignore))
-
-;;
-;; demo ;-)
-;;
+(defun wl-demo-icon-name ()
+  "A function to determine logo file name."
+  (catch 'found
+    (dolist (pair wl-demo-icon-name-alist)
+      (when (eval (car pair))
+	(throw 'found (eval (cdr pair)))))))
 
-(defvar wl-logo-ascii "        o$                  oo$$$$$$ooo
+(defvar wl-logo-ascii "\
+        o$                  oo$$$$$$ooo
      oo$$$      o$$      o$$$\"\"\"\"\"\"$$$$$o
   $$$$$$\"     o$$$\"    o$\"\"          \"$$$
     $$\"      o$\"\"    o$\"              $$$
@@ -79,287 +61,351 @@ $$$$\"\"       \"$$oo$    o          o$\"
                  $$       \"\"\"\"
 	       Wanderlust
                   \"$
-Yet Another Message Interface On Emacsen")
+Yet Another Message Interface On Emacsen"
+  "Ascii picture used to splash the startup screen.")
 
-(eval-when-compile
-  (defmacro wl-demo-with-temp-file-buffer (file &rest forms)
-    "Create a temporary buffer, insert FILE's contents without
-any conversions and evaluate FORMS there like `progn'."
-    ( `(with-temp-buffer
-	 (let ((coding-system-for-read 'binary)
-	       (input-coding-system '*noconv*)
-	       auto-mode-alist
-	       file-name-handler-alist
-	       format-alist
-	       insert-file-contents-access-hook
-	       insert-file-contents-post-hook
-	       insert-file-contents-pre-hook
-	       interpreter-mode-alist)
-	   (insert-file-contents (, file))
-	   (,@ forms)))))
-  (put 'wl-demo-with-temp-file-buffer 'lisp-indent-function 1))
+(eval-and-compile
+  (when wl-on-emacs21
+    ;; `display-images-p' has not been available in Emacs versions
+    ;; prior to Emacs 21.0.105.
+    (defalias-maybe 'display-images-p 'display-graphic-p)))
 
+;; Avoid byte compile warnings.
 (eval-when-compile
-  (defmacro wl-logo-xpm ()
-    ;; (WIDTH HEIGHT DATA)
-    (let ((file (expand-file-name (concat wl-demo-icon-name ".xpm")
-				  wl-icon-dir)))
-      (if (file-exists-p file)
-	  (wl-demo-with-temp-file-buffer file
-	    (re-search-forward
-	     (concat "\"[\t ]*\\([0-9]+\\)[\t ]+\\([0-9]+\\)"
-		     "[\t ]+[0-9]+[\t ]+[0-9]+[\t ]*\""))
-	    (list 'list
-		  (string-to-number (match-string 1))
-		  (string-to-number (match-string 2))
-		  (buffer-string))))))
-  (defmacro wl-logo-xbm ()
-    ;; (WIDTH HEIGHT DATA)
-    (let ((file (expand-file-name (concat wl-demo-icon-name ".xbm")
-				  wl-icon-dir)))
-      (if (file-exists-p file)
-	  (wl-demo-with-temp-file-buffer file
-	    (let ((case-fold-search t)
-		  width height)
-	      (search-forward "width")
-	      (setq width (read (current-buffer)))
-	      (goto-char (point-min))
-	      (search-forward "height")
-	      (setq height (read (current-buffer)))
-	      (goto-char (point-min))
-	      (search-forward "{")
-	      (delete-region (point-min) (point))
-	      (while (re-search-forward "[^0-9a-fx]+" nil t)
-		(replace-match ""))
-	      (goto-char (point-min))
-	      (insert "\"")
-	      (while (search-forward "0x" nil t)
-		(replace-match "\\\\x"))
-	      (goto-char (point-max))
-	      (insert "\"")
-	      (goto-char (point-min))
-	      (list 'list width height (read (current-buffer))))))))
-  (defmacro wl-logo-bitmap ()
-    ;; (DECODED-P . DATA)
-    (let ((file (expand-file-name (concat wl-demo-icon-name ".xbm")
-				  wl-icon-dir)))
-      (if (file-exists-p file)
-	  (if (condition-case nil
-		  (require 'bitmap)
-		(error nil))
-	      (list 'cons t (bitmap-decode-xbm (bitmap-read-xbm-file file)))
-	    (wl-demo-with-temp-file-buffer file
-	      (list 'cons nil (buffer-string))))))))
+  (autoload 'bitmap-insert-xbm-file "bitmap" nil t)
+  (autoload 'create-image "image")
+  (autoload 'device-on-window-system-p "device")
+  (autoload 'image-type-available-p "image")
+  (autoload 'insert-image "image")
+  (autoload 'make-glyph "glyphs")
+  (autoload 'set-glyph-face "glyphs")
+  (autoload 'set-specifier "specifier")
+  (defalias-maybe 'face-background-name 'ignore)
+  (defalias-maybe 'frame-char-height 'ignore)
+  (defalias-maybe 'frame-char-width 'ignore)
+  (defalias-maybe 'glyph-height 'ignore)
+  (defalias-maybe 'glyph-width 'ignore)
+  (defalias-maybe 'image-size 'ignore)
+  (defalias-maybe 'make-extent 'ignore)
+  (defalias-maybe 'propertize 'ignore)
+  (defalias-maybe 'set-extent-end-glyph 'ignore)
+  (defalias-maybe 'window-pixel-height 'ignore)
+  (defalias-maybe 'window-pixel-width 'ignore))
 
-(let ((xpm (wl-logo-xpm)))
-  (if (and xpm
-	   (or (and (featurep 'xemacs)
-		    (featurep 'xpm))
-	       (condition-case nil
-		   (require 'image)
-		 (error nil))))
-      (progn
-	(put 'wl-logo-xpm 'width (car xpm))
-	(put 'wl-logo-xpm 'height (nth 1 xpm))
-	(put 'wl-logo-xpm 'image
-	     (if (featurep 'xemacs)
-		 (make-glyph (vector 'xpm ':data (nth 2 xpm)))
-	       (condition-case nil
-		   (let ((image-types '(xpm)))
-		     (create-image (nth 2 xpm) 'xpm t))
-		 (error
-		  (put 'wl-logo-xpm 'width nil)
-		  (put 'wl-logo-xpm 'height nil)
-		  nil)))))))
+(defvar wl-demo-bitmap-mule-available-p 'unknown
+  "Internal variable to say whether the BITMAP-MULE package is available.")
 
-(let (width height)
-  (let ((xbm (wl-logo-xbm)))
-    (setq width (car xbm)
-	  height (nth 1 xbm))
-    (if (and xbm
-	     (or (featurep 'xemacs)
-		 (condition-case nil
-		     (require 'image)
-		   (error nil))))
-	(progn
-	  (put 'wl-logo-xbm 'width width)
-	  (put 'wl-logo-xbm 'height height)
-	  (put 'wl-logo-xbm 'image
-	       (if (featurep 'xemacs)
-		   (make-glyph (vector 'xbm ':data xbm))
-		 (condition-case nil
-		     (let ((image-types '(xbm)))
-		       (create-image (nth 2 xbm) 'xbm t
-				     ':width (car xbm) ':height (nth 1 xbm)))
-		   (error
-		    (put 'wl-logo-xbm 'width nil)
-		    (put 'wl-logo-xbm 'height nil)
-		    nil)))))))
-  (if (and width
-	   (not (featurep 'xemacs))
-	   (condition-case nil
-	       (require 'bitmap)
-	     (error nil)))
-      (progn
-	(put 'wl-logo-bitmap 'width width)
-	(put 'wl-logo-bitmap 'height height)
-	(let ((default-enable-multibyte-characters t)
-	      (default-mc-flag t))
-	  (with-temp-buffer
-	    (let* ((bm (wl-logo-bitmap))
-		   (cmp (if (car bm)
-			    (cdr bm)
-			  (insert (cdr bm))
-			  (prog1
-			      (bitmap-decode-xbm (bitmap-read-xbm-buffer
-						  (current-buffer)))
-			    (erase-buffer))))
-		   (len (length cmp))
-		   (i 1))
-	      (insert (bitmap-compose (aref cmp 0)))
-	      (while (< i len)
-		(insert "\n" (bitmap-compose (aref cmp i)))
-		(setq i (1+ i)))
-	      (put 'wl-logo-bitmap 'image (buffer-string))))))))
+(defun wl-demo-image-type-alist ()
+  "Return an alist of available logo image types on the current frame."
+  (if (or (and (featurep 'xemacs)
+	       (device-on-window-system-p))
+	  window-system)
+      (let ((xpm
+	     (when (or (and (featurep 'xemacs)
+			    (featurep 'xpm))
+		       (and wl-on-emacs21
+			    (display-images-p)
+			    (image-type-available-p 'xpm)))
+	       '("xpm" . xpm)))
+	    (xbm
+	     (when (or (featurep 'xemacs)
+		       (and wl-on-emacs21
+			    (display-images-p)
+			    (image-type-available-p 'xbm))
+		       (eq t wl-demo-bitmap-mule-available-p)
+		       (and (eq 'unknown wl-demo-bitmap-mule-available-p)
+			    (module-installed-p 'bitmap)
+			    (setq wl-demo-bitmap-mule-available-p t)))
+	       '("xbm" . xbm)))
+	    (bitmap
+	     (when (and (not (featurep 'xemacs))
+			(or (eq t wl-demo-bitmap-mule-available-p)
+			    (and (eq 'unknown wl-demo-bitmap-mule-available-p)
+				 (module-installed-p 'bitmap)
+				 (setq wl-demo-bitmap-mule-available-p t))))
+	       '("bitmap" . bitmap))))
+	(if (and wl-on-emacs21
+		 (image-type-available-p 'xbm))
+	    ;; Prefer xbm rather than bitmap on Emacs 21.
+	    (delq nil (list xpm xbm bitmap '("ascii")))
+	  (delq nil (list xpm bitmap xbm '("ascii")))))
+    '(("ascii"))))
 
-(eval-when-compile
-  (defmacro wl-demo-image-type-alist ()
-    '(append (if (and (get 'wl-logo-xpm 'width)
-		      (or (and (featurep 'xemacs)
-			       (featurep 'xpm)
-			       (device-on-window-system-p))
-			  (and wl-on-emacs21
-			       (display-graphic-p)
-			       (image-type-available-p 'xpm))))
-		 '(("xpm" . xpm)))
-	     (if (and (get 'wl-logo-xbm 'width)
-		      (or (and (featurep 'xemacs)
-			       (device-on-window-system-p))
-			  (and wl-on-emacs21
-			       (display-graphic-p)
+(defun wl-demo-image-filter (file type)
+  "Get filtered image data.
+FILE is the image file name.
+TYPE is the filter function."
+  (let ((filter (catch 'found
+		  (dolist (pair wl-demo-image-filter-alist)
+		    (when (eq (car pair) type)
+		      (throw 'found (cdr pair)))))))
+    (with-temp-buffer
+      (set-buffer-multibyte nil)
+      (insert-file-contents file)
+      (goto-char (point-min))
+      (when filter
+	(funcall filter))
+      (buffer-string))))
+
+(defun wl-demo-insert-image (image-type)
+  "Insert a logo image at the point and position it to be centered.
+IMAGE-TYPE specifies what a type of image should be displayed.
+Return a number of lines that an image occupies in the buffer."
+  (let ((file (cond ((eq 'xpm image-type)
+		     (concat (wl-demo-icon-name) ".xpm"))
+		    ((eq 'bitmap image-type)
+		     (concat (wl-demo-icon-name) ".img"))
+		    ((eq 'xbm image-type)
+		     (concat (wl-demo-icon-name) ".xbm"))))
+	image width height)
+    (when (featurep 'xemacs)
+      (when (boundp 'default-gutter-visible-p)
+	(set-specifier (symbol-value 'default-gutter-visible-p)
+		       nil (current-buffer)))
+      (when (featurep 'scrollbar)
+	(set-specifier (symbol-value 'scrollbar-height) 0 (current-buffer))
+	(set-specifier (symbol-value 'scrollbar-width) 0 (current-buffer))))
+    (if (and file
+	     (if (and wl-icon-directory
+		      (file-directory-p wl-icon-directory))
+		 (setq file (expand-file-name file wl-icon-directory))
+	       (message "You have to specify the value of `wl-icon-directory'")
+	       nil)
+	     (if (file-exists-p file)
+		 (if (file-readable-p file)
+		     t
+		   (message "Permission denied: %s" file)
+		   nil)
+	       (message "File not found: %s" file)
+	       nil))
+	(progn
+	  (cond ((featurep 'xemacs)
+		 (setq width (window-pixel-width)
+		       height (window-pixel-height)
+		       image (make-glyph
+			      (if (eq image-type 'xbm)
+				  (vector image-type ':file file)
+				(vector image-type ':data
+					(wl-demo-image-filter
+					 file image-type)))))
+		 (when (eq 'xbm image-type)
+		   (set-glyph-face image 'wl-highlight-logo-face))
+		 (insert-char ?\  (max 0 (/ (+ (* (- width (glyph-width image))
+						  (window-width)) width)
+					    (* 2 width))))
+		 (set-extent-end-glyph (make-extent (point) (point)) image)
+		 (insert "\n")
+		 (/ (+ (* 2 (glyph-height image) (window-height)) height)
+		    (* 2 height)))
+		((and wl-on-emacs21
+		      (or (eq 'xpm image-type)
+			  (and (eq 'xbm image-type)
 			       (image-type-available-p 'xbm))))
-		 '(("xbm" . xbm)))
-	     (if (and (get 'wl-logo-bitmap 'width)
-		      (not (featurep 'xemacs))
-		      window-system
-		      (featurep 'bitmap))
-		 '(("bitmap" . bitmap)))
-	     '(("ascii")))))
+		 ;; Use the new redisplay engine on Emacs 21.
+		 (setq image (create-image (wl-demo-image-filter file
+								 image-type)
+					   image-type t)
+		       width (image-size image)
+		       height (cdr width)
+		       width (car width))
+		 (when (eq 'xbm image-type)
+		   (let ((bg (face-background 'wl-highlight-demo-face))
+			 (fg (face-foreground 'wl-highlight-logo-face)))
+		     (when (stringp bg)
+		       (plist-put (cdr image) ':background bg))
+		     (when (stringp fg)
+		       (plist-put (cdr image) ':foreground fg))))
+		 (insert (propertize " " 'display
+				     (list 'space ':align-to
+					   (max 0 (round (- (window-width)
+							    width)
+							 2)))))
+		 (insert-image image)
+		 (insert "\n")
+		 (round height))
+		((eq 'bitmap image-type)
+		 ;; Use ready-composed bitmap image.
+		 (require 'bitmap)
+		 (let ((coding-system-for-read 'iso-2022-7bit)
+		       (input-coding-system '*iso-2022-jp*))
+		   (insert-file-contents file))
+		 (goto-char (point-max))
+		 (unless (bolp)
+		   (insert "\n"))
+
+		 ;; Emacs 21.x may fail on computing the end of the
+		 ;; column if there're bitmap characters.
+		 ;;(setq width 0)
+		 ;;(while (progn
+		 ;;	    (end-of-line 0)
+		 ;;	    (not (bobp)))
+		 ;;  (setq width (max width (current-column))))
+		 (setq width 1024)
+		 (while (progn
+			  (end-of-line 0)
+			  (not (bobp)))
+		   (setq width (min width (current-column))))
+
+		 ;; Emacs 21.1 would fail to decode composite chars
+		 ;; if it has been built without fixing coding.c.
+		 (when (and wl-on-emacs21
+			    (>= width 80))
+		   (erase-buffer)
+		   (let ((coding-system-for-read 'raw-text))
+		     (insert-file-contents file))
+		   (goto-char (point-max))
+		   (unless (bolp)
+		     (insert "\n"))
+		   (setq width 0)
+		   (while (progn
+			    (end-of-line 0)
+			    (not (bobp)))
+		     ;; Decode bitmap data line by line.
+		     (decode-coding-region (line-beginning-position)
+					   (point)
+					   'iso-2022-7bit)
+		     (setq width (max width (current-column)))))
+		 (indent-rigidly (point-min) (point-max)
+				 (max 0 (/ (1+ (- (window-width) width)) 2)))
+		 (put-text-property (point-min) (point-max) 'fixed-width t)
+		 (count-lines (point-min) (goto-char (point-max))))
+		((eq 'xbm image-type)
+		 (message "Composing a bitmap image...")
+		 (require 'bitmap)
+		 (bitmap-insert-xbm-file file)
+		 (backward-char)
+		 (indent-rigidly (point-min) (point-max)
+				 (max 0 (/ (1+ (- (window-width)
+						  (current-column)))
+					   2)))
+		 (put-text-property (point-min) (point-max) 'fixed-width t)
+		 (message "Composing a bitmap image...done")
+		 (count-lines (point-min) (goto-char (point-max))))))
+      (insert wl-logo-ascii)
+      (unless (bolp)
+	(insert "\n"))
+      (setq width 0)
+      (while (progn
+	       (end-of-line 0)
+	       (not (bobp)))
+	(setq width (max width (current-column))))
+      (indent-rigidly (point-min) (point-max)
+		      (max 0 (/ (1+ (- (window-width) width)) 2)))
+      (put-text-property (point-min) (point-max) 'fixed-width t)
+      (count-lines (point-min) (goto-char (point-max))))))
+
+(defun wl-demo-setup-properties ()
+  "Set up properties of the demo buffer."
+  (cond
+   (wl-on-emacs21
+    ;; I think there should be a better way to set face background
+    ;; for the buffer only. But I don't know how to do it on Emacs21.
+    (goto-char (point-max))
+    (dotimes (i (- (window-height)
+		   (count-lines (point-min) (point))))
+      (insert ?\n))
+    (let* ((fg (face-foreground 'wl-highlight-demo-face))
+	   (bg (face-background 'wl-highlight-demo-face))
+	   (oblique (nconc '(variable-pitch :slant oblique)
+			   (when (stringp bg)
+			     (list ':background bg))
+			   (when (stringp fg)
+			     (list ':foreground fg))))
+	   (start (text-property-any (point-min) (point-max) 'fixed-width t))
+	   end)
+      (if start
+	  (progn
+	    (put-text-property (point-min) start 'face oblique)
+	    (setq end (or (text-property-not-all start (point-max)
+						 'fixed-width t)
+			  (point-max)))
+	    (put-text-property start end 'face
+			       (nconc '(wl-highlight-logo-face)
+				      (when (stringp bg)
+					(list ':background bg))))
+	    (put-text-property end (point-max) 'face oblique))
+	(put-text-property (point-min) (point-max) 'face oblique))))
+   ((and (featurep 'xemacs)
+	 (face-background-name 'wl-highlight-demo-face))
+    (set-face-background 'default
+			 (face-background-name 'wl-highlight-demo-face)
+			 (current-buffer)))
+   (t
+    (goto-char (point-max))
+    (dotimes (i (- (window-height)
+		   (count-lines (point-min) (point))))
+      (insert ?\n))
+    (let ((start (text-property-any (point-min) (point-max) 'fixed-width t))
+	  end)
+      (if start
+	  (progn
+	    (put-text-property (point-min) start 'face 'wl-highlight-demo-face)
+	    (setq end (or (text-property-not-all start (point-max)
+						 'fixed-width t)
+			  (point-max)))
+	    (put-text-property start end 'face 'wl-highlight-logo-face)
+	    (put-text-property end (point-max) 'face 'wl-highlight-demo-face))
+	(put-text-property (point-min) (point-max)
+			   'face 'wl-highlight-demo-face))))))
+
+(defun wl-demo-insert-text (height)
+  "Insert a version and the copyright message after a logo image.  HEIGHT
+should be a number of lines that an image occupies in the buffer."
+  (let* ((height (- (window-height) height 1))
+	 (text (format (cond ((<= height 2)
+			      "version %s - \"%s\"\n%s\n")
+			     ((eq height 3)
+			      "version %s - \"%s\"\n\n%s\n")
+			     (t
+			      "\nversion %s - \"%s\"\n\n%s\n"))
+		       (product-version-string (product-find 'wl-version))
+		       (product-code-name (product-find 'wl-version))
+		       wl-demo-copyright-notice))
+	 start)
+    (goto-char (point-min))
+    (insert-char ?\n (max 0 (/ (- height 4) 2)))
+    (setq start (goto-char (point-max)))
+    (insert text)
+    (let ((fill-column (window-width)))
+      (center-region start (point)))))
 
 (defun wl-demo (&optional image-type)
-  "Demo on the startup screen.
-Optional IMAGE-TYPE overrides the variable `wl-demo-display-logo'."
+  "Demo on the startup screen.  IMAGE-TYPE should be a symbol which
+overrides the variable `wl-demo-display-logo'.  It will prompt user
+for the type of image when it is called interactively with a prefix
+argument."
   (interactive "P")
   (let ((selection (wl-demo-image-type-alist))
 	type)
     (if (and image-type (interactive-p))
 	(setq type (completing-read "Image type: " selection nil t)
-	      image-type (if (assoc type selection)
-			     (cdr (assoc type selection))))
+	      image-type (when (assoc type selection)
+			   (cdr (assoc type selection))))
       (if (setq type (assoc (format "%s" (or image-type wl-demo-display-logo))
 			    selection))
 	  (setq image-type (cdr type))
-	(setq image-type (cdr (car selection))))))
-  (if image-type
-      (setq image-type (intern (format "wl-logo-%s" image-type))))
-  (let ((demo-buf (let ((default-enable-multibyte-characters t)
-			(default-mc-flag t)
-			(default-line-spacing 0))
-		    (get-buffer-create "*WL Demo*"))))
-    (switch-to-buffer demo-buf)
+	(setq image-type (when wl-demo-display-logo
+			   (cdr (car selection)))))))
+  (let ((buffer (let ((default-enable-multibyte-characters t)
+		      (default-mc-flag t)
+		      (default-line-spacing 0))
+		  (get-buffer-create "*WL Demo*"))))
+    (switch-to-buffer buffer)
+    (setq buffer-read-only nil)
+    (buffer-disable-undo)
     (erase-buffer)
     (setq truncate-lines t
 	  tab-width 8)
     (set (make-local-variable 'tab-stop-list)
 	 '(8 16 24 32 40 48 56 64 72 80 88 96 104 112 120))
-    (when (and (featurep 'xemacs)
-	       (device-on-window-system-p))
-      (if (boundp 'default-gutter-visible-p)
-	  (set-specifier (symbol-value 'default-gutter-visible-p)
-			 nil demo-buf))
-      (set-specifier (symbol-value 'scrollbar-height) 0 demo-buf)
-      (set-specifier (symbol-value 'scrollbar-width) 0 demo-buf))
-    (let ((ww (window-width))
-	  (wh (window-height))
-	  rest)
-      (if image-type
-	  (let ((lw (get image-type 'width))
-		(lh (get image-type 'height))
-		(image (get image-type 'image)))
-	    (cond
-	     ((featurep 'xemacs)
-	      (if (eq 'wl-logo-xbm image-type)
-		  (set-glyph-face image 'wl-highlight-logo-face))
-	      (setq rest (- wh 1 (/ (+ (* lh wh) (window-pixel-height) -1)
-				    (window-pixel-height))))
-	      (insert-char ?\  (max 0 (/ (- (* (window-pixel-width) (1+ ww))
-					    (* lw ww))
-					 2 (window-pixel-width))))
-	      (set-extent-end-glyph (make-extent (point) (point)) image))
-	     ((and wl-on-emacs21
-		   (display-graphic-p)
-		   (not (eq 'wl-logo-bitmap image-type)))
-	      (if (eq 'wl-logo-xbm image-type)
-		  (let ((bg (face-background 'wl-highlight-logo-face))
-			(fg (face-foreground 'wl-highlight-logo-face)))
-		    (if (stringp bg)
-			(plist-put (cdr image) ':background bg))
-		    (if (stringp fg)
-			(plist-put (cdr image) ':foreground fg))))
-	      (setq rest (/ (- (* wh (frame-char-height)) lh 1)
-			    (frame-char-height)))
-	      (insert (propertize " " 'display
-				  (list 'space ':align-to
-					(max 0 (/ (- (* (frame-char-width)
-							(1+ ww)) lw)
-						  2 (frame-char-width))))))
-	      (insert-image image))
-	     (t
-	      (insert image)
-	      (put-text-property (point-min) (point) 'face
-				 'wl-highlight-logo-face)
-	      (setq rest (/ (- (* 16 wh) lh 8) 16))
-	      (indent-rigidly (point-min) (point-max)
-			      (/ (- (* 8 (1+ ww)) lw) 16))))
-	    (goto-char (point-min)))
-	(insert (or wl-logo-ascii (product-name (product-find 'wl-version))))
-	(put-text-property (point-min) (point) 'face 'wl-highlight-logo-face)
-	(setq rest (- wh (count-lines (point-min) (point)) 1))
-	(let ((lw (current-column))
-	      (lh (count-lines (point-min) (point))))
-	  (while (progn (beginning-of-line) (not (bobp)))
-	    (backward-char)
-	    (setq lw (max lw (current-column))))
-	  (indent-rigidly (point) (point-max) (max 0 (/ (- ww lw) 2)))))
-      (insert-char ?\n (max 0 (/ (- rest 4) 2)))
-      (goto-char (point-max))
-      (insert "\n")
-      (let ((start (point))
-	    (text (format (cond ((<= rest 2)
-				 "version %s - \"%s\"\n%s")
-				((eq rest 3)
-				 "version %s - \"%s\"\n\n%s")
-				(t
-				 "\nversion %s - \"%s\"\n\n%s"))
-			  (product-version-string (product-find 'wl-version))
-			  (product-code-name (product-find 'wl-version))
-			  wl-demo-copyright-notice)))
-	(if wl-on-emacs21
-	    (let ((bg (face-background 'wl-highlight-demo-face))
-		  (fg (face-foreground 'wl-highlight-demo-face)))
-	      (insert (propertize text
-				  'face (nconc '(variable-pitch :slant oblique)
-					       (if (stringp bg)
-						   (list ':background bg))
-					       (if (stringp fg)
-						   (list ':foreground fg))))))
-	  (insert text)
-	  (put-text-property start (point) 'face 'wl-highlight-demo-face))
-	(let ((fill-column ww))
-	  (center-region start (point))))
-      (goto-char (point-min))
-      (sit-for (if (featurep 'lisp-float-type) (/ (float 5) (float 10)) 1))
-      demo-buf)))
+    (wl-demo-insert-text (wl-demo-insert-image image-type))
+    (wl-demo-setup-properties)
+    (set-buffer-modified-p nil)
+    (goto-char (point-min))
+    (sit-for (if (featurep 'lisp-float-type)
+		 (/ (float 5) (float 10))
+	       1))
+    buffer))
 
 (require 'product)
 (product-provide (provide 'wl-demo) (require 'wl-version))