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