;;; 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>
;;; Code:
(defconst wl-demo-copyright-notice
- "Copyright (C) 1998-2001 Yuuichi Teranishi <teranisi@gohome.org>"
+ "Copyright (C) 1998-2008 Yuuichi Teranishi <teranisi@gohome.org>"
"A declaration of the copyright on Wanderlust.")
(eval-when-compile
(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.")
+(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
(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)
(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")))
+ (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"))
+ (concat (wl-demo-icon-name) ".xpm"))
((eq 'bitmap image-type)
- (concat wl-demo-icon-name ".img"))
+ (concat (wl-demo-icon-name) ".img"))
((eq 'xbm image-type)
- (concat wl-demo-icon-name ".xbm"))))
+ (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)))
+ (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))
(cond ((featurep 'xemacs)
(setq width (window-pixel-width)
height (window-pixel-height)
- image (make-glyph (vector image-type ':file file)))
+ 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))
(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)
+ ((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-demo-face)))
+ (fg (face-foreground 'wl-highlight-logo-face)))
(when (stringp bg)
(plist-put (cdr image) ':background bg))
(when (stringp fg)
(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)
(max 0 (/ (1+ (- (window-width)
(current-column)))
2)))
- (put-text-property (point-min) (point-max)
- 'face 'wl-highlight-logo-face)
+ (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)
- (put-text-property (point-min) (point) 'face 'wl-highlight-logo-face)
(unless (bolp)
(insert "\n"))
(setq width 0)
(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")
+ "version %s - \"%s\"\n%s\n")
((eq height 3)
- "version %s - \"%s\"\n\n%s")
+ "version %s - \"%s\"\n\n%s\n")
(t
- "\nversion %s - \"%s\"\n\n%s"))
+ "\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))
(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))
+ (insert text)
(let ((fill-column (window-width)))
(center-region start (point)))))
(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)
projects / elisp / wanderlust.git / blobdiff