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             (switch-to-buffer (setq buffer (liece-get-buffer-create
 125                                             (concat (if arg "*" " *")
 126                                                     (liece-version) "*"))))
 127             (erase-buffer)
 128             (static-cond
 129              ((and (fboundp 'image-type-available-p)
 130                    (image-type-available-p 'xpm))
 131               (with-temp-buffer
 132                 (insert (plist-get (cdr liece-splash-image) :data))
 133                 (goto-char (point-min))
 134                 (skip-syntax-forward "^\"")
 135                 (when (looking-at "\"[ \t]*\\([0-9]+\\)[ \t]*\\([0-9]+\\)")
 136                   (setq pixel-width (string-to-int (match-string 1))
 137                         pixel-height (string-to-int (match-string 2)))))
 138               (insert (make-string (max 0 (/ (- (frame-height)
 139                                                 (/ pixel-height
 140                                                    (frame-char-height)))
 141                                              2))
 142                                    ?\n)
 143                       (make-string (max 0 (/ (- (frame-width)
 144                                                 (/ pixel-width
 145                                                    (frame-char-width)))
 146                                              2))
 147                                    ?\ ))
 148               (static-if (condition-case nil
 149                              (progn (insert-image '(image)) nil)
 150                            (wrong-number-of-arguments t))
 151                   (insert-image liece-splash-image "x")
 152                 (insert-image liece-splash-image))
 153               (insert "\n"))
 154              (t
 155               (bitmap-stipple-insert-pixmap liece-splash-image 'center)))
 156             (insert "\n")
 157             (insert-char ?\  (max 0 (/ (- (window-width)
 158                                           (length (liece-version)))
 159                                        2)))
 160             (put-text-property (point) (prog2 (insert (liece-version))(point)
 161                                          (insert "\n"))
 162                                'face 'underline))
 163           (or arg (sit-for 2)))
 164       (unless arg
 165         (kill-buffer buffer)
 166         (set-window-configuration config)))))
 167
 168 ;;; @ modeline decoration
 169 ;;;
 170 (defconst liece-mode-line-image nil)
 171
 172 (defun liece-emacs-create-mode-line-image ()
 173   (static-when (fboundp 'image-type-available-p)
 174     (let ((file (liece-locate-icon-file
 175                  (static-cond
 176                   ((image-type-available-p 'xpm)
 177                    "liece-pointer.xpm")
 178                   ((image-type-available-p 'xbm)
 179                    "liece-pointer.xbm")))))
 180       (and file (file-exists-p file)
 181            (create-image file nil nil :ascent 99)))))
 182
 183 (defun liece-emacs-mode-line-buffer-identification (line)
 184   (let ((id (copy-sequence (car line))) image)
 185     (if (and (stringp id) (string-match "^Liece:" id)
 186              (setq liece-mode-line-image
 187                    (liece-emacs-create-mode-line-image)))
 188         (progn
 189           (add-text-properties 0 (length id)
 190                                (list 'display
 191                                      liece-mode-line-image
 192                                      'rear-nonsticky (list 'display))
 193                                id)
 194           (setcar line id)))
 195     line))
 196
 197 (fset 'liece-mode-line-buffer-identification
 198       'liece-emacs-mode-line-buffer-identification)
 199
 200 ;;; @ nick buffer decoration
 201 ;;;
 202 (defun liece-emacs-create-nick-image (file)
 203   (static-when (and (fboundp 'image-type-available-p)
 204                     (image-type-available-p 'xpm))
 205     (let ((file (liece-locate-icon-file file)))
 206       (and file (file-exists-p file)
 207            (create-image file nil nil :ascent 99)))))
 208
 209 (defun liece-emacs-nick-image-region (start end)
 210   (save-excursion
 211     (goto-char start)
 212     (beginning-of-line)
 213     (setq start (point))
 214
 215     (goto-char end)
 216     (beginning-of-line 2)
 217     (setq end (point))
 218
 219     (save-restriction
 220       (narrow-to-region start end)
 221       (let ((buffer-read-only nil)
 222             (inhibit-read-only t)
 223             (case-fold-search nil)
 224             mark image)
 225         (dolist (entry liece-nick-image-alist)
 226           (setq mark (car entry)
 227                 image (cdr entry))
 228           (if (stringp image)
 229               (setq image
 230                     (setcdr entry (liece-emacs-create-nick-image image))))
 231           (goto-char start)
 232           (while (not (eobp))
 233             (when (eq (char-after) mark)
 234               (add-text-properties (point) (1+ (point))
 235                                    (list 'display
 236                                          image
 237                                          'rear-nonsticky (list 'display))))
 238             (beginning-of-line 2)))))))
 239
 240 ;;; @ unread mark
 241 ;;;
 242 (defun liece-emacs-unread-mark (chnl)
 243   (if liece-display-unread-mark
 244     (with-current-buffer liece-channel-list-buffer
 245       (let ((buffer-read-only nil))
 246         (goto-char (point-min))
 247         (when (re-search-forward (concat "^ ?[0-9]+: " chnl "$") nil t)
 248           (goto-char (match-end 0))
 249           (insert (concat " " liece-emacs-unread-character)))))))
 250
 251 (defun liece-emacs-read-mark (chnl)
 252   (if liece-display-unread-mark
 253     (with-current-buffer liece-channel-list-buffer
 254       (let ((buffer-read-only nil))
 255         (goto-char (point-min))
 256         (when (re-search-forward
 257                (concat "^ ?[0-9]+: " chnl " "
 258                        liece-emacs-unread-character "$") nil t)
 259          (goto-char (- (match-end 0) 2))
 260          (delete-char 2))))))
 261
 262 (defun liece-emacs-redisplay-unread-mark ()
 263   (if liece-display-unread-mark
 264     (let ((chnl))
 265       (dolist (chnl liece-channel-unread-list)
 266         (liece-emacs-unread-mark chnl)))))
 267
 268 (add-hook 'liece-nick-insert-hook 'liece-emacs-nick-image-region)
 269 (add-hook 'liece-nick-replace-hook 'liece-emacs-nick-image-region)
 270
 271 (and liece-splash-image window-system
 272      (liece-emacs-splash))
 273
 274 (fset 'liece-redisplay-unread-mark 'liece-emacs-redisplay-unread-mark)
 275 (add-hook 'liece-channel-unread-hook 'liece-emacs-unread-mark)
 276 (add-hook 'liece-channel-read-hook 'liece-emacs-read-mark)
 277
 278 (provide 'liece-emacs)
 279
 280 ;;; liece-emacs.el ends here