X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=wl%2Fwl-demo.el;h=c2936802e8f3a46e0a37f45ba0e093e7b170419e;hb=7cbfe0393431e873e6679ba985a7c8b646982cf7;hp=b35a2b0051f40937c0d721c189bbdd9ed74508fc;hpb=f06d37bb4a8afabaa570ce4272f301b7a5154507;p=elisp%2Fwanderlust.git diff --git a/wl/wl-demo.el b/wl/wl-demo.el index b35a2b0..c293680 100644 --- a/wl/wl-demo.el +++ b/wl/wl-demo.el @@ -1,7 +1,9 @@ ;;; wl-demo.el --- Opening demo on Wanderlust -;; Copyright (C) 1998,1999,2000,2001 Yuuichi Teranishi -;; Copyright (C) 2000,2001 Katsumi Yamaoka +;; Copyright (C) 1998,1999,2000,2001,2002,2003,2004 +;; Yuuichi Teranishi +;; Copyright (C) 2000,2001,2004 +;; Katsumi Yamaoka ;; Author: Yuuichi Teranishi ;; Katsumi Yamaoka @@ -29,7 +31,7 @@ ;;; Code: (defconst wl-demo-copyright-notice - "Copyright (C) 1998-2001 Yuuichi Teranishi " + "Copyright (C) 1998-2012 Yuuichi Teranishi " "A declaration of the copyright on Wanderlust.") (eval-when-compile @@ -39,13 +41,12 @@ (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-5]\\)" - (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 @@ -79,6 +80,7 @@ Yet Another Message Interface On Emacsen" (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) @@ -129,23 +131,40 @@ Yet Another Message Interface On Emacsen" (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)) @@ -163,12 +182,18 @@ Return a number of lines that an image occupies in the buffer." (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)) - (window-width)) width) - (* 2 width)))) + (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) @@ -178,12 +203,14 @@ Return a number of lines that an image occupies in the buffer." (and (eq 'xbm image-type) (image-type-available-p 'xbm)))) ;; Use the new redisplay engine on Emacs 21. - (setq image (create-image file image-type) + (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-logo-face)) + (let ((bg (face-background 'wl-highlight-demo-face)) (fg (face-foreground 'wl-highlight-logo-face))) (when (stringp bg) (plist-put (cdr image) ':background bg)) @@ -206,11 +233,20 @@ Return a number of lines that an image occupies in the buffer." (goto-char (point-max)) (unless (bolp) (insert "\n")) - (setq width 0) + + ;; 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 (max width (current-column)))) + (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 @@ -232,8 +268,7 @@ Return a number of lines that an image occupies in the buffer." (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) - 'face 'wl-highlight-logo-face) + (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...") @@ -244,12 +279,10 @@ Return a number of lines that an image occupies in the buffer." (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) @@ -259,18 +292,73 @@ Return a number of lines that an image occupies in the buffer." (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)) @@ -278,17 +366,7 @@ should be a number of lines that an image occupies in the buffer." (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))))) @@ -322,6 +400,7 @@ argument." (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) @@ -329,6 +408,17 @@ argument." 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))