-;;; 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,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>
;; 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).
;; 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-2011 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)
+
+(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
+ 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 '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))
+
+(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)
+ (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"))))
+
+(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)
- (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
+ (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 (string-to-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))))
+ ;; 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)))
+ (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)
+ (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))
+ (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))
- ;;(if (featurep 'xemacs) (delete-extent logo-ext))
- demo-buf))
+ (sit-for (if (featurep 'lisp-float-type)
+ (/ (float 5) (float 10))
+ 1))
+ buffer))
+
+;; Prune functions provided temporarily to avoid compile warnings.
+(eval-when-compile
+ (dolist (fn '(face-background-name
+ frame-char-height frame-char-width glyph-height glyph-width
+ image-size make-extent propertize set-extent-end-glyph
+ window-pixel-height window-pixel-width))
+ (when (and (get fn 'defalias-maybe)
+ (eq (symbol-function fn) 'ignore))
+ (put fn 'defalias-maybe nil)
+ (fmakunbound fn))))
+
+(require 'product)
+(product-provide (provide 'wl-demo) (require 'wl-version))
;;; wl-demo.el ends here
projects / elisp / wanderlust.git / blobdiff