X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=wl%2Fwl-demo.el;h=19d26d667d87c5c7ada0e68ea0b53819af4e646a;hb=9e39553b80115a949a7f04ddced4459a7797f8bd;hp=52a3a0db3ecc04f3827ba35436e0948ddc7ab4b3;hpb=1e366a559be4aec4ad4d3cf3e954b8e62a20d2f3;p=elisp%2Fwanderlust.git

diff --git a/wl/wl-demo.el b/wl/wl-demo.el
index 52a3a0d..19d26d6 100644
--- a/wl/wl-demo.el
+++ b/wl/wl-demo.el
@@ -1,10 +1,11 @@
-;;; wl-demo.el -- Opening demo on Wanderlust.
+;;; wl-demo.el --- Opening demo on Wanderlust
 
-;; Copyright 1998,1999,2000 Yuuichi Teranishi <teranisi@gohome.org>
+;; Copyright (C) 1998,1999,2000,2001 Yuuichi Teranishi <teranisi@gohome.org>
+;; Copyright (C) 2000,2001 Katsumi Yamaoka <yamaoka@jpl.org>
 
 ;; Author: Yuuichi Teranishi <teranisi@gohome.org>
+;;	Katsumi Yamaoka <yamaoka@jpl.org>
 ;; Keywords: mail, net news
-;; Time-stamp: <2000-03-30 15:56:54 teranisi>
 
 ;; This file is part of Wanderlust (Yet Another Message Interface on Emacsen).
 
@@ -12,190 +13,289 @@
 ;; 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:
-;; 
 
-(require 'wl-vars)
-(provide 'wl-demo)
-(if (featurep 'xemacs)
-    (require 'wl-xmas))
+(defconst wl-demo-copyright-notice
+  "Copyright (C) 1998-2001 Yuuichi Teranishi <teranisi@gohome.org>"
+  "A declaration of the copyright on Wanderlust.")
 
 (eval-when-compile
-  (defun-maybe device-on-window-system-p ())
-  (defun-maybe glyph-height (a))
-  (defun-maybe glyph-width (a))
-  (defun-maybe make-extent (a b))
-  (defun-maybe make-glyph (a))
-  (defun-maybe set-extent-end-glyph (a b))
-  (defun-maybe startup-center-spaces (a))
-  (defun-maybe window-pixel-height ())
-  (defun-maybe window-pixel-width ())
-  (condition-case nil
-      (require 'bitmap)
-    (error nil))
-  (defun-maybe bitmap-compose (a))
-  (defun-maybe bitmap-decode-xbm (a))
-  (defun-maybe bitmap-read-xbm-file (a))
-  (unless (boundp ':data)
-    (set (make-local-variable ':data) nil))
-  (unless (boundp ':type)
-    (set (make-local-variable ':type) nil))
-  (condition-case nil
-      (require 'image)
-    (error nil))
-  (defun-maybe frame-char-height ())
-  (defun-maybe frame-char-width ())
-  (defun-maybe image-type-available-p (a)))
-
-(static-condition-case nil
-    (progn
-      (insert-image '(image))
-      (defalias 'wl-insert-image 'insert-image))
-  (wrong-number-of-arguments
-   (defun wl-insert-image (image)
-     (insert-image image "x")))
-  (void-function
-   (defun wl-insert-image (image))))
-
-;;
-;; demo ;-)
-;;
+  (require 'cl))
+(require 'path-util)
+(require 'wl-vars)
+(require 'wl-version)
+(require 'wl-highlight)
+
+(defconst wl-demo-icon-name
+  (concat "wl-" (wl-version-status)
+	  (if (string-match "^... Dec \\([ 1][0-9]\\|2[0-4]\\)"
+			    (current-time-string))
+	      "-xmas-logo"
+	    "-logo"))
+  "Basename of the logo file.")
+
+(defvar wl-logo-ascii "\
+        o$                  oo$$$$$$ooo
+     oo$$$      o$$      o$$$\"\"\"\"\"\"$$$$$o
+  $$$$$$\"     o$$$\"    o$\"\"          \"$$$
+    $$\"      o$\"\"    o$\"              $$$
+   $\"      oo$\"     $\"                $$$
+ o$     oo\"\"$$     $                  $$
+o$$  oo$\"  \"$$$o  $                 o$$
+$$$$\"\"       \"$$oo$    o          o$\"
+               \"$$o   \"$$$o oooo$\"\"
+                 $$       \"\"\"\"
+	       Wanderlust
+                  \"$
+Yet Another Message Interface On Emacsen"
+  "Ascii picture used to splash the startup screen.")
+
+(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
-  (cond ((or (featurep 'xemacs) (featurep 'image))
-	 (defmacro wl-title-logo ()
-	   (let ((file (expand-file-name "wl-logo.xpm" wl-icon-dir)))
-	     (if (file-exists-p file)
-		 (let ((buffer (generate-new-buffer " *wl-logo*"))
-		       (coding-system-for-read 'binary)
-		       buffer-file-format format-alist
-		       insert-file-contents-post-hook
-		       insert-file-contents-pre-hook)
-		   (prog1
-		       (save-excursion
-			 (set-buffer buffer)
-			 (insert-file-contents file)
-			 (buffer-string))
-		     (kill-buffer buffer)))))))
-	((condition-case nil
-	     (require 'bitmap)
-	   (error nil))
-	 (defmacro wl-title-logo ()
-	   (let ((file (expand-file-name "wl-logo.xbm" wl-icon-dir)))
+  (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 '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))
+
+(defvar wl-demo-bitmap-mule-available-p 'unknown
+  "Internal variable to say whether the BITMAP-MULE package is available.")
+
+(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)
+      (append
+       (when (or (and (featurep 'xemacs)
+		      (featurep 'xpm))
+		 (and wl-on-emacs21
+		      (display-images-p)
+		      (image-type-available-p 'xpm)))
+	 '(("xpm" . xpm)))
+       (when (and (not (or (featurep 'xemacs)
+			   ;; *.img files won't fit for Emacs 21.
+			   wl-on-emacs21))
+		  (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)))
+       (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)))
+       '(("ascii")))
+    '(("ascii"))))
+
+(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)))
+      (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)
-		 (condition-case nil
-		     (bitmap-decode-xbm (bitmap-read-xbm-file file))
-		   (error (message "Bitmap Logo is not used.")))))))
-	(t
-	 (defmacro wl-title-logo ()))))
-
-(defconst wl-title-logo
-  (cond ((or (and (featurep 'xemacs)
-                  (featurep 'xpm)
-                  (device-on-window-system-p))
-             (and (eval-when-compile (featurep 'image))
-                  (image-type-available-p 'xpm)))
-	 (wl-title-logo))
-	((and window-system
-	      (condition-case nil
-		  (require 'bitmap)
-		(error nil)))
-	 (let ((cmp (wl-title-logo)))
-	   (if cmp
-	       (condition-case nil
-		   (let ((len (length cmp))
-			 (bitmap (bitmap-compose (aref cmp 0)))
-			 (i 1))
-		     (while (< i len)
-		       (setq bitmap (concat bitmap "\n"
-					    (bitmap-compose (aref cmp i)))
-			     i (1+ i)))
-		     bitmap)
-		 (error nil)))))))
-
-(defun wl-demo ()
-  (interactive)
-  (let ((demo-buf (get-buffer-create "*WL Demo*"))
-	logo-ext start)
-    (switch-to-buffer demo-buf)
-    (erase-buffer)
-    (if (and wl-demo-display-logo wl-title-logo)
-	(cond
-         ((featurep 'xemacs)
-          (let ((wl-logo (make-glyph (vector 'xpm :data wl-title-logo))))
-            (insert-char ?\n (max 1 (/ (- (window-height) 6
-                                          (/ (glyph-height wl-logo)
-                                             (/ (window-pixel-height)
-                                                (window-height)))) 2)))
-            (indent-to (startup-center-spaces wl-logo))
-            (insert-char ?\ (max 0 (/ (- (window-width)
-                                         (/ (glyph-width wl-logo)
-                                            (/ (window-pixel-width)
-                                               (window-width)))) 2)))
-            (setq logo-ext (make-extent (point)(point)))
-            (set-extent-end-glyph logo-ext wl-logo)))
-         ((featurep 'image)
-          (let ((wl-logo (list 'image :type 'xpm :data wl-title-logo))
-                pixel-width pixel-height)
-            (with-temp-buffer
-              (insert wl-title-logo)
-              (goto-char (point-min))
-              (skip-syntax-forward "^\"")
-              (when (looking-at "\"[ \t]*\\([0-9]+\\)[ \t]*\\([0-9]+\\)")
-                (setq pixel-width (string-to-int (match-string 1))
-                      pixel-height (string-to-int (match-string 2)))))
-            (insert-char ?\n (max 1 (/ (- (window-height) 6
-                                          (/ pixel-height 
-                                             (frame-char-height))) 2)))
-            (insert-char ?\  (max 0 (/ (- (window-width)
-                                          (/ pixel-width 
-                                             (frame-char-width))) 2)))
-            (wl-insert-image wl-logo)
-            (insert "\n")))
-         (t
-	  (insert wl-title-logo)
-	  (indent-rigidly (point-min) (point-max)
-			  (max 0 (/ (- (window-width) (current-column)) 2)))
-	  (insert "\n")
-	  (goto-char (point-min))
-	  (insert-char ?\n (max 0 (/ (- (window-height)
-					(count-lines (point) (point-max))
-					6) 2)))
-	  (goto-char (point-max))))
-      (insert-char ?\n (max 1 (- (/ (window-height) 3) 2))))
-    (setq start (point))
-    (insert "\n" (if (and wl-demo-display-logo wl-title-logo)
-		     ""
-		   (concat wl-appname "\n")))
-    (let ((fill-column (window-width)))
-      (center-region start (point)))
-    (setq start (point))
-    (put-text-property (point-min) (point) 'face 'wl-highlight-logo-face)
-    (insert (format "\nversion %s - \"%s\"\n\n"
-		    wl-version wl-codename
-		    ))
-    (insert "Copyright (C) 1998-2000 Yuuichi Teranishi <teranisi@gohome.org>")
-    (put-text-property start (point-max) 'face 'wl-highlight-demo-face)
+		 (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 (vector image-type ':file file)))
+		 (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)))
+		((eq 'bitmap image-type)
+		 (require 'bitmap)
+		 (let ((coding-system-for-read 'iso-2022-7bit)
+		       (input-coding-system '*iso-2022-jp*))
+		   (insert-file-contents file))
+		 (end-of-line)
+		 (indent-rigidly (point-min) (point-max)
+				 (max 0 (/ (1+ (- (window-width)
+						  (current-column)))
+					   2)))
+		 (put-text-property (point-min) (point-max)
+				    'face 'wl-highlight-logo-face)
+		 (count-lines (point-min) (goto-char (point-max))))
+		((>= emacs-major-version 21)
+		 (setq image (create-image file image-type)
+		       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-demo-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 '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)
+				    'face 'wl-highlight-logo-face)
+		 (message "Composing a bitmap image...done")
+		 (count-lines (point-min) (goto-char (point-max))))))
+      (insert wl-logo-ascii)
+      (put-text-property (point-min) (point) 'face 'wl-highlight-logo-face)
+      (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)))
+      (count-lines (point-min) (goto-char (point-max))))))
+
+(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")
+			     ((eq height 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))
+	 start)
+    (goto-char (point-min))
+    (insert-char ?\n (max 0 (/ (- height 4) 2)))
+    (setq start (goto-char (point-max)))
+    (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)
+					   (when (stringp bg)
+					     (list ':background bg))
+					   (when (stringp fg)
+					     (list ':foreground fg))))))
+      (insert text)
+      (put-text-property start (point) 'face 'wl-highlight-demo-face))
     (let ((fill-column (window-width)))
-      (center-region start (point)))
+      (center-region start (point)))))
+
+(defun wl-demo (&optional image-type)
+  "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 (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 (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)
+    (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))
+    (wl-demo-insert-text (wl-demo-insert-image image-type))
+    (set-buffer-modified-p nil)
     (goto-char (point-min))
-    (sit-for
-     (if (featurep 'lisp-float-type) (/ (float 5) (float 10)) 1))
-    ;;(if (featurep 'xemacs) (delete-extent logo-ext))
-    demo-buf))
+    (sit-for (if (featurep 'lisp-float-type)
+		 (/ (float 5) (float 10))
+	       1))
+    buffer))
+
+(require 'product)
+(product-provide (provide 'wl-demo) (require 'wl-version))
 
 ;;; wl-demo.el ends here