;;; 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
;; This file is part of Wanderlust (Yet Another Message Interface on Emacsen).
;;
(defconst wl-demo-copyright-notice
- "Copyright (C) 1998-2000 Yuuichi Teranishi <teranisi@gohome.org>")
+ "Copyright (C) 1998-2001 Yuuichi Teranishi <teranisi@gohome.org>")
(require 'wl-vars)
(require 'wl-version)
(require 'wl-highlight)
-(require 'product)
-(product-provide (provide 'wl-demo) (require 'wl-version))
(defconst wl-demo-icon-name (concat "wl-" (wl-version-status) "-logo"))
(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 'tool-bar-mode 'ignore)
(defalias-maybe 'window-pixel-height 'ignore)
(defalias-maybe 'window-pixel-width 'ignore))
(eval-when-compile
(defmacro wl-logo-xpm ()
;; (WIDTH HEIGHT DATA)
- (let ((file (expand-file-name
- (concat wl-demo-icon-name ".xpm")
- wl-icon-dir)))
+ (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
(buffer-string))))))
(defmacro wl-logo-xbm ()
;; (WIDTH HEIGHT DATA)
- (let ((file (expand-file-name
- (concat wl-demo-icon-name ".xbm")
- wl-icon-dir)))
+ (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)
(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)))
+ (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))))
+ (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)))
- (create-image (nth 2 xpm) 'xpm t))))))
+ (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)))))))
-(let ((xbm (wl-logo-xbm))
- (bm (wl-logo-bitmap)))
- (if (and xbm (or (featurep 'xemacs)
- (featurep 'image)
- (condition-case nil (require 'bitmap) (error nil))))
+(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-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)
- (insert "\n" (bitmap-compose (aref cmp i)))
- (setq i (1+ i)))
- (buffer-string))))))))))
+ (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))))))))
+
+(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)
+ (image-type-available-p 'xbm))))
+ '(("xbm" . xbm)))
+ (if (and (get 'wl-logo-bitmap 'width)
+ (not (featurep 'xemacs))
+ window-system
+ (featurep 'bitmap))
+ '(("bitmap" . bitmap)))
+ '(("ascii")))))
(defun wl-demo (&optional image-type)
"Demo on the startup screen.
Optional IMAGE-TYPE overrides the variable `wl-demo-display-logo'."
(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))))
+ (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)
+ (erase-buffer)
+ (setq truncate-lines t)
(cond ((featurep 'xemacs)
(if (device-on-window-system-p)
(progn
nil demo-buf))
(set-specifier (symbol-value 'scrollbar-height) 0 demo-buf)
(set-specifier (symbol-value 'scrollbar-width) 0 demo-buf))))
- ((and (> emacs-major-version 20) (display-graphic-p))
+ ((and wl-on-emacs21
+ (display-graphic-p))
(make-local-hook 'kill-buffer-hook)
(let* ((frame (selected-frame))
(toolbar (frame-parameter frame 'tool-bar-lines)))
nil t)
(set-face-background 'fringe (face-background 'default frame)
frame))))
- (erase-buffer)
- (setq truncate-lines t)
- (let* ((wl-demo-display-logo
- (if (and image-type (interactive-p))
- (let* ((selection '(("xbm" . xbm) ("xpm" . xpm) ("ascii")))
- (type (completing-read "Image type: " selection nil t)))
- (if (assoc type selection)
- (cdr (assoc type selection))
- t))
- (or image-type wl-demo-display-logo)))
- (logo (if (cond ((featurep 'xemacs)
- (device-on-window-system-p))
- ((featurep 'image)
- (display-graphic-p))
- (t window-system))
- (cond ((and (eq 'xbm wl-demo-display-logo)
- (get 'wl-logo-xbm 'width))
- 'wl-logo-xbm)
- (wl-demo-display-logo
- (cond ((get 'wl-logo-xpm 'width)
- 'wl-logo-xpm)
- ((get 'wl-logo-xbm 'width)
- 'wl-logo-xbm))))))
- (ww (window-width))
- (wh (window-height))
- rest)
- (if logo
- (let ((lw (get logo 'width))
- (lh (get logo 'height))
- (image (get logo 'image)))
+ (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 logo)
+ (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))))
(* lw ww))
2 (window-pixel-width))))
(set-extent-end-glyph (make-extent (point) (point)) image))
- ((featurep 'image)
- (if (eq 'wl-logo-xbm logo)
+ ((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) ':foreground fg))))
(setq rest (/ (- (* wh (frame-char-height)) lh 1)
(frame-char-height)))
- (insert-char ?\ (max 0 (/ (- (* (frame-char-width) (1+ ww)) lw)
- 2 (frame-char-width))))
+ (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)
(insert-char ?\n (max 0 (/ (- rest 4) 2)))
(goto-char (point-max))
(insert "\n")
- (let ((start (point)))
- (insert (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))
- (put-text-property start (point) 'face 'wl-highlight-demo-face)
+ (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