lisp/liece-xemacs.el

   1 ;;; liece-xemacs.el --- XEmacs specific routines.
   2 ;; Copyright (C) 1998-2000 Daiki Ueno
   3
   4 ;; Author: Daiki Ueno <ueno@unixuser.org>
   5 ;; Created: 1998-09-28
   6 ;; Revised: 1999-08-22
   7 ;; Keywords: emulation
   8
   9 ;; This file is part of Liece.
  10
  11 ;; This program is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15
  16 ;; This program is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25
  26
  27 ;;; Commentary:
  28 ;;
  29
  30 ;;; Code:
  31
  32 (eval-when-compile
  33   (require 'liece-inlines)
  34   (require 'liece-crypt)
  35   (require 'liece-commands))
  36
  37 (autoload 'liece-command-dcc-send "liece-dcc")
  38 (defvar liece-nick-popup-menu)
  39
  40 (defgroup liece-toolbar nil
  41   "Toolbar of your XEmacs"
  42   :tag "Toolbar"
  43   :group 'liece)
  44
  45 (defgroup liece-toolbar-icons nil
  46   "Toolbar Icons of your XEmacs"
  47   :tag "Toolbar Icons"
  48   :prefix "liece-toolbar-"
  49   :group 'liece)
  50
  51 (defmacro liece-xemacs-icon-path (file)
  52   "Search icon FILE and return absolete path of the file."
  53   `(or (and liece-icon-directory
  54             (expand-file-name ,file liece-icon-directory))
  55        (let ((path (liece-find-path ,file "icons")))
  56          (when path
  57            (setq liece-icon-directory
  58                  (file-name-directory path)))
  59          path)))
  60
  61 (define-widget 'liece-toolbar-icon 'list
  62   "Edit toolbar spec entries"
  63   :match (lambda (widget value)
  64            (valid-plist-p value))
  65   :convert-widget 'liece-toolbar-icon-convert)
  66
  67 (eval-and-compile
  68   (defconst liece-toolbar-icon-states
  69     '(:up :down :disabled :cap-up :cap-down :cap-disabled)
  70     "toolbar event states")
  71
  72   (defun liece-toolbar-icon-convert-1 (state)
  73     (list 'group :inline t :format "%t: %v"
  74           :tag (capitalize (substring (symbol-name state) 1))
  75           (list 'const :format "" :value state
  76                 (list 'radio '(const :tag "none" nil) 'file)))))
  77
  78 (defun liece-toolbar-icon-convert (widget)
  79   "Widget converter of the WIDGET `liece-toolbar-icon'."
  80   (apply #'widget-put widget :args
  81          (eval-when-compile
  82            (mapcar #'liece-toolbar-icon-convert-1
  83                    liece-toolbar-icon-states)))
  84   widget)
  85
  86 (defcustom liece-use-toolbar (if (featurep 'toolbar)
  87                                  'default-toolbar
  88                                nil)
  89   "*If nil, do not use a toolbar.
  90 If it is non-nil, it must be a toolbar.  The five valid values are
  91 `default-toolbar', `top-toolbar', `bottom-toolbar',
  92 `right-toolbar', and `left-toolbar'."
  93   :type '(choice (const default-toolbar)
  94                  (const top-toolbar) (const bottom-toolbar)
  95                  (const left-toolbar) (const right-toolbar)
  96                  (const :tag "no toolbar" nil))
  97   :group 'liece-toolbar)
  98
  99 (defcustom liece-toolbar-back-icon '(:up "back.xpm")
 100   "Back button."
 101   :type 'liece-toolbar-icon
 102   :group 'liece-toolbar-icons)
 103
 104 (defcustom liece-toolbar-forward-icon '(:up "forward.xpm")
 105   "Forward button."
 106   :type 'liece-toolbar-icon
 107   :group 'liece-toolbar-icons)
 108
 109 (defcustom liece-toolbar-reload-icon '(:up "reload.xpm")
 110   "Reload button."
 111   :type 'liece-toolbar-icon
 112   :group 'liece-toolbar-icons)
 113
 114 (defcustom liece-toolbar-home-icon '(:up "home.xpm")
 115   "Home button."
 116   :type 'liece-toolbar-icon
 117   :group 'liece-toolbar-icons)
 118
 119 (defcustom liece-toolbar-search-icon '(:up "search.xpm")
 120   "Search button."
 121   :type 'liece-toolbar-icon
 122   :group 'liece-toolbar-icons)
 123
 124 (defcustom liece-toolbar-location-icon '(:up "location.xpm")
 125   "Location button."
 126   :type 'liece-toolbar-icon
 127   :group 'liece-toolbar-icons)
 128
 129 (defcustom liece-toolbar-crypt-active-icon '(:up "encrypt.xpm")
 130   "Crypt button (active)."
 131   :type 'liece-toolbar-icon
 132   :group 'liece-toolbar-icons)
 133
 134 (defcustom liece-toolbar-crypt-inactive-icon '(:up "crypt.xpm")
 135   "Crypt button (inactive)."
 136   :type 'liece-toolbar-icon
 137   :group 'liece-toolbar-icons)
 138
 139 (defcustom liece-toolbar-crypt-icon
 140   liece-toolbar-crypt-inactive-icon
 141   "Crypt button."
 142   :type 'liece-toolbar-icon
 143   :group 'liece-toolbar-icons)
 144
 145 (defcustom liece-toolbar-stop-icon '(:up "stop.xpm")
 146   "Stop button."
 147   :type 'liece-toolbar-icon
 148   :group 'liece-toolbar-icons)
 149
 150 ;;; @ internal variables
 151 ;;;
 152 (defvar liece-glyph-cache nil)
 153 (defvar liece-toolbar-position (if (featurep 'toolbar)
 154                                    default-toolbar-position
 155                                  nil))
 156
 157 (defvar liece-toolbar-back-glyph nil)
 158 (defvar liece-toolbar-forward-glyph nil)
 159 (defvar liece-toolbar-reload-glyph nil)
 160 (defvar liece-toolbar-home-glyph nil)
 161 (defvar liece-toolbar-search-glyph nil)
 162 (defvar liece-toolbar-location-glyph nil)
 163 (defvar liece-toolbar-crypt-glyph nil)
 164 (defvar liece-toolbar-crypt-active-glyph nil)
 165 (defvar liece-toolbar-crypt-inactive-glyph nil)
 166 (defvar liece-toolbar-stop-glyph nil)
 167
 168 (defvar liece-toolbar-spec-list
 169   '([liece-toolbar-back-glyph
 170      liece-command-previous-channel t "Previous Channel"]
 171     [liece-toolbar-forward-glyph
 172      liece-command-next-channel t "Next Channel"]
 173     [liece-toolbar-reload-glyph
 174      liece-command-list t "List Channel"]
 175     [liece-toolbar-home-glyph
 176      liece-switch-to-channel-no-1 t "Go Home Channel"]
 177     [liece-toolbar-search-glyph
 178      liece-command-finger t "Finger"]
 179     [liece-toolbar-location-glyph
 180      liece-command-join t "Join Channel"]
 181     [liece-toolbar-crypt-glyph
 182      liece-toolbar-toggle-crypt t "Toggle Crypt Mode"]
 183     [liece-toolbar-stop-glyph
 184      liece-command-quit t "Quit IRC"]))
 185
 186 ;;; @ toolbar icons
 187 ;;;
 188 (defun liece-toolbar-icon-plist-get (spec prop)
 189   "Return absolete path of icon file which SPEC has PROP."
 190   (let ((icon (plist-get spec prop)))
 191     (if icon (liece-locate-icon-file icon))))
 192
 193 (defun liece-toolbar-map-button-list (plist)
 194   "Make toolbar icon list based on status PLIST."
 195   (apply #'toolbar-make-button-list
 196          (mapcar
 197           (lambda (prop)
 198             (liece-toolbar-icon-plist-get plist prop))
 199           liece-toolbar-icon-states)))
 200
 201 (defun liece-xemacs-setup-toolbar (bar &optional force)
 202   "Prepare icons of toolbar BAR.
 203 If optional argument FORCE is non-nil, always update toolbar."
 204   (let (icon plist)
 205     (set-default-toolbar-position liece-toolbar-position)
 206     (dolist (spec bar)
 207       (setq icon (aref spec 0)
 208             plist (symbol-value
 209                    (intern (concat
 210                             (substring (prin1-to-string icon) -5 0)
 211                             "icon"))))
 212       (when (or force
 213                 (not (symbol-value icon)))
 214         (set icon (liece-toolbar-map-button-list plist))))
 215     (run-hooks 'liece-xemacs-setup-toolbar-hook)))
 216
 217 (add-hook 'liece-xemacs-setup-toolbar-hook 'liece-toolbar-setup-crypt-glyph)
 218
 219 (defun liece-toolbar-setup-crypt-glyph ()
 220   "Set crypt icons in two states."
 221   (setq liece-toolbar-crypt-active-glyph
 222         (liece-toolbar-map-button-list liece-toolbar-crypt-active-icon)
 223         liece-toolbar-crypt-inactive-glyph
 224         (liece-toolbar-map-button-list liece-toolbar-crypt-inactive-icon)))
 225
 226 (defun liece-toolbar-toggle-crypt ()
 227   "Toolbar button handler for crypt mode."
 228   (interactive)
 229   (liece-command-toggle-crypt)
 230   (setq liece-toolbar-crypt-glyph
 231         (if liece-crypt-mode-active
 232             liece-toolbar-crypt-active-glyph
 233           liece-toolbar-crypt-inactive-glyph))
 234   (when liece-use-toolbar
 235     (set-specifier (symbol-value liece-use-toolbar) liece-toolbar-spec-list
 236                    (current-buffer))))
 237
 238 ;;; @ modeline decoration
 239 ;;;
 240 (defun liece-xemacs-hide-modeline ()
 241   "Remove modeline from current window."
 242   (set-specifier has-modeline-p nil (current-buffer)))
 243
 244 (when (featurep 'scrollbar)
 245   (defun liece-xemacs-hide-scrollbars ()
 246     (static-cond
 247      ((boundp 'horizontal-scrollbar-visible-p)
 248       (set-specifier horizontal-scrollbar-visible-p nil (current-buffer)))
 249      ((boundp 'scrollbar-height)
 250       (set-specifier scrollbar-height 0 (current-buffer)))))
 251   (add-hook 'liece-nick-mode-hook 'liece-xemacs-hide-scrollbars)
 252   (add-hook 'liece-channel-list-mode-hook 'liece-xemacs-hide-scrollbars))
 253
 254 (add-hook 'liece-nick-mode-hook 'liece-xemacs-hide-modeline)
 255 (add-hook 'liece-channel-list-mode-hook 'liece-xemacs-hide-modeline)
 256
 257 (defvar liece-xemacs-modeline-left-extent
 258   (let ((ext (copy-extent modeline-buffer-id-left-extent)))
 259     ext))
 260
 261 (defvar liece-xemacs-modeline-right-extent
 262   (let ((ext (copy-extent modeline-buffer-id-right-extent)))
 263     ext))
 264
 265 (add-hook 'liece-command-mode-hook 'liece-setup-toolbar)
 266
 267 (defun liece-setup-toolbar ()
 268   "Prepare toolbar if wanted."
 269   (when liece-use-toolbar
 270     (liece-xemacs-setup-toolbar liece-toolbar-spec-list)
 271     (set-specifier (symbol-value liece-use-toolbar) liece-toolbar-spec-list
 272                    (current-buffer))))
 273
 274 (defun liece-xemacs-modeline-glyph ()
 275   "Return a glyph of modeline pointer."
 276   (let ((glyph
 277          (let (file)
 278            (make-glyph
 279             (nconc
 280              (if (setq file (liece-locate-icon-file
 281                              "liece-pointer.xpm"))
 282                  (list (vector 'xpm :file file)))
 283              (if (setq file (liece-locate-icon-file
 284                              "liece-pointer.xbm"))
 285                  (list (vector 'xbm :file file)))
 286              '([string :data "Liece:"]))))))
 287     (set-glyph-face glyph 'modeline-buffer-id)
 288     glyph))
 289
 290 (defun liece-xemacs-mode-line-buffer-identification (line)
 291   "Decorate 1st element of `mode-line-buffer-identification' LINE.
 292 Modify whole identification by side effect."
 293   (let ((id (car line)) chop)
 294     (if (and (stringp id) (string-match "^Liece:" id))
 295         (progn
 296           (setq chop (match-end 0))
 297           (nconc
 298            (list
 299             (let ((glyph (liece-xemacs-modeline-glyph)))
 300               (if glyph
 301                   (cons liece-xemacs-modeline-left-extent glyph)
 302                 (cons liece-xemacs-modeline-left-extent
 303                       (substring id 0 chop))))
 304             (cons liece-xemacs-modeline-right-extent
 305                   (substring id chop)))
 306            (cdr line)))
 307       line)))
 308
 309 (defun liece-xemacs-suppress-modeline-format ()
 310   "Remove unnecessary information from `modeline-format'."
 311   (setq modeline-format
 312         (remrassq 'modeline-modified
 313                   (delq 'modeline-multibyte-status
 314                         (copy-sequence mode-line-format)))))
 315
 316 ;;; @ menus
 317 ;;;
 318 (defun liece-xemacs-nick-popup-menu (widget &optional event)
 319   "Trigger function for popup menu."
 320   (let ((pos (widget-event-point event)))
 321     (when pos
 322       (goto-char pos)
 323       (if (eq major-mode 'liece-nick-mode)
 324           (liece-nick-update-region))
 325       (let ((menu (cdr liece-nick-popup-menu)))
 326         (setq menu (nconc (list "IRCHAT" ; title: not displayed
 327                                 "     IRC commands"
 328                                 "--:shadowDoubleEtchedOut")
 329                           (mapcar (lambda (spec)
 330                                     (if (stringp spec)
 331                                         "--:shadowEtchedOut"
 332                                       spec))
 333                                   menu)))
 334         (let (popup-menu-titles)
 335           (popup-menu menu))))))
 336
 337 (fset 'liece-nick-popup-menu 'liece-xemacs-nick-popup-menu)
 338
 339 ;;; @ nick buffer decoration
 340 ;;;
 341 (defun liece-xemacs-create-nick-glyph (file &optional string)
 342   "Return a glyph of nick indicator from FILE or STRING."
 343   (or
 344    (cdr-safe (assoc file liece-glyph-cache))
 345    (let ((glyph
 346           (make-glyph
 347            (nconc
 348             (if (setq file (liece-locate-icon-file file))
 349                 (list (vector 'xpm :file file)))
 350             (if string
 351                 (list (vector 'string :data string)))))))
 352      (push (cons file glyph) liece-glyph-cache)
 353      (set-glyph-face glyph 'default)
 354      glyph)))
 355
 356 (defun liece-xemacs-glyph-nick-region (start end)
 357   "Decorate nick buffer between START and END."
 358   (save-excursion
 359     (setq start (progn (goto-char start)(beginning-of-line)(point))
 360           end (progn (goto-char end)(beginning-of-line 2)(point)))
 361     (save-restriction
 362       (narrow-to-region start end)
 363       (let ((buffer-read-only nil)
 364             (inhibit-read-only t)
 365             (case-fold-search nil)
 366             mark file glyph ext ant)
 367         (map-extents
 368          (lambda (e void)
 369            (when (or
 370                   (extent-property
 371                    e 'liece-xemacs-glyph-nick-extent)
 372                   (extent-property
 373                    e 'liece-xemacs-glyph-nick-annotation))
 374              (delete-extent e)))
 375          (current-buffer) start end)
 376         (dolist (entry liece-nick-image-alist)
 377           (setq mark (car entry)
 378                 file (cdr entry)
 379                 glyph (liece-xemacs-create-nick-glyph
 380                        file (char-to-string mark)))
 381           (when glyph
 382             (goto-char start)
 383             (while (not (eobp))
 384               (when (eq (char-after) mark)
 385                 (mapcar 'delete-annotation
 386                         (annotations-at (1+ (point))))
 387                 (setq ext (make-extent (point) (1+ (point)))
 388                       ant (make-annotation glyph (1+ (point)) 'text))
 389                 (set-extent-property ext 'end-open t)
 390                 (set-extent-property ext 'start-open t)
 391                 (set-extent-property ext 'invisible t)
 392                 (set-extent-property ext 'intangible t)
 393                 (set-extent-property
 394                  ant 'liece-xemacs-glyph-nick-extent ext)
 395                 (set-extent-property
 396                  ext 'liece-xemacs-glyph-nick-annotation ant))
 397               (beginning-of-line 2))))))))
 398
 399 (defun liece-xemacs-set-drop-functions (start end)
 400   "Initialize drag and drop in DCC between START and END.
 401 This function needs window system independent drag and drop
 402 support (21.0 b39 or later)"
 403   (interactive "r")
 404   (liece-xemacs-set-drop-functions-buffer
 405    (current-buffer) start end)
 406   (goto-char end))
 407
 408 (defun liece-xemacs-set-drop-functions-buffer (&optional buffer start end)
 409   "Initialize BUFFER drag and drop DCC settings between START and END.
 410 This function needs window system independent drag and drop
 411 support (21.0 b39 or later)"
 412   (interactive)
 413   (when (and (featurep 'x) (featurep 'dragdrop))
 414     (save-excursion
 415       (when buffer
 416         (set-buffer buffer))
 417       (setq start (or start (point-min))
 418             end (or end (point-max)))
 419       (goto-char start)
 420       (setq start (line-beginning-position))
 421       (goto-char end)
 422       (setq end (line-beginning-position))
 423       (goto-char end)
 424       (when (not (eobp))
 425         (beginning-of-line 2)
 426         (setq end (point)))
 427       (save-restriction
 428         (narrow-to-region start end)
 429         (let (buffer-read-only case-fold-search)
 430           (map-extents
 431            (function
 432             (lambda (e void)
 433               (when (extent-property e 'liece-xemacs-drop-extent)
 434                 (delete-extent e))))
 435            buffer start end)
 436           (goto-char start)
 437           (let (st nd nick func)
 438             (while (not (eobp))
 439               (forward-char)
 440               (setq st (point)
 441                     nd (line-end-position)
 442                     nick (buffer-substring st nd))
 443               (mapcar 'delete-annotation (annotations-at nd))
 444               (setq func (intern (concat "liece-xemacs-drop-function-" nick)))
 445               (fset func
 446                     (list 'lambda (list 'object)
 447                           (list 'liece-xemacs-drop-function 'object nick)))
 448               (let ((ext (make-extent st nd)))
 449                 (set-extent-property ext 'liece-xemacs-drop-extent t)
 450                 (set-extent-property ext 'dragdrop-drop-functions (list func)))
 451               (beginning-of-line 2))))))))
 452
 453 (defun liece-xemacs-drop-function (object nick)
 454   "Drag and drop handler.
 455 Always two arguments are passed, OBJECT and NICK."
 456   (if (and (eq (car object) 'dragdrop_URL)
 457            (stringp (cdr object))
 458            (string-match "^[^:]*:\\(.*\\)" (cdr object)))
 459       (let ((filename (match-string 1 (cdr object))))
 460         (liece-command-dcc-send filename nick))))
 461
 462 (defadvice easy-menu-add-item
 463   (around liece-fix-menu-path-switch-buffer activate)
 464   "Advice for XEmacs 20.4 or earlier."
 465   (save-excursion
 466     (set-buffer liece-command-buffer)
 467     (add-menu-button
 468      (cons (car (ad-get-arg 0)) (ad-get-arg 1))
 469      (ad-get-arg 2) (ad-get-arg 3))))
 470
 471 (eval-and-compile
 472   (setq liece-x-face-insert-function
 473         (function liece-x-face-insert-with-xemacs))
 474
 475   (defun liece-x-face-insert-with-xemacs (buffer str nick)
 476     (save-excursion
 477       (let ((glyph (cdr-safe (assoc nick liece-glyph-cache))))
 478         (unless glyph
 479           (setq glyph (make-glyph
 480                        (cond
 481                         ((and (featurep 'xface)
 482                               (memq (console-type) '(x mswindows)))
 483                          `[xface :data ,str])
 484                         (t `[string :data ,str]))))
 485           (when glyph
 486             (push (cons nick glyph) liece-glyph-cache)
 487             (set-glyph-face glyph 'default)))
 488         (set-buffer buffer)
 489         (goto-char (point-max))
 490         (when glyph
 491           (set-extent-end-glyph (make-extent (point) (point)) glyph))))))
 492
 493 ;;; @ startup splash
 494 ;;;
 495 (eval-when-compile
 496   (defvar filename)
 497   (setq load-path
 498         `(,(if (and (boundp 'filename)
 499                     (stringp filename)
 500                     (file-exists-p filename))
 501                (file-name-directory filename)
 502              default-directory)
 503           ,@load-path)))
 504
 505 (when (featurep 'xpm)
 506   (eval-when-compile
 507     (defmacro liece-xemacs-logo ()
 508       (let ((logo "liece.xpm")
 509             (dir (if (and (boundp 'filename)
 510                           (stringp filename)
 511                           (file-exists-p filename))
 512                      (file-name-directory filename)
 513                    default-directory)))
 514         (setq logo (expand-file-name logo dir))
 515         (if (file-exists-p logo)
 516             (let ((buffer (generate-new-buffer " *liece-logo*"))
 517                   (coding-system-for-read (quote binary))
 518                   buffer-file-format format-alist
 519                   insert-file-contents-post-hook
 520                   insert-file-contents-pre-hook)
 521               (prog1
 522                   (save-excursion
 523                     (set-buffer buffer)
 524                     (insert-file-contents logo)
 525                     (buffer-string))
 526                 (kill-buffer buffer)))
 527           (progn
 528             (byte-compile-warn
 529              "Warning: file \"%s\" not found." logo)
 530             (sit-for 2)
 531             nil))))))
 532
 533 (defconst liece-xemacs-logo
 534   (when (featurep 'xpm)
 535     (liece-xemacs-logo)))
 536
 537 (defun liece-xemacs-splash-at-point (&optional height)
 538   "Display splash logo in HEIGHT."
 539   (or (bolp) (insert "\n"))
 540   (let ((bow (point))
 541         (glyph (make-glyph `[xpm :data ,liece-xemacs-logo]))
 542         (lh (/ (window-pixel-height) (window-height)))
 543         (lw (/ (window-pixel-width) (window-width)))
 544         (liece-insert-environment-version nil)
 545         bov)
 546
 547     (insert-char ?\n (max 0 (/ (- (or height (window-height))
 548                                   (/ (glyph-height glyph) lh))
 549                                2)))
 550     (insert-char ?\  (max 0 (/ (- (window-width)
 551                                   (/ (glyph-width glyph) lw))
 552                                2)))
 553     (when (and (featurep 'xpm) (memq (console-type) '(x mswindows)))
 554       (set-extent-end-glyph
 555        (make-extent (point) (point))
 556        glyph))
 557     (insert "\n")
 558     (insert-char ?\  (max 0 (/ (- (window-width) (length (liece-version))) 2)))
 559     (setq bov (point))
 560     (insert (liece-version))
 561     (and (find-face 'bold-italic)
 562          (put-text-property bov (point) 'face 'bold-italic))
 563     (goto-char bow)
 564     (set-window-start (get-buffer-window (current-buffer)) (point))
 565     (redisplay-frame)))
 566
 567 (defun liece-xemacs-splash (&optional arg)
 568   "Display splash logo interactively.
 569 If ARG is given, don't hide splash buffer."
 570   (interactive "P")
 571   (and liece-xemacs-logo
 572        (let ((frame (selected-frame))
 573              config buffer
 574              (liece-insert-environment-version nil))
 575          (and frame
 576               (unwind-protect
 577                   (progn
 578                     (setq config (current-window-configuration))
 579                     (switch-to-buffer
 580                      (setq buffer (generate-new-buffer
 581                                    (concat (if arg "*" " *")
 582                                            (liece-version) "*"))))
 583                     (delete-other-windows)
 584                     (liece-xemacs-splash-at-point)
 585                     (set-buffer-modified-p nil)
 586                     (or arg (sleep-for 2)))
 587                 (unless arg
 588                   (kill-buffer buffer)
 589                   (set-window-configuration config)
 590                   (redisplay-frame frame)))))))
 591
 592 (or (eq 'stream (device-type))
 593     (liece-xemacs-splash))
 594
 595 \f
 596 ;;; @ emulation functions
 597 ;;;
 598 (defun liece-xemacs-map-extents (function)
 599   "Map FUNCTION over the extents which overlap the current buffer."
 600   (map-extents (lambda (extent ignore)
 601                  (if (overlayp extent) (funcall function extent)))))
 602
 603 (defun liece-xemacs-kill-all-overlays ()
 604   "Delete all extents in the current buffer."
 605   (liece-xemacs-map-extents #'delete-extent))
 606
 607 (defun liece-xemacs-overlays-at (pos)
 608   "Return a list of the overlays that contain position POS."
 609   (let ((ext (extent-at pos)))
 610     (and ext (overlayp ext) (list ext))))
 611
 612 (fset 'liece-mode-line-buffer-identification
 613       'liece-xemacs-mode-line-buffer-identification)
 614
 615 (fset 'liece-suppress-mode-line-format
 616       'liece-xemacs-suppress-modeline-format)
 617
 618 (fset 'liece-kill-all-overlays 'liece-xemacs-kill-all-overlays)
 619 (fset 'liece-map-overlays 'liece-xemacs-map-extents)
 620 (fset 'liece-locate-data-directory 'locate-data-directory)
 621
 622 (add-hook 'liece-nick-insert-hook 'liece-xemacs-glyph-nick-region)
 623 (add-hook 'liece-nick-insert-hook 'liece-xemacs-set-drop-functions)
 624
 625 (add-hook 'liece-nick-replace-hook 'liece-xemacs-glyph-nick-region)
 626 (add-hook 'liece-nick-replace-hook 'liece-xemacs-set-drop-functions)
 627
 628 (provide 'liece-xemacs)
 629
 630 ;;; liece-xemacs.el ends here
 631