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