427 lines
16 KiB
EmacsLisp
427 lines
16 KiB
EmacsLisp
;;; dvc-xemacs.el --- Compatibility stuff for XEmacs
|
|
;;;
|
|
;;; This file should be loaded when using XEmacs; load
|
|
;;; dvc-emacs.el when using Gnu Emacs.
|
|
|
|
;; Copyright (C) 2004-2006, 2008 by all contributors
|
|
|
|
;; Author: Robert Widhopf-Fenk <hack@robf.de>
|
|
|
|
;; This file is part of DVC.
|
|
;;
|
|
;; DVC is free software; you can redistribute it and/or modify
|
|
;; it under the terms of the GNU General Public License as published by
|
|
;; the Free Software Foundation; either version 2, or (at your option)
|
|
;; any later version.
|
|
|
|
;; DVC is distributed in the hope that it will be useful,
|
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
;; GNU General Public License for more details.
|
|
|
|
;; You should have received a copy of the GNU General Public License
|
|
;; along with GNU Emacs; see the file COPYING. If not, write to
|
|
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
|
|
;; Boston, MA 02110-1301, USA.
|
|
|
|
;;; Policy: see dvc-emacs.el for policy on what goes in this file.
|
|
|
|
;;; Code:
|
|
|
|
(eval-when-compile
|
|
(require 'cl))
|
|
|
|
(eval-and-compile
|
|
(require 'overlay)
|
|
(require 'wid-edit)
|
|
;; The following require causes a infinite recursion as the (provide ...) is at
|
|
;; the file end. Thus we live with the warnings about unknown variables etc.
|
|
;;(require 'dvc-core)
|
|
)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; fixes warnings about undefined variables
|
|
(unless (boundp 'add-log-buffer-file-name-function)
|
|
(defvar add-log-buffer-file-name-function nil))
|
|
(unless (boundp 'add-log-file-name-function)
|
|
(defvar add-log-file-name-function nil))
|
|
(unless (boundp 'add-log-keep-changes-together)
|
|
(defvar add-log-keep-changes-together nil))
|
|
(unless (boundp 'global-font-lock-mode)
|
|
(defvar global-font-lock-mode nil))
|
|
(unless (boundp 'vc-ignore-vc-files)
|
|
(defvar vc-ignore-vc-files nil))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(unless (functionp 'add-log-file-name)
|
|
(defun add-log-file-name (buffer-file log-file)
|
|
;; Never want to add a change log entry for the ChangeLog file itself.
|
|
(unless (or (null buffer-file) (string= buffer-file log-file))
|
|
(if add-log-file-name-function
|
|
(funcall add-log-file-name-function buffer-file)
|
|
(setq buffer-file
|
|
(if (string-match
|
|
(concat "^" (regexp-quote (file-name-directory log-file)))
|
|
buffer-file)
|
|
(substring buffer-file (match-end 0))
|
|
(file-name-nondirectory buffer-file)))
|
|
;; If we have a backup file, it's presumably because we're
|
|
;; comparing old and new versions (e.g. for deleted
|
|
;; functions) and we'll want to use the original name.
|
|
(if (backup-file-name-p buffer-file)
|
|
(file-name-sans-versions buffer-file)
|
|
buffer-file)))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; the unless check seems to fail
|
|
;;(unless (functionp 'replace-regexp-in-string)
|
|
(defun replace-regexp-in-string (regexp rep string
|
|
&optional fixedcase literal)
|
|
(replace-in-string string regexp rep literal))
|
|
;;)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(unless (functionp 'line-end-position)
|
|
(defun line-end-position ()
|
|
(save-excursion (end-of-line) (point))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(unless (functionp 'line-beginning-position)
|
|
(defun line-beginning-position (&optional n)
|
|
(save-excursion
|
|
(if n (forward-line n))
|
|
(beginning-of-line)
|
|
(point))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(unless (functionp 'mouse-set-point)
|
|
(defun mouse-set-point (event)
|
|
(goto-char (event-point event))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(unless (functionp 'match-string-no-properties)
|
|
(defun match-string-no-properties (arg &optional string)
|
|
(match-string arg string)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(unless (functionp 'clone-buffer)
|
|
(defun clone-buffer (&optional newname display-flag)
|
|
"Create a twin copy of the current buffer.
|
|
If NEWNAME is nil, it defaults to the current buffer's name;
|
|
NEWNAME is modified by adding or incrementing <N> at the end as necessary.
|
|
|
|
If DISPLAY-FLAG is non-nil, the new buffer is shown with `pop-to-buffer'.
|
|
This runs the normal hook `clone-buffer-hook' in the new buffer
|
|
after it has been set up properly in other respects."
|
|
(interactive (list (if current-prefix-arg (read-string "Name: "))
|
|
t))
|
|
(if buffer-file-name
|
|
(error "Cannot clone a file-visiting buffer"))
|
|
(if (get major-mode 'no-clone)
|
|
(error "Cannot clone a buffer in %s mode" mode-name))
|
|
(setq newname (or newname (buffer-name)))
|
|
(if (string-match "<[0-9]+>\\'" newname)
|
|
(setq newname (substring newname 0 (match-beginning 0))))
|
|
(let ((buf (current-buffer))
|
|
(ptmin (point-min))
|
|
(ptmax (point-max))
|
|
(pt (point))
|
|
(mk (mark t))
|
|
(modified (buffer-modified-p))
|
|
(mode major-mode)
|
|
(lvars (buffer-local-variables))
|
|
(process (get-buffer-process (current-buffer)))
|
|
(new (generate-new-buffer (or newname (buffer-name)))))
|
|
(save-restriction
|
|
(widen)
|
|
(with-current-buffer new
|
|
(insert-buffer-substring buf)))
|
|
(with-current-buffer new
|
|
(narrow-to-region ptmin ptmax)
|
|
(goto-char pt)
|
|
(if mk (set-mark mk))
|
|
(set-buffer-modified-p modified)
|
|
|
|
;; Clone the old buffer's process, if any.
|
|
(when process (clone-process process))
|
|
|
|
;; Now set up the major mode.
|
|
(funcall mode)
|
|
|
|
;; Set up other local variables.
|
|
(mapcar (lambda (v)
|
|
(condition-case () ;in case var is read-only
|
|
(if (symbolp v)
|
|
(makunbound v)
|
|
(set (make-local-variable (car v)) (cdr v)))
|
|
(error nil)))
|
|
lvars)
|
|
|
|
;; Run any hooks (typically set up by the major mode
|
|
;; for cloning to work properly).
|
|
(run-hooks 'clone-buffer-hook))
|
|
(if display-flag (pop-to-buffer new))
|
|
new)))
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(unless (functionp 'make-temp-file)
|
|
(defun make-temp-file (prefix &optional dir-flag)
|
|
"Create a temporary file.
|
|
The returned file name (created by `make-temp-name', is guaranteed to point to
|
|
a newly created empty file.
|
|
You can then use `write-region' to write new data into the file.
|
|
|
|
If DIR-FLAG is non-nil, create a new empty directory instead of a file."
|
|
(let (file)
|
|
(while (condition-case ()
|
|
(progn
|
|
(setq file
|
|
(make-temp-name
|
|
(expand-file-name prefix)))
|
|
(if dir-flag
|
|
(make-directory file)
|
|
(write-region "" nil file nil 'silent nil))
|
|
nil)
|
|
(file-already-exists t))
|
|
;; the file was somehow created by someone else between
|
|
;; `make-temp-name' and `write-region', let's try again.
|
|
nil)
|
|
file)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; AFAIK easy-menu cannot be used for dynamic menus
|
|
|
|
(defun dvc-xemacs-dvc-mode-p (buf)
|
|
"Helper function for menu-related functions.
|
|
|
|
Return t if BUF is a dvc-related buffer."
|
|
(if (bufferp buf)
|
|
(setq buf (format "%s" (symbol-value-in-buffer 'major-mode buf))))
|
|
(string-match "^dvc-" buf))
|
|
|
|
(defvar dvc-dead-process-buffer-queue nil)
|
|
|
|
(defun dvc-xemacs-buffers-menu (menu)
|
|
"Create the markers-menu.
|
|
|
|
MENU is the menu to which items should be added."
|
|
(interactive (list nil))
|
|
(let ((bufs (buffer-list))
|
|
(queue dvc-dead-process-buffer-queue)
|
|
queue-menu
|
|
b)
|
|
;; the user buffers
|
|
(while bufs
|
|
(setq b (car bufs)
|
|
bufs (cdr bufs))
|
|
(if (dvc-xemacs-dvc-mode-p b)
|
|
(setq menu (cons (vector (buffer-name b)
|
|
(list 'switch-to-buffer b) t)
|
|
menu))))
|
|
(setq menu (sort menu
|
|
(lambda (m1 m2) (string< (aref m1 0) (aref m2 0)))))
|
|
;; the queue buffers
|
|
(while queue
|
|
(setq b (car queue)
|
|
queue (cdr queue)
|
|
queue-menu (cons (vector (buffer-name b)
|
|
(list 'switch-to-buffer b) t)
|
|
queue-menu)))
|
|
(setq queue-menu (sort queue-menu
|
|
(lambda (m1 m2) (string< (aref m1 0) (aref m2 0)))))
|
|
;; combine menus
|
|
(setq menu (cons (append '("Queue") queue-menu) menu))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(defun dvc-group-buffers-menu-by-mode-then-alphabetically (buf1 buf2)
|
|
"For use as a value of `buffers-menu-grouping-function'.
|
|
This groups buffers by major mode. It only really makes sense if
|
|
`buffers-menu-sorting-function' is
|
|
'dvc-sort-buffers-menu-by-mode-then-alphabetically'.
|
|
|
|
(setq buffers-menu-grouping-function 'dvc-group-buffers-menu-by-mode-then-alphabetically)
|
|
BUF1 and BUF2 are successive members of the sorted buffers list after
|
|
being passed through `buffers-menu-sort-function'. It should return
|
|
non-nil if the second buffer begins a new group.
|
|
|
|
This is a modified version of
|
|
`group-buffers-menu-by-mode-then-alphabetically'
|
|
adding an submenu \"DVC\" containing all dvc buffers."
|
|
(cond ((and buf1 buf2
|
|
(not (dvc-xemacs-dvc-mode-p buf1))
|
|
(dvc-xemacs-dvc-mode-p buf2))
|
|
(if (string-match "\\`*" (buffer-name buf1))
|
|
"*Misc*"
|
|
(symbol-value-in-buffer 'mode-name buf1)))
|
|
((and buf1
|
|
(dvc-xemacs-dvc-mode-p buf1)
|
|
(or (not buf2)
|
|
(not (dvc-xemacs-dvc-mode-p buf2))))
|
|
"DVC")
|
|
((string-match "\\`*" (buffer-name buf1))
|
|
(and (null buf2) "*Misc*"))
|
|
((or (null buf2)
|
|
(string-match "\\`*" (buffer-name buf2))
|
|
(not (eq (symbol-value-in-buffer 'major-mode buf1)
|
|
(symbol-value-in-buffer 'major-mode buf2))))
|
|
(symbol-value-in-buffer 'mode-name buf1))
|
|
(t nil)))
|
|
|
|
(defun dvc-sort-buffers-menu-by-mode-then-alphabetically (buf1 buf2)
|
|
"For use as a value of `buffers-menu-sort-function'.
|
|
Sorts first by major mode and then alphabetically by name, but puts buffers
|
|
beginning with a star at the end of the list.
|
|
|
|
(setq buffers-menu-sort-function 'dvc-sort-buffers-menu-by-mode-then-alphabetically)
|
|
It will be passed two arguments BUF1 and BUF2 (two buffers to compare)
|
|
and will return t if the first is \"less\" than the second.
|
|
|
|
This is a modified version of `sort-buffers-menu-by-mode-then-alphabetically',
|
|
causing all *dvc-* buffers to be treated as having the same major mode."
|
|
(let* ((nam1 (buffer-name buf1))
|
|
(nam2 (buffer-name buf2))
|
|
(inv1p (not (null (string-match "\\` " nam1))))
|
|
(inv2p (not (null (string-match "\\` " nam2))))
|
|
(star1p (not (null (string-match "\\`*" nam1))))
|
|
(star2p (not (null (string-match "\\`*" nam2))))
|
|
(mode1 (symbol-value-in-buffer 'major-mode buf1))
|
|
(mode2 (symbol-value-in-buffer 'major-mode buf2)))
|
|
(if (dvc-xemacs-dvc-mode-p mode1)
|
|
(setq mode1 "dvc"))
|
|
(if (dvc-xemacs-dvc-mode-p mode1)
|
|
(setq mode2 "dvc"))
|
|
(cond ((not (eq inv1p inv2p))
|
|
(not inv1p))
|
|
((not (eq star1p star2p))
|
|
(not star1p))
|
|
((and star1p star2p (string-lessp nam1 nam2)))
|
|
((string-lessp mode1 mode2)
|
|
t)
|
|
((string-lessp mode2 mode1)
|
|
nil)
|
|
(t
|
|
(string-lessp nam1 nam2)))))
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; since the custom.el coming with XEmacs does not know about the :inherit
|
|
;; keyword of defface we are dealing with it for our faces ...
|
|
(let ((faces (face-list)) face inherit)
|
|
(while faces
|
|
(setq face (car faces)
|
|
faces (cdr faces))
|
|
(when (string-match "^dvc-" (format "%s" face))
|
|
(setq inherit (assoc :inherit (car (custom-face-get-spec face))))
|
|
(if inherit
|
|
(set-face-parent face (cadr inherit))))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(unless (functionp 'minibuffer-contents)
|
|
(defun minibuffer-contents ()
|
|
"Return the user input in a minbuffer as a string.
|
|
The current buffer must be a minibuffer."
|
|
(buffer-substring)))
|
|
|
|
(unless (functionp 'minibufferp)
|
|
(defun minibufferp ()
|
|
"Return non-nil if within a minibuffer."
|
|
(equal (selected-window)
|
|
(active-minibuffer-window))))
|
|
|
|
(unless (functionp 'diff-hunk-next)
|
|
(defalias 'diff-hunk-next 'diff-next-hunk))
|
|
|
|
(unless (functionp 'diff-hunk-prev)
|
|
(defalias 'diff-hunk-prev 'diff-prev-hunk))
|
|
|
|
(defalias 'dvc-expand-file-name 'expand-file-name)
|
|
|
|
;; FIXME: move to dvc-utils?
|
|
(defun dvc-xmas-make-temp-dir (prefix)
|
|
"Make a temporary directory using PREFIX.
|
|
Return the name of the directory."
|
|
(let ((dir (make-temp-name (expand-file-name prefix (temp-directory)))))
|
|
(make-directory dir)
|
|
dir))
|
|
|
|
(defalias 'dvc-make-temp-dir 'dvc-xmas-make-temp-dir)
|
|
|
|
;; From Gnus.
|
|
(defun dvc-xmas-move-overlay (extent start end &optional buffer)
|
|
(set-extent-endpoints extent start end buffer))
|
|
|
|
(defun dvc-xmas-kill-all-overlays ()
|
|
"Delete all extents in the current buffer."
|
|
(map-extents (lambda (extent ignore)
|
|
(delete-extent extent)
|
|
nil)))
|
|
|
|
(defun dvc-xmas-add-text-properties (start end props &optional object)
|
|
(add-text-properties start end props object)
|
|
(put-text-property start end 'start-closed nil object))
|
|
|
|
(defun dvc-xmas-put-text-property (start end prop value &optional object)
|
|
(put-text-property start end prop value object)
|
|
(put-text-property start end 'start-closed nil object))
|
|
|
|
(defun dvc-xmas-assq-delete-all (key alist)
|
|
(let ((elem nil))
|
|
(while (setq elem (assq key alist))
|
|
(setq alist (delq elem alist)))
|
|
alist))
|
|
|
|
(defalias 'dvc-make-overlay 'make-extent)
|
|
(defalias 'dvc-delete-overlay 'delete-extent)
|
|
(defalias 'dvc-overlay-put 'set-extent-property)
|
|
(defalias 'dvc-move-overlay 'dvc-xmas-move-overlay)
|
|
(defalias 'dvc-overlay-buffer 'extent-object)
|
|
(defalias 'dvc-overlay-start 'extent-start-position)
|
|
(defalias 'dvc-overlay-end 'extent-end-position)
|
|
(defalias 'dvc-kill-all-overlays 'dvc-xmas-kill-all-overlays)
|
|
(defalias 'dvc-extent-detached-p 'extent-detached-p)
|
|
(defalias 'dvc-add-text-properties 'dvc-xmas-add-text-properties)
|
|
(defalias 'dvc-put-text-property 'dvc-xmas-put-text-property)
|
|
(defalias 'dvc-deactivate-mark 'ignore)
|
|
(defalias 'dvc-window-edges 'window-pixel-edges)
|
|
(defalias 'dvc-assq-delete-all 'dvc-xmas-assq-delete-all)
|
|
(defconst dvc-mouse-face-prop 'highlight)
|
|
;; end from Gnus
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(defalias 'dvc-line-number-at-pos (if (functionp 'line-number-at-pos)
|
|
'line-number-at-pos
|
|
'line-number))
|
|
|
|
|
|
(defvar allow-remote-paths nil)
|
|
|
|
(if (fboundp 'ewoc-delete)
|
|
(defalias 'dvc-ewoc-delete 'ewoc-delete)
|
|
(defun dvc-ewoc-delete (ewoc &rest nodes)
|
|
"Delete NODES from EWOC."
|
|
(ewoc--set-buffer-bind-dll-let* ewoc
|
|
((L nil) (R nil) (last (ewoc--last-node ewoc)))
|
|
(dolist (node nodes)
|
|
;; If we are about to delete the node pointed at by last-node,
|
|
;; set last-node to nil.
|
|
(when (eq last node)
|
|
(setf last nil (ewoc--last-node ewoc) nil))
|
|
(delete-region (ewoc--node-start-marker node)
|
|
(ewoc--node-start-marker (ewoc--node-next dll node)))
|
|
(set-marker (ewoc--node-start-marker node) nil)
|
|
(setf L (ewoc--node-left node)
|
|
R (ewoc--node-right node)
|
|
;; Link neighbors to each other.
|
|
(ewoc--node-right L) R
|
|
(ewoc--node-left R) L
|
|
;; Forget neighbors.
|
|
(ewoc--node-left node) nil
|
|
(ewoc--node-right node) nil)))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(provide 'dvc-xemacs)
|
|
|
|
;; Local Variables:
|
|
;; End:
|
|
|
|
;;; dvc-xemacs.el ends here
|