lisp/liece-emacs.el

   1 ;;; liece-emacs.el --- FSF Emacs specific routines.
   2 ;; Copyright (C) 1999 Daiki Ueno
   3
   4 ;; Author: Daiki Ueno <ueno@unixuser.org>
   5 ;; Created: 1999-08-21
   6 ;; Keywords: emulation
   7
   8 ;; This file is part of Liece.
   9
  10 ;; This program is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; This program is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25
  26 ;;; Commentary:
  27 ;;
  28
  29 ;;; Code:
  30
  31 (eval-when-compile
  32   (require 'static)
  33   (require 'liece-compat)
  34   (require 'liece-vars))
  35
  36 (eval-when-compile (ignore-errors (require 'image)))
  37
  38 (require 'derived)
  39
  40 (eval-and-compile
  41   (autoload 'bitmap-stipple-xbm-file-to-stipple "bitmap-stipple")
  42   (autoload 'bitmap-stipple-insert-pixmap "bitmap-stipple"))
  43
  44 ;;; @ widget emulation
  45 ;;;
  46 (defvar liece-widget-keymap nil)
  47
  48 (unless liece-widget-keymap
  49   (require 'wid-edit)
  50   (setq liece-widget-keymap (copy-keymap widget-keymap))
  51   (substitute-key-definition
  52    'widget-button-click 'liece-widget-button-click
  53    liece-widget-keymap)
  54   (define-key liece-widget-keymap (if (featurep 'xemacs) 'button3
  55                                     [mouse-3])
  56     'liece-widget-button-click))
  57
  58 (defun liece-emacs-widget-convert-button (type from to &rest args)
  59   (apply 'widget-convert-button type from to args)
  60   (let ((map (copy-keymap liece-widget-keymap)))
  61     (set-keymap-parent map (current-local-map))
  62     (overlay-put (make-overlay from to) 'local-map map)))
  63
  64 (defun liece-emacs-widget-button-click (event)
  65   (interactive "e")
  66   (with-current-buffer
  67       (let ((window (posn-window (event-start event))))
  68         (and (windowp window) (window-buffer window)))
  69     (goto-char (widget-event-point event))
  70     (cond
  71      ((widget-at (point)))
  72      ((> (point) (save-excursion
  73                    (widget-forward 0)
  74                    (point)))
  75       (widget-backward 0))
  76      ((< (point) (save-excursion
  77                    (widget-backward 0)
  78                    (point)))
  79       (widget-forward 0)))
  80     (widget-button-click event)))
  81
  82 (fset 'liece-widget-convert-button
  83       'liece-emacs-widget-convert-button)
  84 (fset 'liece-widget-button-click
  85       'liece-emacs-widget-button-click)
  86
  87 ;;; @ startup splash
  88 ;;;
  89 (defconst liece-splash-image
  90   (eval-when-compile
  91     (cond
  92      ((and (fboundp 'image-type-available-p)
  93            (image-type-available-p 'xpm))
  94       (let ((file (expand-file-name "liece.xpm" default-directory)))
  95         (if (file-exists-p file)
  96             (list 'image
  97                   :type 'xpm
  98                   :data (with-temp-buffer
  99                           (insert-file-contents-as-binary file)
 100                           (buffer-string))))))
 101      ((fboundp 'set-face-stipple)
 102       (let ((file (expand-file-name "liece.xbm" default-directory)))
 103         (if (file-exists-p file)
 104             (bitmap-stipple-xbm-file-to-stipple file)))))))
 105
 106 (defun liece-emacs-splash (&optional arg)
 107   (interactive "P")
 108   (let* ((font (cdr (assq 'font (frame-parameters))))
 109          (liece-insert-environment-version nil)
 110          config buffer pixel-width pixel-height)
 111     (unwind-protect
 112         (progn
 113           (setq config (current-window-configuration))
 114           (save-excursion
 115             (switch-to-buffer (setq buffer (liece-get-buffer-create
 116                                             (concat (if arg "*" " *")
 117                                                     (liece-version) "*"))))
 118             (erase-buffer)
 119             (static-cond
 120              ((and (fboundp 'image-type-available-p)
 121                    (image-type-available-p 'xpm))
 122               (with-temp-buffer
 123                 (insert (plist-get (cdr liece-splash-image) :data))
 124                 (goto-char (point-min))
 125                 (skip-syntax-forward "^\"")
 126                 (when (looking-at "\"[ \t]*\\([0-9]+\\)[ \t]*\\([0-9]+\\)")
 127                   (setq pixel-width (string-to-int (match-string 1))
 128                         pixel-height (string-to-int (match-string 2)))))
 129               (insert (make-string (max 0 (/ (- (frame-height)
 130                                                 (/ pixel-height
 131                                                    (frame-char-height)))
 132                                              2))
 133                                    ?\n)
 134                       (make-string (max 0 (/ (- (frame-width)
 135                                                 (/ pixel-width
 136                                                    (frame-char-width)))
 137                                              2))
 138                                    ?\ ))
 139               (static-if (condition-case nil
 140                              (progn (insert-image '(image)) nil)
 141                            (wrong-number-of-arguments t))
 142                   (insert-image liece-splash-image "x")
 143                 (insert-image liece-splash-image))
 144               (insert "\n"))
 145              (t
 146               (bitmap-stipple-insert-pixmap liece-splash-image 'center)))
 147             (insert "\n")
 148             (insert-char ?\  (max 0 (/ (- (window-width)
 149                                           (length (liece-version)))
 150                                        2)))
 151             (put-text-property (point) (prog2 (insert (liece-version))(point)
 152                                          (insert "\n"))
 153                                'face 'underline))
 154           (or arg (sit-for 2)))
 155       (unless arg
 156         (kill-buffer buffer)
 157         (set-window-configuration config)))))
 158
 159 ;;; @ modeline decoration
 160 ;;;
 161 (defconst liece-mode-line-image nil)
 162
 163 (static-unless (or (not (fboundp 'create-image))
 164                    (memq 'data-p (aref (symbol-function 'create-image) 0)))
 165   (defadvice create-image
 166     (before data-p (file-or-data &optional type data-p &rest props) activate)
 167     (ad-set-args 0 (list (ad-get-arg 0) (ad-get-arg 1) (ad-get-arg 3)))))
 168
 169 (defun liece-emacs-create-mode-line-image ()
 170   (static-when (fboundp 'image-type-available-p)
 171     (let ((file (liece-locate-icon-file
 172                  (static-cond
 173                   ((image-type-available-p 'xpm)
 174                    "liece-pointer.xpm")
 175                   ((image-type-available-p 'xbm)
 176                    "liece-pointer.xbm")))))
 177       (and file (file-exists-p file)
 178            (create-image file nil nil :ascent 99)))))
 179
 180 (defun liece-emacs-mode-line-buffer-identification (line)
 181   (let ((id (copy-sequence (car line))) image)
 182     (if (and (stringp id) (string-match "^Liece:" id)
 183              (setq liece-mode-line-image
 184                    (liece-emacs-create-mode-line-image)))
 185         (progn
 186           (add-text-properties 0 (length id)
 187                                (list 'display
 188                                      liece-mode-line-image
 189                                      'rear-nonsticky (list 'display))
 190                                id)
 191           (setcar line id)))
 192     line))
 193
 194 (fset 'liece-mode-line-buffer-identification
 195       'liece-emacs-mode-line-buffer-identification)
 196
 197 ;;; @ nick buffer decoration
 198 ;;;
 199 (defun liece-emacs-create-nick-image (file)
 200   (static-when (and (fboundp 'image-type-available-p)
 201                     (image-type-available-p 'xpm))
 202     (let ((file (liece-locate-icon-file file)))
 203       (and file (file-exists-p file)
 204            (create-image file nil nil :ascent 99)))))
 205
 206 (defun liece-emacs-nick-image-region (start end)
 207   (save-excursion
 208     (goto-char start)
 209     (beginning-of-line)
 210     (setq start (point))
 211
 212     (goto-char end)
 213     (beginning-of-line 2)
 214     (setq end (point))
 215
 216     (save-restriction
 217       (narrow-to-region start end)
 218       (let ((buffer-read-only nil)
 219             (inhibit-read-only t)
 220             (case-fold-search nil)
 221             mark image)
 222         (dolist (entry liece-nick-image-alist)
 223           (setq mark (car entry)
 224                 image (cdr entry))
 225           (if (stringp image)
 226               (setq image
 227                     (setcdr entry (liece-emacs-create-nick-image image))))
 228           (goto-char start)
 229           (while (not (eobp))
 230             (when (eq (char-after) mark)
 231               (add-text-properties (point) (1+ (point))
 232                                    (list 'display
 233                                          image
 234                                          'rear-nonsticky (list 'display))))
 235             (beginning-of-line 2)))))))
 236
 237 (add-hook 'liece-nick-insert-hook 'liece-emacs-nick-image-region)
 238 (add-hook 'liece-nick-replace-hook 'liece-emacs-nick-image-region)
 239
 240 (and liece-splash-image window-system
 241      (liece-emacs-splash))
 242
 243 (provide 'liece-emacs)
 244
 245 ;;; liece-emacs.el ends here