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