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 default-toolbar-position)
 154
 155 (defvar liece-toolbar-back-glyph nil)
 156 (defvar liece-toolbar-forward-glyph nil)
 157 (defvar liece-toolbar-reload-glyph nil)
 158 (defvar liece-toolbar-home-glyph nil)
 159 (defvar liece-toolbar-search-glyph nil)
 160 (defvar liece-toolbar-location-glyph nil)
 161 (defvar liece-toolbar-crypt-glyph nil)
 162 (defvar liece-toolbar-crypt-active-glyph nil)
 163 (defvar liece-toolbar-crypt-inactive-glyph nil)
 164 (defvar liece-toolbar-stop-glyph nil)
 165
 166 (defvar liece-toolbar-spec-list
 167   '([liece-toolbar-back-glyph
 168      liece-command-previous-channel t "Previous Channel"]
 169     [liece-toolbar-forward-glyph
 170      liece-command-next-channel t "Next Channel"]
 171     [liece-toolbar-reload-glyph
 172      liece-command-list t "List Channel"]
 173     [liece-toolbar-home-glyph
 174      liece-switch-to-channel-no-1 t "Go Home Channel"]
 175     [liece-toolbar-search-glyph
 176      liece-command-finger t "Finger"]
 177     [liece-toolbar-location-glyph
 178      liece-command-join t "Join Channel"]
 179     [liece-toolbar-crypt-glyph
 180      liece-toolbar-toggle-crypt t "Toggle Crypt Mode"]
 181     [liece-toolbar-stop-glyph
 182      liece-command-quit t "Quit IRC"]))
 183
 184 ;;; @ toolbar icons
 185 ;;;
 186 (defun liece-toolbar-icon-plist-get (spec prop)
 187   "Return absolete path of icon file which SPEC has PROP."
 188   (let ((icon (plist-get spec prop)))
 189     (if icon (liece-locate-icon-file icon))))
 190
 191 (defun liece-toolbar-map-button-list (plist)
 192   "Make toolbar icon list based on status PLIST."
 193   (apply #'toolbar-make-button-list
 194          (mapcar
 195           (lambda (prop)
 196             (liece-toolbar-icon-plist-get plist prop))
 197           liece-toolbar-icon-states)))
 198
 199 (defun liece-xemacs-setup-toolbar (bar &optional force)
 200   "Prepare icons of toolbar BAR.
 201 If optional argument FORCE is non-nil, always update toolbar."
 202   (let (icon plist)
 203     (set-default-toolbar-position liece-toolbar-position)
 204     (dolist (spec bar)
 205       (setq icon (aref spec 0)
 206             plist (symbol-value
 207                    (intern (concat
 208                             (substring (prin1-to-string icon) -5 0)
 209                             "icon"))))
 210       (when (or force
 211                 (not (symbol-value icon)))
 212         (set icon (liece-toolbar-map-button-list plist)))
 213       (run-hooks 'liece-xemacs-setup-toolbar-hook))))
 214
 215 (add-hook 'liece-xemacs-setup-toolbar-hook 'liece-toolbar-setup-crypt-glyph)
 216
 217 (defun liece-toolbar-setup-crypt-glyph ()
 218   "Set crypt icons in two states."
 219   (setq liece-toolbar-crypt-active-glyph
 220         (liece-toolbar-map-button-list liece-toolbar-crypt-active-icon)
 221         liece-toolbar-crypt-inactive-glyph
 222         (liece-toolbar-map-button-list liece-toolbar-crypt-inactive-icon)))
 223
 224 (defun liece-toolbar-toggle-crypt ()
 225   "Toolbar button handler for crypt mode."
 226   (interactive)
 227   (liece-command-toggle-crypt)
 228   (setq liece-toolbar-crypt-glyph
 229         (if liece-crypt-mode-active
 230             liece-toolbar-crypt-active-glyph
 231           liece-toolbar-crypt-inactive-glyph))
 232   (and liece-use-toolbar
 233        (set-specifier (symbol-value liece-use-toolbar)
 234                       (cons (current-buffer) liece-toolbar-spec-list))))
 235
 236 ;;; @ modeline decoration
 237 ;;;
 238 (defun liece-xemacs-hide-modeline ()
 239   "Remove modeline from current window."
 240   (set-specifier has-modeline-p (cons (current-buffer) nil)))
 241
 242 (when (featurep 'scrollbar)
 243   (defun liece-xemacs-hide-scrollbars ()
 244     (static-cond
 245      ((boundp 'horizontal-scrollbar-visible-p)
 246       (set-specifier horizontal-scrollbar-visible-p nil
 247                      (current-buffer)))
 248      ((boundp 'scrollbar-height)
 249       (set-specifier scrollbar-height (cons (current-buffer) 0)))))
 250   (add-hook 'liece-nick-mode-hook 'liece-xemacs-hide-scrollbars)
 251   (add-hook 'liece-channel-list-mode-hook 'liece-xemacs-hide-scrollbars))
 252
 253 (add-hook 'liece-nick-mode-hook 'liece-xemacs-hide-modeline)
 254 (add-hook 'liece-channel-list-mode-hook 'liece-xemacs-hide-modeline)
 255
 256 (defvar liece-xemacs-modeline-left-extent
 257   (let ((ext (copy-extent modeline-buffer-id-left-extent)))
 258     ext))
 259
 260 (defvar liece-xemacs-modeline-right-extent
 261   (let ((ext (copy-extent modeline-buffer-id-right-extent)))
 262     ext))
 263
 264 (add-hook 'liece-command-mode-hook 'liece-setup-toolbar)
 265
 266 (defun liece-setup-toolbar ()
 267   "Prepare toolbar if wanted."
 268   (and liece-use-toolbar
 269        (liece-xemacs-setup-toolbar liece-toolbar-spec-list)
 270        (set-specifier (symbol-value liece-use-toolbar)
 271                       (cons (current-buffer) liece-toolbar-spec-list))))
 272
 273 (defun liece-xemacs-modeline-glyph ()
 274   "Return a glyph of modeline pointer."
 275   (let ((glyph
 276          (let (file)
 277            (make-glyph
 278             (nconc
 279              (if (setq file (liece-locate-icon-file
 280                              "liece-pointer.xpm"))
 281                  (list (vector 'xpm :file file)))
 282              (if (setq file (liece-locate-icon-file
 283                              "liece-pointer.xbm"))
 284                  (list (vector 'xbm :file file)))
 285              '([string :data "Liece:"]))))))
 286     (set-glyph-face glyph 'modeline-buffer-id)
 287     glyph))
 288
 289 (defun liece-xemacs-mode-line-buffer-identification (line)
 290   "Decorate 1st element of `mode-line-buffer-identification' LINE.
 291 Modify whole identification by side effect."
 292   (let ((id (car line)) chop)
 293     (if (and (stringp id) (string-match "^Liece:" id))
 294         (progn
 295           (setq chop (match-end 0))
 296           (nconc
 297            (list
 298             (let ((glyph (liece-xemacs-modeline-glyph)))
 299               (if glyph
 300                   (cons liece-xemacs-modeline-left-extent glyph)
 301                 (cons liece-xemacs-modeline-left-extent
 302                       (substring id 0 chop))))
 303             (cons liece-xemacs-modeline-right-extent
 304                   (substring id chop)))
 305            (cdr line)))
 306       line)))
 307
 308 (defun liece-xemacs-suppress-modeline-format ()
 309   "Remove unnecessary information from `modeline-format'."
 310   (setq modeline-format
 311         (remrassq 'modeline-modified
 312                   (delq 'modeline-multibyte-status
 313                         (copy-sequence mode-line-format)))))
 314
 315 ;;; @ menus
 316 ;;;
 317 (defun liece-xemacs-nick-popup-menu (widget &optional event)
 318   "Trigger function for popup menu."
 319   (let ((pos (widget-event-point event)))
 320     (when pos
 321       (goto-char pos)
 322       (if (eq major-mode 'liece-nick-mode)
 323           (liece-nick-update-region))
 324       (let ((menu (cdr liece-nick-popup-menu)))
 325         (setq menu (nconc (list "IRCHAT" ; title: not displayed
 326                                 "     IRC commands"
 327                                 "--:shadowDoubleEtchedOut")
 328                           (mapcar (lambda (spec)
 329                                     (if (stringp spec)
 330                                         "--:shadowEtchedOut"
 331                                       spec))
 332                                   menu)))
 333         (let (popup-menu-titles)
 334           (popup-menu menu))))))
 335
 336 (fset 'liece-nick-popup-menu 'liece-xemacs-nick-popup-menu)
 337
 338 ;;; @ nick buffer decoration
 339 ;;;
 340 (defun liece-xemacs-create-nick-glyph (file &optional string)
 341   "Return a glyph of nick indicator from FILE or STRING."
 342   (or
 343    (cdr-safe (assoc file liece-glyph-cache))
 344    (let ((glyph
 345           (make-glyph
 346            (nconc
 347             (if (setq file (liece-locate-icon-file file))
 348                 (list (vector 'xpm :file file)))
 349             (if string
 350                 (list (vector 'string :data string)))))))
 351      (push (cons file glyph) liece-glyph-cache)
 352      (set-glyph-face glyph 'default)
 353      glyph)))
 354
 355 (defun liece-xemacs-glyph-nick-region (start end)
 356   "Decorate nick buffer between START and END."
 357   (save-excursion
 358     (setq start (progn (goto-char start)(beginning-of-line)(point))
 359           end (progn (goto-char end)(beginning-of-line 2)(point)))
 360     (save-restriction
 361       (narrow-to-region start end)
 362       (let ((buffer-read-only nil)
 363             (inhibit-read-only t)
 364             (case-fold-search nil)
 365             mark file glyph ext ant)
 366         (map-extents
 367          (lambda (e void)
 368            (when (or
 369                   (extent-property
 370                    e 'liece-xemacs-glyph-nick-extent)
 371                   (extent-property
 372                    e 'liece-xemacs-glyph-nick-annotation))
 373              (delete-extent e)))
 374          (current-buffer) start end)
 375         (dolist (entry liece-nick-image-alist)
 376           (setq mark (car entry)
 377                 file (cdr entry)
 378                 glyph (liece-xemacs-create-nick-glyph
 379                        file (char-to-string mark)))
 380           (when glyph
 381             (goto-char start)
 382             (while (not (eobp))
 383               (when (eq (char-after) mark)
 384                 (mapcar 'delete-annotation
 385                         (annotations-at (1+ (point))))
 386                 (setq ext (make-extent (point) (1+ (point)))
 387                       ant (make-annotation glyph (1+ (point)) 'text))
 388                 (set-extent-property ext 'end-open t)
 389                 (set-extent-property ext 'start-open t)
 390                 (set-extent-property ext 'invisible t)
 391                 (set-extent-property ext 'intangible t)
 392                 (set-extent-property
 393                  ant 'liece-xemacs-glyph-nick-extent ext)
 394                 (set-extent-property
 395                  ext 'liece-xemacs-glyph-nick-annotation ant))
 396               (beginning-of-line 2))))))))
 397
 398 (defun liece-xemacs-set-drop-functions (start end)
 399   "Initialize drag and drop in DCC between START and END.
 400 This function needs window system independent drag and drop
 401 support (21.0 b39 or later)"
 402   (interactive "r")
 403   (liece-xemacs-set-drop-functions-buffer
 404    (current-buffer) start end)
 405   (goto-char end))
 406
 407 (defun liece-xemacs-set-drop-functions-buffer (&optional buffer start end)
 408   "Initialize BUFFER drag and drop DCC settings between START and END.
 409 This function needs window system independent drag and drop
 410 support (21.0 b39 or later)"
 411   (interactive)
 412   (when (and (featurep 'x) (featurep 'dragdrop))
 413     (save-excursion
 414       (when buffer
 415         (set-buffer buffer))
 416       (setq start (or start (point-min))
 417             end (or end (point-max)))
 418       (goto-char start)
 419       (setq start (line-beginning-position))
 420       (goto-char end)
 421       (setq end (line-beginning-position))
 422       (goto-char end)
 423       (when (not (eobp))
 424         (beginning-of-line 2)
 425         (setq end (point)))
 426       (save-restriction
 427         (narrow-to-region start end)
 428         (let (buffer-read-only case-fold-search)
 429           (map-extents
 430            (function
 431             (lambda (e void)
 432               (when (extent-property e 'liece-xemacs-drop-extent)
 433                 (delete-extent e))))
 434            buffer start end)
 435           (goto-char start)
 436           (let (st nd nick func)
 437             (while (not (eobp))
 438               (forward-char)
 439               (setq st (point)
 440                     nd (line-end-position)
 441                     nick (buffer-substring st nd))
 442               (mapcar 'delete-annotation (annotations-at nd))
 443               (setq func (intern (concat "liece-xemacs-drop-function-" nick)))
 444               (fset func
 445                     (list 'lambda (list 'object)
 446                           (list 'liece-xemacs-drop-function 'object nick)))
 447               (let ((ext (make-extent st nd)))
 448                 (set-extent-property ext 'liece-xemacs-drop-extent t)
 449                 (set-extent-property ext 'dragdrop-drop-functions (list func)))
 450               (beginning-of-line 2))))))))
 451
 452 (defun liece-xemacs-drop-function (object nick)
 453   "Drag and drop handler.
 454 Always two arguments are passed, OBJECT and NICK."
 455   (if (and (eq (car object) 'dragdrop_URL)
 456            (stringp (cdr object))
 457            (string-match "^[^:]*:\\(.*\\)" (cdr object)))
 458       (let ((filename (match-string 1 (cdr object))))
 459         (liece-command-dcc-send filename nick))))
 460
 461 (defadvice easy-menu-add-item
 462   (around liece-fix-menu-path-switch-buffer activate)
 463   "Advice for XEmacs 20.4 or earlier."
 464   (save-excursion
 465     (set-buffer liece-command-buffer)
 466     (add-menu-button
 467      (cons (car (ad-get-arg 0)) (ad-get-arg 1))
 468      (ad-get-arg 2) (ad-get-arg 3))))
 469
 470 (eval-and-compile
 471   (setq liece-x-face-insert-function
 472         (function liece-x-face-insert-with-xemacs))
 473
 474   (defun liece-x-face-insert-with-xemacs (buffer str nick)
 475     (save-excursion
 476       (let ((glyph (cdr-safe (assoc nick liece-glyph-cache))))
 477         (unless glyph
 478           (setq glyph (make-glyph
 479                        (cond
 480                         ((and (featurep 'xface)
 481                               (memq (console-type) '(x mswindows)))
 482                          `[xface :data ,str])
 483                         (t `[string :data ,str]))))
 484           (when glyph
 485             (push (cons nick glyph) liece-glyph-cache)
 486             (set-glyph-face glyph 'default)))
 487         (set-buffer buffer)
 488         (goto-char (point-max))
 489         (when glyph
 490           (set-extent-end-glyph (make-extent (point) (point)) glyph))))))
 491
 492 ;;; @ startup splash
 493 ;;;
 494 (eval-when-compile
 495   (defvar filename)
 496   (setq load-path
 497         `(,(if (and (boundp 'filename)
 498                     (stringp filename)
 499                     (file-exists-p filename))
 500                (file-name-directory filename)
 501              default-directory)
 502           ,@load-path)))
 503
 504 (when (featurep 'xpm)
 505   (eval-when-compile
 506     (defmacro liece-xemacs-logo ()
 507       (let ((logo "liece.xpm")
 508             (dir (if (and (boundp 'filename)
 509                           (stringp filename)
 510                           (file-exists-p filename))
 511                      (file-name-directory filename)
 512                    default-directory)))
 513         (setq logo (expand-file-name logo dir))
 514         (if (file-exists-p logo)
 515             (let ((buffer (generate-new-buffer " *liece-logo*"))
 516                   (coding-system-for-read (quote binary))
 517                   buffer-file-format format-alist
 518                   insert-file-contents-post-hook
 519                   insert-file-contents-pre-hook)
 520               (prog1
 521                   (save-excursion
 522                     (set-buffer buffer)
 523                     (insert-file-contents logo)
 524                     (buffer-string))
 525                 (kill-buffer buffer)))
 526           (progn
 527             (byte-compile-warn
 528              "Warning: file \"%s\" not found." logo)
 529             (sit-for 2)
 530             nil))))))
 531
 532 (defconst liece-xemacs-logo
 533   (when (featurep 'xpm)
 534     (liece-xemacs-logo)))
 535
 536 (defun liece-xemacs-splash-at-point (&optional height)
 537   "Display splash logo in HEIGHT."
 538   (or (bolp) (insert "\n"))
 539   (let ((bow (point))
 540         (glyph (make-glyph `[xpm :data ,liece-xemacs-logo]))
 541         (lh (/ (window-pixel-height) (window-height)))
 542         (lw (/ (window-pixel-width) (window-width)))
 543         (liece-insert-environment-version nil)
 544         bov)
 545
 546     (insert-char ?\n (max 0 (/ (- (or height (window-height))
 547                                   (/ (glyph-height glyph) lh))
 548                                2)))
 549     (insert-char ?\  (max 0 (/ (- (window-width)
 550                                   (/ (glyph-width glyph) lw))
 551                                2)))
 552     (when (and (featurep 'xpm) (memq (console-type) '(x mswindows)))
 553       (set-extent-end-glyph
 554        (make-extent (point) (point))
 555        glyph))
 556     (insert "\n")
 557     (insert-char ?\  (max 0 (/ (- (window-width) (length (liece-version))) 2)))
 558     (setq bov (point))
 559     (insert (liece-version))
 560     (and (find-face 'bold-italic)
 561          (put-text-property bov (point) 'face 'bold-italic))
 562     (goto-char bow)
 563     (set-window-start (get-buffer-window (current-buffer)) (point))
 564     (redisplay-frame)))
 565
 566 (defun liece-xemacs-splash (&optional arg)
 567   "Display splash logo interactively.
 568 If ARG is given, don't hide splash buffer."
 569   (interactive "P")
 570   (and liece-xemacs-logo
 571        (let ((frame (selected-frame))
 572              config buffer
 573              (liece-insert-environment-version nil))
 574          (and frame
 575               (unwind-protect
 576                   (progn
 577                     (setq config (current-window-configuration))
 578                     (switch-to-buffer
 579                      (setq buffer (generate-new-buffer
 580                                    (concat (if arg "*" " *")
 581                                            (liece-version) "*"))))
 582                     (delete-other-windows)
 583                     (liece-xemacs-splash-at-point)
 584                     (set-buffer-modified-p nil)
 585                     (or arg (sleep-for 2)))
 586                 (unless arg
 587                   (kill-buffer buffer)
 588                   (set-window-configuration config)
 589                   (redisplay-frame frame)))))))
 590
 591 (or (eq 'stream (device-type))
 592     (liece-xemacs-splash))
 593
 594 \f
 595 ;;; @ emulation functions
 596 ;;;
 597 (defun liece-xemacs-map-extents (function)
 598   "Map FUNCTION over the extents which overlap the current buffer."
 599   (map-extents (lambda (extent ignore)
 600                  (if (overlayp extent) (funcall function extent)))))
 601
 602 (defun liece-xemacs-kill-all-overlays ()
 603   "Delete all extents in the current buffer."
 604   (liece-xemacs-map-extents #'delete-extent))
 605
 606 (defun liece-xemacs-overlays-at (pos)
 607   "Return a list of the overlays that contain position POS."
 608   (let ((ext (extent-at pos)))
 609     (and ext (overlayp ext) (list ext))))
 610
 611 (fset 'liece-mode-line-buffer-identification
 612       'liece-xemacs-mode-line-buffer-identification)
 613
 614 (fset 'liece-suppress-mode-line-format
 615       'liece-xemacs-suppress-modeline-format)
 616
 617 (fset 'liece-kill-all-overlays 'liece-xemacs-kill-all-overlays)
 618 (fset 'liece-map-overlays 'liece-xemacs-map-extents)
 619 (fset 'liece-locate-data-directory 'locate-data-directory)
 620
 621 (add-hook 'liece-nick-insert-hook 'liece-xemacs-glyph-nick-region)
 622 (add-hook 'liece-nick-insert-hook 'liece-xemacs-set-drop-functions)
 623
 624 (add-hook 'liece-nick-replace-hook 'liece-xemacs-glyph-nick-region)
 625 (add-hook 'liece-nick-replace-hook 'liece-xemacs-set-drop-functions)
 626
 627 (provide 'liece-xemacs)
 628
 629 ;;; liece-xemacs.el ends here
 630