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 'liece-compat)
  33   (require 'liece-vars)
  34   (require 'liece-misc))
  35
  36 (eval-when-compile (require 'cl))
  37 (eval-when-compile (ignore-errors (require 'image)))
  38
  39 (require 'derived)
  40
  41 (eval-and-compile
  42   (autoload 'bitmap-stipple-xbm-file-to-stipple "bitmap-stipple")
  43   (autoload 'bitmap-stipple-insert-pixmap "bitmap-stipple"))
  44
  45 ;;; @ widget emulation
  46 ;;;
  47 (defvar liece-widget-keymap nil)
  48
  49 (unless liece-widget-keymap
  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 [mouse-3]
  55     'liece-widget-button-click))
  56
  57 (defun liece-emacs-widget-convert-button (type from to &rest args)
  58   (apply 'widget-convert-button type from to args)
  59   (let ((map (copy-keymap liece-widget-keymap)))
  60     (set-keymap-parent map (current-local-map))
  61     (overlay-put (make-overlay from to) 'local-map map)))
  62
  63 (defun liece-emacs-widget-button-click (event)
  64   (interactive "e")
  65   (let* ((window (posn-window (event-start event)))
  66          (point (window-point window))
  67          (buffer (window-buffer window)))
  68     (with-current-buffer buffer
  69       (unwind-protect
  70           (progn
  71             (goto-char (widget-event-point event))
  72             (cond
  73              ((widget-at (point)))
  74              ((> (point) (save-excursion
  75                            (widget-forward 0)
  76                            (point)))
  77               (widget-backward 0))
  78              ((< (point) (save-excursion
  79                            (widget-backward 0)
  80                            (point)))
  81               (widget-forward 0)))
  82             (call-interactively (function widget-button-click)))
  83         (if (windowp (setq window (get-buffer-window buffer)))
  84             (set-window-point window point))))))
  85
  86 (fset 'liece-widget-convert-button
  87       'liece-emacs-widget-convert-button)
  88 (fset 'liece-widget-button-click
  89       'liece-emacs-widget-button-click)
  90
  91 ;;; @ startup splash
  92 ;;;
  93 (defvar liece-splash-image
  94   (eval-when-compile
  95     (let ((file (expand-file-name "liece.xpm" default-directory)))
  96       (if (file-exists-p file)
  97           (with-temp-buffer
  98             (insert-file-contents file)
  99             (buffer-string))))))
 100
 101 (defun liece-emacs-splash-with-image ()
 102   (or (eq (car-safe liece-splash-image) 'image)
 103       (setq liece-splash-image
 104             (create-image liece-splash-image 'xpm 'data)))
 105   (setq cursor-type nil)
 106   (when liece-splash-image
 107     (let ((image-size (image-size liece-splash-image)))
 108       (insert (make-string (max 0 (/ (- (window-height)
 109                                         (floor (cdr image-size)))
 110                                      2))
 111                            ?\n))
 112       (make-string (max 0 (/ (- (window-width)
 113                                 (floor (car image-size)))
 114                              2))
 115                    ?\ )
 116       (insert-image liece-splash-image))))
 117
 118 (defun liece-emacs-splash-with-stipple ()
 119   (bitmap-stipple-insert-pixmap
 120    (eval-when-compile
 121      (let ((file (expand-file-name "liece.xbm" default-directory)))
 122        (if (file-exists-p file)
 123            (bitmap-stipple-xbm-file-to-stipple file))))
 124    'center))
 125
 126 (defvar liece-splash-buffer nil)
 127
 128 (defvar liece-emacs-splash-function nil)
 129
 130 (defun liece-emacs-splash (&optional arg)
 131   (interactive "P")
 132   (unless (and liece-splash-buffer (buffer-live-p liece-splash-buffer))
 133     (let ((liece-insert-environment-version nil))
 134       (save-excursion
 135         (setq liece-splash-buffer (generate-new-buffer
 136                                    (concat (if arg "*" " *")
 137                                            (liece-version) "*")))
 138         (push liece-splash-buffer liece-buffer-list)
 139         (set-buffer liece-splash-buffer)
 140         (erase-buffer)
 141         (funcall liece-emacs-splash-function)
 142         (insert-char ?\  (max 0 (/ (- (window-width)
 143                                       (length (liece-version)))
 144                                    2)))
 145         (put-text-property (point) (prog2 (insert (liece-version))(point)
 146                                      (insert "\n"))
 147                            'face 'underline))))
 148   (if arg
 149       (switch-to-buffer liece-splash-buffer)
 150     (save-window-excursion
 151       (switch-to-buffer liece-splash-buffer)
 152       (sit-for 2))))
 153
 154 ;;; @ modeline decoration
 155 ;;;
 156 (defvar liece-mode-line-image nil)
 157
 158 (defun liece-emacs-create-mode-line-image ()
 159   (let ((file (liece-locate-icon-file "liece-pointer.xpm")))
 160     (if (file-exists-p file)
 161         (create-image file nil nil :ascent 99))))
 162
 163 (defun liece-emacs-mode-line-buffer-identification (line)
 164   (let ((id (copy-sequence (car line))) image)
 165       (or liece-mode-line-image
 166           (setq liece-mode-line-image (liece-emacs-create-mode-line-image)))
 167       (when (and liece-mode-line-image
 168                  (stringp id) (string-match "^Liece:" id))
 169         (add-text-properties 0 (length id)
 170                              (list 'display
 171                                    liece-mode-line-image
 172                                    'rear-nonsticky (list 'display))
 173                              id)
 174         (setcar line id))
 175       line))
 176
 177 ;;; @ nick buffer decoration
 178 ;;;
 179 (defun liece-emacs-create-nick-image (file)
 180   (let ((file (liece-locate-icon-file file)))
 181     (if (file-exists-p file)
 182         (create-image file nil nil :ascent 99))))
 183
 184 (defun liece-emacs-nick-image-region (start end)
 185   (save-excursion
 186     (goto-char start)
 187     (beginning-of-line)
 188     (setq start (point))
 189
 190     (goto-char end)
 191     (beginning-of-line 2)
 192     (setq end (point))
 193
 194     (save-restriction
 195       (narrow-to-region start end)
 196       (let ((buffer-read-only nil)
 197             (inhibit-read-only t)
 198             (case-fold-search nil)
 199             mark image)
 200         (dolist (entry liece-nick-image-alist)
 201           (setq mark (car entry)
 202                 image (cdr entry))
 203           (if (stringp image)
 204               (setq image
 205                     (setcdr entry (liece-emacs-create-nick-image image))))
 206           (goto-char start)
 207           (while (not (eobp))
 208             (when (eq (char-after) mark)
 209               (add-text-properties (point) (1+ (point))
 210                                    (list 'display
 211                                          image
 212                                          'rear-nonsticky (list 'display))))
 213             (beginning-of-line 2)))))))
 214
 215 ;;; @ unread mark
 216 ;;;
 217 (defun liece-emacs-unread-mark (chnl)
 218   (if liece-display-unread-mark
 219       (with-current-buffer liece-channel-list-buffer
 220         (let ((buffer-read-only nil))
 221           (goto-char (point-min))
 222           (when (re-search-forward (concat "^ ?[0-9]+: " chnl "$") nil t)
 223             (goto-char (match-end 0))
 224             (insert (concat " " liece-channel-unread-character)))))))
 225
 226 (defun liece-emacs-read-mark (chnl)
 227   (if liece-display-unread-mark
 228       (with-current-buffer liece-channel-list-buffer
 229         (let ((buffer-read-only nil))
 230           (goto-char (point-min))
 231           (when (re-search-forward
 232                  (concat "^ ?[0-9]+: " chnl " "
 233                          liece-channel-unread-character "$") nil t)
 234             (goto-char (- (match-end 0) 2))
 235             (delete-char 2))))))
 236
 237 (defun liece-emacs-redisplay-unread-mark ()
 238   (if liece-display-unread-mark
 239       (dolist (chnl liece-channel-unread-list)
 240         (liece-emacs-unread-mark chnl))))
 241
 242 (if (and (fboundp 'image-type-available-p)
 243          (and (display-color-p)
 244               (image-type-available-p 'xpm)))
 245     (progn
 246       (fset 'liece-mode-line-buffer-identification
 247             'liece-emacs-mode-line-buffer-identification)
 248       (setq liece-emacs-splash-function #'liece-emacs-splash-with-image)
 249       (add-hook 'liece-nick-insert-hook 'liece-emacs-nick-image-region)
 250       (add-hook 'liece-nick-replace-hook 'liece-emacs-nick-image-region))
 251   (fset 'liece-mode-line-buffer-identification 'identity)
 252   (setq liece-emacs-splash-function #'liece-emacs-splash-with-stipple))
 253
 254 (when (and (not liece-inhibit-startup-message) window-system)
 255   (liece-emacs-splash))
 256
 257 (fset 'liece-redisplay-unread-mark 'liece-emacs-redisplay-unread-mark)
 258 (add-hook 'liece-channel-unread-functions 'liece-emacs-unread-mark)
 259 (add-hook 'liece-channel-read-functions 'liece-emacs-read-mark)
 260
 261 (provide 'liece-emacs)
 262
 263 ;;; liece-emacs.el ends here