1;;; navi2ch-splash.el --- Navigator for 2ch for Emacsen -*- coding: iso-2022-7bit; -*- 2 3;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Navi2ch 4;; Project 5 6;; Author: UEYAMA Rui <rui314159@users.sourceforge.net> 7;; 110 $B$NL>L5$7$5$s(B http://pc.2ch.net/test/read.cgi/unix/1013457056/110 8;; 9;; Keywords: network, 2ch 10 11;; This file is free software; you can redistribute it and/or modify 12;; it under the terms of the GNU General Public License as published by 13;; the Free Software Foundation; either version 2, or (at your option) 14;; any later version. 15 16;; This file is distributed in the hope that it will be useful, 17;; but WITHOUT ANY WARRANTY; without even the implied warranty of 18;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 19;; GNU General Public License for more details. 20 21;; You should have received a copy of the GNU General Public License 22;; along with GNU Emacs; see the file COPYING. If not, write to 23;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, 24;; Boston, MA 02111-1307, USA. 25 26;;; Commentary: 27 28;; $B%3!<%I$O!"(BWanderlust $B$N(B wl-demo.el $B$+$i$b$i$$$^$7$?!#$[$H$s$I(B 29;; $BJQ$o$C$F$J$$$G$9!#(B 30;; 31;;; wl-demo.el --- Opening demo on Wanderlust 32;; 33;; Copyright (C) 1998,1999,2000,2001 Yuuichi Teranishi <teranisi@gohome.org> 34;; Copyright (C) 2000,2001 Katsumi Yamaoka <yamaoka@jpl.org> 35 36;;; Code: 37(provide 'navi2ch-splash) 38(defconst navi2ch-splash-ident 39 "$Id$") 40 41(eval-when-compile 42 (require 'cl)) 43(require 'navi2ch-vars) 44(require 'navi2ch-face) 45(require 'navi2ch-util) 46(require 'navi2ch-version) 47 48(defconst navi2ch-splash-copyright-notice 49 (concat "Copyright (C) 2000-2008 Navi2ch Project. 50This software includes some fragments from other softwares; 51Copyright (C) 1993-2000 Free Software Foundation, Inc. 52Copyright (C) 1998-2001 Yuuichi Teranishi <teranisi@gohome.org> 53Copyright (C) 2000,2001 Katsumi Yamaoka <yamaoka@jpl.org>\n" 54 (substitute-command-keys " 55Navi2ch comes with ABSOLUTELY NO WARRANTY; type \\[describe-no-warranty] for full details.")) 56 "A declaration of the copyright on Navi2ch.") 57 58(defconst navi2ch-splash-logo-image-name 59 "navi2ch-logo" 60 "Basename of the logo file.") 61 62;; $B$3$l$O$5$9$,$K:9$7$+$($J$$$H!D!D(B 63(defvar navi2ch-splash-logo-ascii "\ 64$B!!!!"#!!!!!!!!"#"#!!!!!!!!!!!!!!!!!!!!!!!!!!"#"#!!!!!!!!"#!!!!(B 65$B!!"#!!!!!!!!"#!!!!!!!!!!!!!!"#"#"#"#!!!!!!!!!!!!"#!!!!!!!!"#!!(B 66$B"#!!!!!!!!!!!!!!!!!!!!!!!!!!"#!!!!"#!!!!!!!!!!!!!!!!!!!!!!!!"#(B 67$B"#!!!!!!!!!!!!!!!!!!!!!!!!!!"#!!!!"#!!!!!!!!!!!!!!!!!!!!!!!!"#(B 68$B"#!!!!!!!!!!!!!!!!!!!!!!!!!!"#!!!!"#!!!!!!!!!!!!!!!!!!!!!!!!"#(B 69$B"#!!!!!!!!!!!!!!!!!!!!!!!!!!"#!!!!"#!!!!!!!!!!!!!!!!!!!!!!!!"#(B 70$B"#!!!!!!!!!!!!!!!!!!!!!!!!"#!!!!!!"#!!!!!!!!!!!!!!!!!!!!!!!!"#(B 71$B!!"#!!!!!!!!!!!!!!!!!!!!"#"#"#"#"#"#"#!!!!!!!!!!!!!!!!!!!!"#!!(B 72$B!!!!"#!!!!!!!!!!!!!!!!!!"#!!!!!!!!!!"#!!!!!!!!!!!!!!!!!!"#!!!!(B 73 74 Navi2ch" 75 "Ascii picture used to splash the startup screen.") 76 77(eval-when-compile 78 (when navi2ch-on-emacs21 79 ;; `display-images-p' has not been available in Emacs versions 80 ;; prior to Emacs 21.0.105. 81 (navi2ch-defalias-maybe 'display-images-p 'display-graphic-p))) 82 83;; Avoid byte compile warnings. 84(eval-when-compile 85 (autoload 'bitmap-insert-xbm-file "bitmap" nil t) 86 (autoload 'create-image "image") 87 (autoload 'device-on-window-system-p "device") 88 (autoload 'image-type-available-p "image") 89 (autoload 'insert-image "image") 90 (autoload 'make-glyph "glyphs") 91 (autoload 'set-glyph-face "glyphs") 92 (autoload 'set-specifier "specifier") 93 (navi2ch-defalias-maybe 'frame-char-height 'ignore) 94 (navi2ch-defalias-maybe 'frame-char-width 'ignore) 95 (navi2ch-defalias-maybe 'glyph-height 'ignore) 96 (navi2ch-defalias-maybe 'glyph-width 'ignore) 97 (navi2ch-defalias-maybe 'image-size 'ignore) 98 (navi2ch-defalias-maybe 'make-extent 'ignore) 99 (navi2ch-defalias-maybe 'set-extent-end-glyph 'ignore) 100 (navi2ch-defalias-maybe 'window-pixel-height 'ignore) 101 (navi2ch-defalias-maybe 'window-pixel-width 'ignore)) 102 103(defvar navi2ch-splash-bitmap-mule-available-p 'unknown 104 "Internal variable to say whether the BITMAP-MULE package is available.") 105 106(defun navi2ch-splash-image-type-alist () 107 "Return an alist of available logo image types on the current frame." 108 (if (or (and (featurep 'xemacs) 109 (device-on-window-system-p)) 110 window-system) 111 (let ((xpm 112 (when (or (and (featurep 'xemacs) 113 (featurep 'xpm)) 114 (and navi2ch-on-emacs21 115 (display-images-p) 116 (image-type-available-p 'xpm))) 117 '("xpm" . xpm))) 118 (xbm 119 (when (or (featurep 'xemacs) 120 (and navi2ch-on-emacs21 121 (display-images-p) 122 (image-type-available-p 'xbm)) 123 (eq t navi2ch-splash-bitmap-mule-available-p) 124 (and (eq 'unknown navi2ch-splash-bitmap-mule-available-p) 125 (or (featurep 'bitmap) 126 (locate-library "bitmap")) 127 (setq navi2ch-splash-bitmap-mule-available-p t))) 128 '("xbm" . xbm))) 129 (bitmap 130 (when (and (not (featurep 'xemacs)) 131 (or (eq t navi2ch-splash-bitmap-mule-available-p) 132 (and (eq 'unknown navi2ch-splash-bitmap-mule-available-p) 133 (or (featurep 'bitmap) 134 (locate-library "bitmap")) 135 (setq navi2ch-splash-bitmap-mule-available-p t)))) 136 '("bitmap" . bitmap)))) 137 (if (and navi2ch-on-emacs21 138 (image-type-available-p 'xbm)) 139 ;; Prefer xbm rather than bitmap on Emacs 21. 140 (delq nil (list xbm bitmap xpm '("ascii"))) 141 (delq nil (list bitmap xbm xpm '("ascii"))))) 142 '(("ascii")))) 143 144(defun navi2ch-splash-insert-image (image-type) 145 "Insert a logo image at the point and position it to be centered. 146IMAGE-TYPE specifies what a type of image should be displayed. 147Return a number of lines that an image occupies in the buffer." 148 (let ((file (cond ((eq 'xpm image-type) 149 (concat navi2ch-splash-logo-image-name ".xpm")) 150 ((eq 'bitmap image-type) 151 (concat navi2ch-splash-logo-image-name ".img")) 152 ((eq 'xbm image-type) 153 (concat navi2ch-splash-logo-image-name ".xbm")))) 154 image width height) 155 (when (featurep 'xemacs) 156 (when (boundp 'default-gutter-visible-p) 157 (set-specifier (symbol-value 'default-gutter-visible-p) 158 nil (current-buffer))) 159 (set-specifier (symbol-value 'scrollbar-height) 0 (current-buffer)) 160 (set-specifier (symbol-value 'scrollbar-width) 0 (current-buffer))) 161 (if (and file 162 (if (and navi2ch-icon-directory 163 (file-directory-p navi2ch-icon-directory)) 164 (setq file (expand-file-name file navi2ch-icon-directory)) 165 (message "You have to specify the value of `navi2ch-icon-directory'") 166 nil) 167 (if (file-exists-p file) 168 (if (file-readable-p file) 169 t 170 (message "Permission denied: %s" file) 171 nil) 172 (message "File not found: %s" file) 173 nil)) 174 (progn 175 (cond ((featurep 'xemacs) 176 (setq width (window-pixel-width) 177 height (window-pixel-height) 178 image (make-glyph (vector image-type ':file file))) 179 (when (eq 'xbm image-type) 180 (set-glyph-face image 'navi2ch-splash-screen-face)) 181 (insert-char ?\ (max 0 (/ (+ (* (- width (glyph-width image)) 182 (window-width)) width) 183 (* 2 width)))) 184 (set-extent-end-glyph (make-extent (point) (point)) image) 185 (insert "\n") 186 (/ (+ (* 2 (glyph-height image) (window-height)) height) 187 (* 2 height))) 188 ((and navi2ch-on-emacs21 189 (or (eq 'xpm image-type) 190 (and (eq 'xbm image-type) 191 (image-type-available-p 'xbm)))) 192 ;; Use the new redisplay engine on Emacs 21. 193 (setq image (create-image file image-type) 194 width (image-size image) 195 height (cdr width) 196 width (car width)) 197 (when (eq 'xbm image-type) 198 (let ((bg (face-background 'navi2ch-splash-screen-face)) 199 (fg (face-foreground 'navi2ch-splash-screen-face))) 200 (when (stringp bg) 201 (plist-put (cdr image) ':background bg)) 202 (when (stringp fg) 203 (plist-put (cdr image) ':foreground fg)))) 204 (insert (navi2ch-propertize " " 'display 205 (list 'space ':align-to 206 (max 0 (round (- (window-width) 207 width) 208 2))))) 209 (insert-image image) 210 (insert "\n") 211 (round height)) 212 ((eq 'bitmap image-type) 213 ;; Use ready-composed bitmap image. 214 (require 'bitmap) 215 (let ((coding-system-for-read 'iso-2022-7bit)) 216 (insert-file-contents file)) 217 (goto-char (point-max)) 218 (unless (bolp) 219 (insert "\n")) 220 (setq width 0) 221 (while (progn 222 (end-of-line 0) 223 (not (bobp))) 224 (setq width (max width (current-column)))) 225 ;; Emacs 21.1 would fail to decode composite chars 226 ;; if it has been built without fixing coding.c. 227 (when (and navi2ch-on-emacs21 228 (>= width 80)) 229 (erase-buffer) 230 (let ((coding-system-for-read 'raw-text)) 231 (insert-file-contents file)) 232 (goto-char (point-max)) 233 (unless (bolp) 234 (insert "\n")) 235 (setq width 0) 236 (while (progn 237 (end-of-line 0) 238 (not (bobp))) 239 ;; Decode bitmap data line by line. 240 (decode-coding-region (navi2ch-line-beginning-position) 241 (point) 242 'iso-2022-7bit) 243 (setq width (max width (current-column))))) 244 (indent-rigidly (point-min) (point-max) 245 (max 0 (/ (1+ (- (window-width) width)) 2))) 246 (put-text-property (point-min) (point-max) 247 'face 'navi2ch-splash-screen-face) 248 (count-lines (point-min) (goto-char (point-max)))) 249 ((eq 'xbm image-type) 250 (message "Composing a bitmap image...") 251 (require 'bitmap) 252 (bitmap-insert-xbm-file file) 253 (backward-char) 254 (indent-rigidly (point-min) (point-max) 255 (max 0 (/ (1+ (- (window-width) 256 (current-column))) 257 2))) 258 (put-text-property (point-min) (point-max) 259 'face 'navi2ch-splash-screen-face) 260 (message "Composing a bitmap image...done") 261 (count-lines (point-min) (goto-char (point-max)))))) 262 (insert navi2ch-splash-logo-ascii) 263 (put-text-property (point-min) (point) 'face 'navi2ch-splash-screen-face) 264 (unless (bolp) 265 (insert "\n")) 266 (setq width 0) 267 (while (progn 268 (end-of-line 0) 269 (not (bobp))) 270 (setq width (max width (current-column)))) 271 (indent-rigidly (point-min) (point-max) 272 (max 0 (/ (1+ (- (window-width) width)) 2))) 273 (count-lines (point-min) (goto-char (point-max)))))) 274 275(defun navi2ch-splash-insert-text (height) 276 "Insert a version and the copyright message after a logo image. 277HEIGHT should be a number of lines that an image occupies in the buffer." 278 (let* ((height (- (window-height) height 1)) 279 (notice-height (length (split-string navi2ch-splash-copyright-notice 280 "\n"))) 281 (text (format (cond ((<= (- height notice-height) 1) 282 "version %s - \"%s\"\n%s") 283 ((eq (- height notice-height) 2) 284 "version %s - \"%s\"\n\n%s") 285 (t 286 "\nversion %s - \"%s\"\n\n%s")) 287 navi2ch-version 288 "$B%*%^%(%b%J!<(B" 289 navi2ch-splash-copyright-notice)) 290 (text-height (length (split-string text "\n"))) 291 start) 292 (goto-char (point-min)) 293 (insert-char ?\n (max 0 (/ (- height text-height) 2))) 294 (setq start (goto-char (point-max))) 295 (if navi2ch-on-emacs21 296 (let ((bg (face-background 'navi2ch-splash-screen-face)) 297 (fg (face-foreground 'navi2ch-splash-screen-face))) 298 (insert (navi2ch-propertize text 299 'face (nconc '(variable-pitch :slant oblique) 300 (when (stringp bg) 301 (list ':background bg)) 302 (when (stringp fg) 303 (list ':foreground fg)))))) 304 (insert text) 305 (put-text-property start (point) 'face 'navi2ch-splash-screen-face)) 306 (let ((fill-column (window-width))) 307 (center-region start (point))))) 308 309;; shut up XEmacs warnings 310(eval-when-compile 311 (defvar default-enable-multibyte-characters) 312 (defvar default-mc-flag) 313 (defvar default-line-spacing)) 314 315(defun navi2ch-splash (&optional image-type) 316 "Demo on the startup screen. 317IMAGE-TYPE should be a symbol which overrides the variable 318`navi2ch-splash-display-logo'. It will prompt user for the type 319of image when it is called interactively with a prefix argument." 320 (interactive "P") 321 (let ((selection (navi2ch-splash-image-type-alist)) 322 type) 323 (if (and image-type (interactive-p)) 324 (setq type (completing-read "Image type: " selection nil t) 325 image-type (when (assoc type selection) 326 (cdr (assoc type selection)))) 327 (if (setq type (assoc (format "%s" (or image-type navi2ch-splash-display-logo)) 328 selection)) 329 (setq image-type (cdr type)) 330 (setq image-type (when navi2ch-splash-display-logo 331 (cdr (car selection))))))) 332 (let ((buffer (let ((default-enable-multibyte-characters t) 333 (default-mc-flag t) 334 (default-line-spacing 0)) 335 (get-buffer-create "*navi2ch splash*")))) 336 (switch-to-buffer buffer) 337 (setq buffer-read-only nil) 338 (buffer-disable-undo) 339 (erase-buffer) 340 (setq truncate-lines t 341 tab-width 8) 342 (set (make-local-variable 'tab-stop-list) 343 '(8 16 24 32 40 48 56 64 72 80 88 96 104 112 120)) 344 (navi2ch-splash-insert-text (navi2ch-splash-insert-image image-type)) 345 (set-buffer-modified-p nil) 346 (goto-char (point-min)) 347 (sit-for (if (featurep 'lisp-float-type) 348 (/ (float 5) (float 10)) 349 1)) 350 buffer)) 351 352;;; navi2ch-splash.el ends here 353