navi2ch-splash.el

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