;;; 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).
;;
;;; Commentary:
-;;
+;;
;;; Code:
-;;
+;;
+
+(defconst wl-demo-copyright-notice
+ "Copyright (C) 1998-2001 Yuuichi Teranishi <teranisi@gohome.org>")
(require 'wl-vars)
-(provide 'wl-demo)
-(if (featurep 'xemacs)
- (require 'wl-xmas))
+(require 'wl-version)
+(require 'wl-highlight)
+(defconst wl-demo-icon-name (concat "wl-" (wl-version-status) "-logo"))
+
+;; Avoid byte compile warnings.
(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))))
+ (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 ;-)
;;
+
+(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")
+
(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)))
- (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))
+ (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-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))))))))
+
+(let ((xpm (wl-logo-xpm)))
+ (if (and xpm (or (and (featurep 'xemacs)
+ (featurep 'xpm))
+ (and (condition-case nil (require 'image) (error nil))
+ (image-type-available-p 'xpm))))
+ (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)))
+ (create-image (nth 2 xpm) 'xpm t))))))
+
+(let ((xbm (wl-logo-xbm))
+ (bm (wl-logo-bitmap)))
+ (if (and xbm (or (featurep 'xemacs)
+ (featurep 'image)
+ (condition-case nil (require 'bitmap) (error nil))))
+ (progn
+ (put 'wl-logo-xbm 'width (car xbm))
+ (put 'wl-logo-xbm 'height (nth 1 xbm))
+ (put 'wl-logo-xbm 'image
+ (cond
+ ((featurep 'xemacs)
+ (make-glyph (vector 'xbm ':data xbm)))
+ ((featurep 'image)
+ (create-image (nth 2 xbm) 'xbm t
+ ':width (car xbm) ':height (nth 1 xbm)))
+ (t
+ (let ((default-enable-multibyte-characters t)
+ (default-mc-flag t))
+ (with-temp-buffer
+ (let* ((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)
- (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)
+ (insert "\n" (bitmap-compose (aref cmp i)))
+ (setq i (1+ i)))
+ (buffer-string))))))))))
+
+(defun wl-demo (&optional image-type)
+ "Demo on the startup screen.
+Optional IMAGE-TYPE overrides the variable `wl-demo-display-logo'."
+ (interactive "P")
+ (if (and image-type (interactive-p))
+ (let* ((selection (append
+ (if (and (get 'wl-logo-xbm 'width)
+ (cond ((featurep 'xemacs)
+ (device-on-window-system-p))
+ (wl-on-emacs21
+ (display-graphic-p))
+ (t window-system)))
+ '(("xbm" . xbm)))
+ (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)
+ (featurep 'image)
+ (image-type-available-p 'xpm))))
+ '(("xpm" . xpm)))
+ '(("ascii"))))
+ (type (completing-read "Image type: " selection nil t)))
+ (setq image-type (if (assoc type selection)
+ (cdr (assoc type selection)))))
+ (setq image-type (or image-type wl-demo-display-logo)))
+ (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)
(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)
- (let ((fill-column (window-width)))
- (center-region start (point)))
- (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))
+ (setq truncate-lines t)
+ (cond ((featurep 'xemacs)
+ (if (device-on-window-system-p)
+ (progn
+ (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))))
+ ((and wl-on-emacs21 (display-graphic-p))
+ (make-local-hook 'kill-buffer-hook)
+ (let* ((frame (selected-frame))
+ (toolbar (frame-parameter frame 'tool-bar-lines)))
+ (modify-frame-parameters frame '((tool-bar-lines)))
+ (add-hook
+ 'kill-buffer-hook
+ (` (lambda ()
+ (let ((frame (, frame)))
+ (when (frame-live-p frame)
+ (, (if (and toolbar (> toolbar 0))
+ (` (modify-frame-parameters
+ frame '((tool-bar-lines . (, toolbar)))))))
+ (set-face-background
+ 'fringe (, (face-background 'fringe frame)) frame)))))
+ nil t)
+ (set-face-background 'fringe (face-background 'default frame)
+ frame))))
+ (let ((logo (cond ((eq 'xbm image-type)
+ (if (and (get 'wl-logo-xbm 'width)
+ (cond ((featurep 'xemacs)
+ (device-on-window-system-p))
+ (wl-on-emacs21
+ (display-graphic-p))
+ (t window-system)))
+ 'wl-logo-xbm))
+ ((eq 'xpm image-type)
+ (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)
+ (featurep 'image)
+ (image-type-available-p 'xpm))))
+ 'wl-logo-xpm))))
+ (ww (window-width))
+ (wh (window-height))
+ rest)
+ (if logo
+ (let ((lw (get logo 'width))
+ (lh (get logo 'height))
+ (image (get logo 'image)))
+ (cond
+ ((featurep 'xemacs)
+ (if (eq 'wl-logo-xbm logo)
+ (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))
+ (if (eq 'wl-logo-xbm logo)
+ (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)))
+
+(require 'product)
+(product-provide (provide 'wl-demo) (require 'wl-version))
;;; wl-demo.el ends here
projects / elisp / wanderlust.git / blobdiff