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