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