2428 lines
93 KiB
EmacsLisp
2428 lines
93 KiB
EmacsLisp
|
;;; ourcomments-util.el --- Utility routines
|
||
|
|
;;
|
||
|
|
;; Author: Lennart Borgman <lennart dot borgman at gmail dot com>
|
||
|
|
;; Created: Wed Feb 21 2007
|
||
|
|
(defconst ourcomments-util:version "0.25") ;;Version:
|
||
|
|
;; Last-Updated: 2009-08-04 Tue
|
||
|
|
;; Keywords:
|
||
|
|
;; Compatibility: Emacs 22
|
||
|
|
;;
|
||
|
|
;; Features that might be required by this library:
|
||
|
|
;;
|
||
|
|
;; None
|
||
|
|
;;
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;;
|
||
|
|
;;; Commentary:
|
||
|
|
;;
|
||
|
|
;; The functionality given by these small routines should in my
|
||
|
|
;; opinion be part of Emacs (but they are not that currently).
|
||
|
|
;;
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;;
|
||
|
|
;;; Change log:
|
||
|
|
;;
|
||
|
|
;;
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;;
|
||
|
|
;; This program 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.
|
||
|
|
;;
|
||
|
|
;; This program 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 this program; see the file COPYING. If not, write to the
|
||
|
|
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
||
|
|
;; Boston, MA 02111-1307, USA.
|
||
|
|
;;
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;;
|
||
|
|
;;; Code:
|
||
|
|
|
||
|
|
(eval-when-compile (require 'apropos))
|
||
|
|
(eval-when-compile (require 'bookmark))
|
||
|
|
(eval-when-compile (require 'cl))
|
||
|
|
(eval-when-compile (require 'grep))
|
||
|
|
(eval-when-compile (require 'ido))
|
||
|
|
(eval-when-compile (require 'org))
|
||
|
|
(eval-when-compile (require 'recentf))
|
||
|
|
(eval-when-compile (require 'uniquify))
|
||
|
|
|
||
|
|
(require 'cus-edit)
|
||
|
|
|
||
|
|
;; (ourcomments-indirect-fun 'html-mumamo)
|
||
|
|
;; (ourcomments-indirect-fun 'html-mumamo-mode)
|
||
|
|
;;;###autoload
|
||
|
|
(defun ourcomments-indirect-fun (fun)
|
||
|
|
"Get the alias symbol for function FUN if any."
|
||
|
|
;; This code is from `describe-function-1'.
|
||
|
|
(when (and (symbolp fun)
|
||
|
|
(functionp fun))
|
||
|
|
(let ((def (symbol-function fun)))
|
||
|
|
(when (symbolp def)
|
||
|
|
(while (and (fboundp def)
|
||
|
|
(symbolp (symbol-function def)))
|
||
|
|
(setq def (symbol-function def)))
|
||
|
|
def))))
|
||
|
|
|
||
|
|
(defun ourcomments-goto-line (line)
|
||
|
|
"A version of `goto-line' for use in elisp code."
|
||
|
|
(save-restriction
|
||
|
|
(widen)
|
||
|
|
(goto-char (point-min))
|
||
|
|
(forward-line (1- line))))
|
||
|
|
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;;;; Popups etc.
|
||
|
|
|
||
|
|
(defun point-to-coord (point)
|
||
|
|
"Return coordinates of POINT in selected window.
|
||
|
|
The coordinates are in the form \(\(XOFFSET YOFFSET) WINDOW).
|
||
|
|
This form is suitable for `popup-menu'."
|
||
|
|
;; Fix-me: showtip.el adds (window-inside-pixel-edges
|
||
|
|
;; (selected-window)). Why?
|
||
|
|
(let* ((pn (posn-at-point point))
|
||
|
|
(x-y (posn-x-y pn))
|
||
|
|
(x (car x-y))
|
||
|
|
(y (cdr x-y))
|
||
|
|
(pos (list (list x (+ y 20)) (selected-window))))
|
||
|
|
pos))
|
||
|
|
|
||
|
|
;;;###autoload
|
||
|
|
(defun popup-menu-at-point (menu &optional prefix)
|
||
|
|
"Popup the given menu at point.
|
||
|
|
This is similar to `popup-menu' and MENU and PREFIX has the same
|
||
|
|
meaning as there. The position for the popup is however where
|
||
|
|
the window point is."
|
||
|
|
(let ((where (point-to-coord (point))))
|
||
|
|
(popup-menu menu where prefix)))
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;;;; Toggles in menus
|
||
|
|
|
||
|
|
;;;###autoload
|
||
|
|
(defmacro define-toggle (symbol value doc &rest args)
|
||
|
|
"Declare SYMBOL as a customizable variable with a toggle function.
|
||
|
|
The purpose of this macro is to define a defcustom and a toggle
|
||
|
|
function suitable for use in a menu.
|
||
|
|
|
||
|
|
The arguments have the same meaning as for `defcustom' with these
|
||
|
|
restrictions:
|
||
|
|
|
||
|
|
- The :type keyword cannot be used. Type is always 'boolean.
|
||
|
|
- VALUE must be t or nil.
|
||
|
|
|
||
|
|
DOC and ARGS are just passed to `defcustom'.
|
||
|
|
|
||
|
|
A `defcustom' named SYMBOL with doc-string DOC and a function
|
||
|
|
named SYMBOL-toggle is defined. The function toggles the value
|
||
|
|
of SYMBOL. It takes no parameters.
|
||
|
|
|
||
|
|
To create a menu item something similar to this can be used:
|
||
|
|
|
||
|
|
\(define-key map [SYMBOL]
|
||
|
|
\(list 'menu-item \"Toggle nice SYMBOL\"
|
||
|
|
'SYMBOL-toggle
|
||
|
|
:button '(:toggle . SYMBOL)))"
|
||
|
|
(declare
|
||
|
|
(doc-string 3)
|
||
|
|
(debug t))
|
||
|
|
(let* ((SYMBOL-toggle (intern (concat (symbol-name symbol) "-toggle")))
|
||
|
|
(SYMBOL-name (symbol-name symbol))
|
||
|
|
(var-doc doc)
|
||
|
|
(fun-doc (concat "Toggles the \(boolean) value of `"
|
||
|
|
SYMBOL-name
|
||
|
|
"'.\n"
|
||
|
|
"For how to set it permanently see this variable.\n"
|
||
|
|
)))
|
||
|
|
(let ((var (append `(defcustom ,symbol ,value ,var-doc)
|
||
|
|
args
|
||
|
|
nil))
|
||
|
|
(fun `(defun ,SYMBOL-toggle ()
|
||
|
|
,fun-doc
|
||
|
|
(interactive)
|
||
|
|
(customize-set-variable (quote ,symbol) (not ,symbol)))))
|
||
|
|
;;(message "\nvar=%S\nfun=%S\n" var fun)
|
||
|
|
;; Fix-me: I am having problems with this one, see
|
||
|
|
;; http://lists.gnu.org/archive/html/help-gnu-emacs/2009-12/msg00608.html
|
||
|
|
`(progn ,var ,fun)
|
||
|
|
)))
|
||
|
|
|
||
|
|
;;(macroexpand '(define-toggle my-toggle t "doc" :tag "Short help" :group 'popcmp))
|
||
|
|
;;(macroexpand-all (define-toggle my-toggle t "doc" :tag "Short help" :group 'popcmp))
|
||
|
|
|
||
|
|
;;;###autoload
|
||
|
|
(defmacro define-toggle-old (symbol value doc &rest args)
|
||
|
|
(declare (doc-string 3))
|
||
|
|
(list
|
||
|
|
'progn
|
||
|
|
(let ((var-decl (list 'custom-declare-variable
|
||
|
|
(list 'quote symbol)
|
||
|
|
(list 'quote value)
|
||
|
|
doc)))
|
||
|
|
(while args
|
||
|
|
(let ((arg (car args)))
|
||
|
|
(setq args (cdr args))
|
||
|
|
(unless (symbolp arg)
|
||
|
|
(error "Junk in args %S" args))
|
||
|
|
(let ((keyword arg)
|
||
|
|
(value (car args)))
|
||
|
|
(unless args
|
||
|
|
(error "Keyword %s is missing an argument" keyword))
|
||
|
|
(setq args (cdr args))
|
||
|
|
(cond
|
||
|
|
((not (memq keyword '(:type)))
|
||
|
|
(setq var-decl (append var-decl (list keyword value))))
|
||
|
|
(t
|
||
|
|
(lwarn '(define-toggle) :error "Keyword %s can't be used here"
|
||
|
|
keyword))))))
|
||
|
|
(when (assoc :type var-decl) (error ":type is set. Should not happen!"))
|
||
|
|
(setq var-decl (append var-decl (list :type '(quote boolean))))
|
||
|
|
var-decl)
|
||
|
|
(let* ((SYMBOL-toggle (intern (concat (symbol-name symbol) "-toggle")))
|
||
|
|
(SYMBOL-name (symbol-name symbol))
|
||
|
|
(fun-doc (concat "Toggles the \(boolean) value of `"
|
||
|
|
SYMBOL-name
|
||
|
|
"'.\n"
|
||
|
|
"For how to set it permanently see this variable.\n"
|
||
|
|
;;"\nDescription of `" SYMBOL-name "':\n" doc
|
||
|
|
)))
|
||
|
|
`(defun ,SYMBOL-toggle ()
|
||
|
|
,fun-doc
|
||
|
|
(interactive)
|
||
|
|
(customize-set-variable (quote ,symbol) (not ,symbol)))
|
||
|
|
)))
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;;;; Indentation of regions
|
||
|
|
|
||
|
|
;; From an idea by weber <hugows@gmail.com>
|
||
|
|
;; (defun indent-line-or-region ()
|
||
|
|
;; "Indent line or region.
|
||
|
|
;; Only do this if indentation seems bound to \\t.
|
||
|
|
|
||
|
|
;; Call `indent-region' if region is active, otherwise
|
||
|
|
;; `indent-according-to-mode'."
|
||
|
|
;; (interactive)
|
||
|
|
;; ;; Do a wild guess if we should indent or not ...
|
||
|
|
;; (let* ((indent-region-mode)
|
||
|
|
;; ;; The above hides the `indent-line-or-region' binding
|
||
|
|
;; (t-bound (key-binding [?\t])))
|
||
|
|
;; (if (not
|
||
|
|
;; (save-match-data
|
||
|
|
;; (string-match "indent" (symbol-name t-bound))))
|
||
|
|
;; (call-interactively t-bound t)
|
||
|
|
;; (if (and mark-active ;; there is a visible region selected
|
||
|
|
;; transient-mark-mode)
|
||
|
|
;; (indent-region (region-beginning) (region-end))
|
||
|
|
;; (indent-according-to-mode))))) ;; indent line
|
||
|
|
|
||
|
|
;; (define-minor-mode indent-region-mode
|
||
|
|
;; "Use \\t to indent line or region.
|
||
|
|
;; The key \\t is bound to `indent-line-or-region' if this mode is
|
||
|
|
;; on."
|
||
|
|
;; :global t
|
||
|
|
;; :keymap '(([?\t] . indent-line-or-region)))
|
||
|
|
;; (when indent-region-mode (indent-region-mode 1))
|
||
|
|
|
||
|
|
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;;;; Minor modes
|
||
|
|
|
||
|
|
;; (defmacro define-globalized-minor-mode-with-on-off (global-mode mode
|
||
|
|
;; turn-on turn-off
|
||
|
|
;; &rest keys)
|
||
|
|
;; "Make a global mode GLOBAL-MODE corresponding to buffer-local minor MODE.
|
||
|
|
;; This is a special variant of `define-globalized-minor-mode' for
|
||
|
|
;; mumamo. It let bounds the variable GLOBAL-MODE-checking before
|
||
|
|
;; calling TURN-ON or TURN-OFF.
|
||
|
|
|
||
|
|
;; TURN-ON is a function that will be called with no args in every buffer
|
||
|
|
;; and that should try to turn MODE on if applicable for that buffer.
|
||
|
|
;; TURN-OFF is a function that turns off MODE in a buffer.
|
||
|
|
;; KEYS is a list of CL-style keyword arguments. As the minor mode
|
||
|
|
;; defined by this function is always global, any :global keyword is
|
||
|
|
;; ignored. Other keywords have the same meaning as in `define-minor-mode',
|
||
|
|
;; which see. In particular, :group specifies the custom group.
|
||
|
|
;; The most useful keywords are those that are passed on to the
|
||
|
|
;; `defcustom'. It normally makes no sense to pass the :lighter
|
||
|
|
;; or :keymap keywords to `define-globalized-minor-mode', since these
|
||
|
|
;; are usually passed to the buffer-local version of the minor mode.
|
||
|
|
|
||
|
|
;; If MODE's set-up depends on the major mode in effect when it was
|
||
|
|
;; enabled, then disabling and reenabling MODE should make MODE work
|
||
|
|
;; correctly with the current major mode. This is important to
|
||
|
|
;; prevent problems with derived modes, that is, major modes that
|
||
|
|
;; call another major mode in their body."
|
||
|
|
|
||
|
|
;; (let* ((global-mode-name (symbol-name global-mode))
|
||
|
|
;; (pretty-name (easy-mmode-pretty-mode-name mode))
|
||
|
|
;; (pretty-global-name (easy-mmode-pretty-mode-name global-mode))
|
||
|
|
;; (group nil)
|
||
|
|
;; (extra-keywords nil)
|
||
|
|
;; (MODE-buffers (intern (concat global-mode-name "-buffers")))
|
||
|
|
;; (MODE-enable-in-buffers
|
||
|
|
;; (intern (concat global-mode-name "-enable-in-buffers")))
|
||
|
|
;; (MODE-check-buffers
|
||
|
|
;; (intern (concat global-mode-name "-check-buffers")))
|
||
|
|
;; (MODE-cmhh (intern (concat global-mode-name "-cmhh")))
|
||
|
|
;; (MODE-major-mode (intern (concat (symbol-name mode)
|
||
|
|
;; "-major-mode")))
|
||
|
|
;; (MODE-checking (intern (concat global-mode-name "-checking")))
|
||
|
|
;; keyw)
|
||
|
|
|
||
|
|
;; ;; Check keys.
|
||
|
|
;; (while (keywordp (setq keyw (car keys)))
|
||
|
|
;; (setq keys (cdr keys))
|
||
|
|
;; (case keyw
|
||
|
|
;; (:group (setq group (nconc group (list :group (pop keys)))))
|
||
|
|
;; (:global (setq keys (cdr keys)))
|
||
|
|
;; (t (push keyw extra-keywords) (push (pop keys) extra-keywords))))
|
||
|
|
|
||
|
|
;; (unless group
|
||
|
|
;; ;; We might as well provide a best-guess default group.
|
||
|
|
;; (setq group
|
||
|
|
;; `(:group ',(intern (replace-regexp-in-string
|
||
|
|
;; "-mode\\'" "" (symbol-name mode))))))
|
||
|
|
|
||
|
|
;; `(progn
|
||
|
|
|
||
|
|
;; ;; Define functions for the global mode first so that it can be
|
||
|
|
;; ;; turned on during load:
|
||
|
|
|
||
|
|
;; ;; List of buffers left to process.
|
||
|
|
;; (defvar ,MODE-buffers nil)
|
||
|
|
|
||
|
|
;; ;; The function that calls TURN-ON in each buffer.
|
||
|
|
;; (defun ,MODE-enable-in-buffers ()
|
||
|
|
;; (let ((,MODE-checking nil))
|
||
|
|
;; (dolist (buf ,MODE-buffers)
|
||
|
|
;; (when (buffer-live-p buf)
|
||
|
|
;; (with-current-buffer buf
|
||
|
|
;; (if ,mode
|
||
|
|
;; (unless (eq ,MODE-major-mode major-mode)
|
||
|
|
;; (setq ,MODE-checking t)
|
||
|
|
;; (,mode -1)
|
||
|
|
;; (,turn-on)
|
||
|
|
;; (setq ,MODE-checking nil)
|
||
|
|
;; (setq ,MODE-major-mode major-mode))
|
||
|
|
;; (setq ,MODE-checking t)
|
||
|
|
;; (,turn-on)
|
||
|
|
;; (setq ,MODE-checking nil)
|
||
|
|
;; (setq ,MODE-major-mode major-mode)))))))
|
||
|
|
;; (put ',MODE-enable-in-buffers 'definition-name ',global-mode)
|
||
|
|
|
||
|
|
;; (defun ,MODE-check-buffers ()
|
||
|
|
;; (,MODE-enable-in-buffers)
|
||
|
|
;; (setq ,MODE-buffers nil)
|
||
|
|
;; (remove-hook 'post-command-hook ',MODE-check-buffers))
|
||
|
|
;; (put ',MODE-check-buffers 'definition-name ',global-mode)
|
||
|
|
|
||
|
|
;; ;; The function that catches kill-all-local-variables.
|
||
|
|
;; (defun ,MODE-cmhh ()
|
||
|
|
;; (add-to-list ',MODE-buffers (current-buffer))
|
||
|
|
;; (add-hook 'post-command-hook ',MODE-check-buffers))
|
||
|
|
;; (put ',MODE-cmhh 'definition-name ',global-mode)
|
||
|
|
|
||
|
|
|
||
|
|
;; (defvar ,MODE-major-mode nil)
|
||
|
|
;; (make-variable-buffer-local ',MODE-major-mode)
|
||
|
|
|
||
|
|
;; ;; The actual global minor-mode
|
||
|
|
;; (define-minor-mode ,global-mode
|
||
|
|
;; ,(format "Toggle %s in every possible buffer.
|
||
|
|
;; With prefix ARG, turn %s on if and only if ARG is positive.
|
||
|
|
;; %s is enabled in all buffers where `%s' would do it.
|
||
|
|
;; See `%s' for more information on %s."
|
||
|
|
;; pretty-name pretty-global-name pretty-name turn-on
|
||
|
|
;; mode pretty-name)
|
||
|
|
;; :global t ,@group ,@(nreverse extra-keywords)
|
||
|
|
|
||
|
|
;; ;; Setup hook to handle future mode changes and new buffers.
|
||
|
|
;; (if ,global-mode
|
||
|
|
;; (progn
|
||
|
|
;; (add-hook 'after-change-major-mode-hook
|
||
|
|
;; ',MODE-enable-in-buffers)
|
||
|
|
;; ;;(add-hook 'find-file-hook ',MODE-check-buffers)
|
||
|
|
;; (add-hook 'find-file-hook ',MODE-cmhh)
|
||
|
|
;; (add-hook 'change-major-mode-hook ',MODE-cmhh))
|
||
|
|
;; (remove-hook 'after-change-major-mode-hook ',MODE-enable-in-buffers)
|
||
|
|
;; ;;(remove-hook 'find-file-hook ',MODE-check-buffers)
|
||
|
|
;; (remove-hook 'find-file-hook ',MODE-cmhh)
|
||
|
|
;; (remove-hook 'change-major-mode-hook ',MODE-cmhh))
|
||
|
|
|
||
|
|
;; ;; Go through existing buffers.
|
||
|
|
;; (let ((,MODE-checking t))
|
||
|
|
;; (dolist (buf (buffer-list))
|
||
|
|
;; (with-current-buffer buf
|
||
|
|
;; ;;(if ,global-mode (,turn-on) (when ,mode (,mode -1)))
|
||
|
|
;; (if ,global-mode (,turn-on) (,turn-off))
|
||
|
|
;; ))))
|
||
|
|
|
||
|
|
;; )))
|
||
|
|
|
||
|
|
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;;;; Unfilling
|
||
|
|
;;
|
||
|
|
;; The idea is from
|
||
|
|
;; http://interglacial.com/~sburke/pub/emacs/sburke_dot_emacs.config
|
||
|
|
|
||
|
|
;;;###autoload
|
||
|
|
(defun unfill-paragraph ()
|
||
|
|
"Unfill the current paragraph."
|
||
|
|
(interactive) (with-unfilling 'fill-paragraph))
|
||
|
|
;;(defalias 'unwrap-paragraph 'unfill-paragraph)
|
||
|
|
|
||
|
|
;;;###autoload
|
||
|
|
(defun unfill-region ()
|
||
|
|
"Unfill the current region."
|
||
|
|
(interactive) (with-unfilling 'fill-region))
|
||
|
|
;;(defalias 'unwrap-region 'unfill-region)
|
||
|
|
|
||
|
|
;;;###autoload
|
||
|
|
(defun unfill-individual-paragraphs ()
|
||
|
|
"Unfill individual paragraphs in the current region."
|
||
|
|
(interactive) (with-unfilling 'fill-individual-paragraphs))
|
||
|
|
;;(defalias 'unwrap-individual-paragraphs 'unfill-individual-paragraphs)
|
||
|
|
|
||
|
|
(defun with-unfilling (fn)
|
||
|
|
"Unfill using the fill function FN."
|
||
|
|
(let ((fill-column (1+ (point-max)))) (call-interactively fn)))
|
||
|
|
|
||
|
|
(defvar fill-dwim-state nil)
|
||
|
|
(defvar fill-dwim-mark nil)
|
||
|
|
|
||
|
|
;;;###autoload
|
||
|
|
(defun fill-dwim (arg)
|
||
|
|
"Fill or unfill paragraph or region.
|
||
|
|
With prefix ARG fill only current line."
|
||
|
|
(interactive "P")
|
||
|
|
(or arg
|
||
|
|
(not fill-dwim-mark)
|
||
|
|
(equal (point-marker) fill-dwim-mark)
|
||
|
|
(setq fill-dwim-state nil))
|
||
|
|
(if mark-active
|
||
|
|
;; This avoids deactivating the mark
|
||
|
|
(progn
|
||
|
|
(if fill-dwim-state
|
||
|
|
(call-interactively 'unfill-region)
|
||
|
|
(call-interactively 'fill-region))
|
||
|
|
(setq deactivate-mark nil))
|
||
|
|
(if arg
|
||
|
|
(fill-region (line-beginning-position) (line-end-position))
|
||
|
|
(if fill-dwim-state
|
||
|
|
(call-interactively 'unfill-paragraph)
|
||
|
|
(call-interactively 'fill-paragraph))))
|
||
|
|
(setq fill-dwim-mark (copy-marker (point)))
|
||
|
|
(unless arg
|
||
|
|
(setq fill-dwim-state (not fill-dwim-state))))
|
||
|
|
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;;;; Widgets
|
||
|
|
|
||
|
|
;;;###autoload
|
||
|
|
(defun ourcomments-mark-whole-buffer-or-field ()
|
||
|
|
"Mark whole buffer or editable field at point."
|
||
|
|
(interactive)
|
||
|
|
(let* ((field (widget-field-at (point)))
|
||
|
|
(from (when field (widget-field-start field)))
|
||
|
|
(to (when field (widget-field-end field)))
|
||
|
|
(size (when field (widget-get field :size))))
|
||
|
|
(if (not field)
|
||
|
|
(mark-whole-buffer)
|
||
|
|
(while (and size
|
||
|
|
(not (zerop size))
|
||
|
|
(> to from)
|
||
|
|
(eq (char-after (1- to)) ?\s))
|
||
|
|
(setq to (1- to)))
|
||
|
|
(push-mark (point))
|
||
|
|
(push-mark from nil t)
|
||
|
|
(goto-char to))))
|
||
|
|
|
||
|
|
;; (rassq 'genshi-nxhtml-mumamo-mode mumamo-defined-turn-on-functions)
|
||
|
|
;; (major-modep 'nxhtml-mode)
|
||
|
|
;; (major-modep 'nxhtml-mumamo-mode)
|
||
|
|
;; (major-modep 'jsp-nxhtml-mumamo-mode)
|
||
|
|
;; (major-modep 'gsp-nxhtml-mumamo-mode)
|
||
|
|
;; (major-modep 'asp-nxhtml-mumamo-mode)
|
||
|
|
;; (major-modep 'django-nxhtml-mumamo-mode)
|
||
|
|
;; (major-modep 'eruby-nxhtml-mumamo-mode)
|
||
|
|
;; (major-modep 'eruby-nxhtml-mumamo-mode)
|
||
|
|
;; (major-modep 'smarty-nxhtml-mumamo-mode)
|
||
|
|
;; (major-modep 'embperl-nxhtml-mumamo-mode)
|
||
|
|
;; (major-modep 'laszlo-nxml-mumamo-mode)
|
||
|
|
;; (major-modep 'genshi-nxhtml-mumamo-mode)
|
||
|
|
;; (major-modep 'javascript-mode)
|
||
|
|
;; (major-modep 'espresso-mode)
|
||
|
|
;; (major-modep 'css-mode)
|
||
|
|
;; (major-modep 'js-mode)
|
||
|
|
|
||
|
|
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;;;; Lines
|
||
|
|
|
||
|
|
;; Changed from move-beginning-of-line to beginning-of-line to support
|
||
|
|
;; physical-line-mode.
|
||
|
|
;; Fix-me: use end-of-visual-line etc.
|
||
|
|
;;;###autoload
|
||
|
|
(defun ourcomments-move-beginning-of-line(arg)
|
||
|
|
"Move point to beginning of line or indentation.
|
||
|
|
See `beginning-of-line' for ARG.
|
||
|
|
|
||
|
|
If `line-move-visual' is non-nil then the visual line beginning
|
||
|
|
is first tried.
|
||
|
|
|
||
|
|
If in a widget field stay in that."
|
||
|
|
(interactive "p")
|
||
|
|
(let ((pos (point))
|
||
|
|
vis-pos
|
||
|
|
(field (widget-field-at (point))))
|
||
|
|
(when line-move-visual
|
||
|
|
(line-move-visual -1 t)
|
||
|
|
(beginning-of-line)
|
||
|
|
(setq vis-pos (point))
|
||
|
|
(goto-char pos))
|
||
|
|
(call-interactively 'beginning-of-line arg)
|
||
|
|
(when (and vis-pos
|
||
|
|
(= vis-pos (point)))
|
||
|
|
(while (and (> pos (point))
|
||
|
|
(not (eobp)))
|
||
|
|
(let (last-command)
|
||
|
|
(line-move-visual 1 t)))
|
||
|
|
(line-move-visual -1 t))
|
||
|
|
(when (= pos (point))
|
||
|
|
(if (= 0 (current-column))
|
||
|
|
(skip-chars-forward " \t")
|
||
|
|
(backward-char)
|
||
|
|
(beginning-of-line)))
|
||
|
|
(when (and field
|
||
|
|
(< (point) (widget-field-start field)))
|
||
|
|
(goto-char (widget-field-start field)))))
|
||
|
|
(put 'ourcomments-move-beginning-of-line 'CUA 'move)
|
||
|
|
|
||
|
|
;;;###autoload
|
||
|
|
(defun ourcomments-move-end-of-line(arg)
|
||
|
|
"Move point to end of line or after last non blank char.
|
||
|
|
See `end-of-line' for ARG.
|
||
|
|
|
||
|
|
Similar to `ourcomments-move-beginning-of-line' but for end of
|
||
|
|
line."
|
||
|
|
(interactive "p")
|
||
|
|
(or arg (setq arg 1))
|
||
|
|
(let ((pos (point))
|
||
|
|
vis-pos
|
||
|
|
eol-pos)
|
||
|
|
(when line-move-visual
|
||
|
|
(let (last-command) (line-move-visual 1 t))
|
||
|
|
(end-of-line)
|
||
|
|
(setq vis-pos (point))
|
||
|
|
(goto-char pos))
|
||
|
|
(call-interactively 'end-of-line arg)
|
||
|
|
(when (and vis-pos
|
||
|
|
(= vis-pos (point)))
|
||
|
|
(setq eol-pos (point))
|
||
|
|
(beginning-of-line)
|
||
|
|
(let (last-command) (line-move-visual 1 t))
|
||
|
|
;; move backwards if we moved to a new line
|
||
|
|
(unless (= (point) eol-pos)
|
||
|
|
(backward-char)))
|
||
|
|
(when (= pos (point))
|
||
|
|
(if (= (line-end-position) (point))
|
||
|
|
(skip-chars-backward " \t")
|
||
|
|
(forward-char)
|
||
|
|
(end-of-line)))))
|
||
|
|
(put 'ourcomments-move-end-of-line 'CUA 'move)
|
||
|
|
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;;;; Keymaps
|
||
|
|
|
||
|
|
(defun ourcomments-find-keymap-variables (key--- binding--- keymap---)
|
||
|
|
"Return a list of matching keymap variables.
|
||
|
|
They should have key KEY--- bound to BINDING--- and have value
|
||
|
|
KEYMAP---.
|
||
|
|
|
||
|
|
Ignore `special-event-map', `global-map', `overriding-local-map'
|
||
|
|
and `overriding-terminal-local-map'."
|
||
|
|
(let ((vars--- nil)
|
||
|
|
(ancestors--- nil))
|
||
|
|
(let ((parent (keymap-parent keymap---)))
|
||
|
|
(while parent
|
||
|
|
(setq ancestors--- (cons parent ancestors---))
|
||
|
|
(setq parent (keymap-parent parent))))
|
||
|
|
(mapatoms (lambda (symbol)
|
||
|
|
(unless (memq symbol '(keymap---
|
||
|
|
ancestors---
|
||
|
|
vars---
|
||
|
|
special-event-map
|
||
|
|
global-map
|
||
|
|
overriding-local-map
|
||
|
|
overriding-terminal-local-map
|
||
|
|
))
|
||
|
|
(let (val)
|
||
|
|
(if (boundp symbol)
|
||
|
|
(setq val (symbol-value symbol))
|
||
|
|
(when (keymapp symbol)
|
||
|
|
(setq val (symbol-function symbol))))
|
||
|
|
(when (and val
|
||
|
|
(keymapp val)
|
||
|
|
(eq binding--- (lookup-key val key--- t)))
|
||
|
|
(if (equal val keymap---)
|
||
|
|
(push symbol vars---)
|
||
|
|
(when ancestors---
|
||
|
|
(catch 'found
|
||
|
|
(dolist (ancestor ancestors---)
|
||
|
|
(when (equal val ancestor)
|
||
|
|
(push symbol vars---)
|
||
|
|
(throw 'found nil)))))))))))
|
||
|
|
;;; (let ((childs nil))
|
||
|
|
;;; (dolist (var vars---)
|
||
|
|
;;; (dolist (ancestor ancestors---)
|
||
|
|
;;; (when (equal (keymap-parent var)
|
||
|
|
;;; (
|
||
|
|
vars---))
|
||
|
|
|
||
|
|
;; This is modelled after `current-active-maps'.
|
||
|
|
(defun key-bindings (key &optional olp position)
|
||
|
|
"Return list of bindings for key sequence KEY in current keymaps.
|
||
|
|
The first binding is the active binding and the others are
|
||
|
|
bindings shadowed by this in the order of their priority level
|
||
|
|
\(see Info node `(elisp) Searching Keymaps').
|
||
|
|
|
||
|
|
The entries in the list have the form
|
||
|
|
|
||
|
|
\(BINDING (MAPS) MORE-INFO)
|
||
|
|
|
||
|
|
where BINDING is the command bound to and MAPS are matching maps
|
||
|
|
\(according to `ourcomments-find-keymap-variables').
|
||
|
|
|
||
|
|
MORE-INFO is a list with more information
|
||
|
|
|
||
|
|
\(PRIORITY-LEVEL \[ACTIVE-WHEN])
|
||
|
|
|
||
|
|
where PRIORITY-LEVEL is a symbol matching the level where the
|
||
|
|
keymap is found and ACTIVE-WHEN is a symbol which must be non-nil
|
||
|
|
for the keymap to be active \(minor mode levels only)."
|
||
|
|
;;(message "\nkey-bindings %s %s %s" key olp position)
|
||
|
|
(let* ((bindings nil)
|
||
|
|
(maps (current-active-maps))
|
||
|
|
map
|
||
|
|
map-sym
|
||
|
|
map-rec
|
||
|
|
binding
|
||
|
|
keymaps
|
||
|
|
minor-maps
|
||
|
|
where
|
||
|
|
map-where
|
||
|
|
where-map
|
||
|
|
(local-map (current-local-map))
|
||
|
|
(pt (or position (point)))
|
||
|
|
(point-keymap (get-char-property pt 'keymap))
|
||
|
|
(point-local-map (get-char-property pt 'local-map))
|
||
|
|
)
|
||
|
|
(setq keymaps
|
||
|
|
(cons (list global-map 'global-map)
|
||
|
|
keymaps))
|
||
|
|
(when overriding-terminal-local-map
|
||
|
|
(setq keymaps
|
||
|
|
(cons (list overriding-terminal-local-map 'overriding-terminal-local-map)
|
||
|
|
keymaps)))
|
||
|
|
(when overriding-local-map
|
||
|
|
(setq keymaps
|
||
|
|
(cons (list overriding-local-map 'overriding-local-map)
|
||
|
|
keymaps)))
|
||
|
|
(unless (cdr keymaps)
|
||
|
|
(when point-local-map
|
||
|
|
(setq keymaps
|
||
|
|
(cons (list point-local-map 'point-local-map)
|
||
|
|
keymaps)))
|
||
|
|
;; Fix-me:
|
||
|
|
;;/* If on a mode line string with a local keymap,
|
||
|
|
|
||
|
|
(when local-map
|
||
|
|
(setq keymaps
|
||
|
|
(cons (list local-map 'local-map)
|
||
|
|
keymaps)))
|
||
|
|
|
||
|
|
;; Minor-modes
|
||
|
|
;;(message "================ Minor-modes")
|
||
|
|
(dolist (list '(emulation-mode-map-alists
|
||
|
|
minor-mode-overriding-map-alist
|
||
|
|
minor-mode-map-alist))
|
||
|
|
;;(message "------- %s" list)
|
||
|
|
(let ((alists (if (eq list 'emulation-mode-map-alists)
|
||
|
|
(symbol-value list)
|
||
|
|
(list (symbol-value list)))))
|
||
|
|
(dolist (alist alists)
|
||
|
|
;;(message "\n(symbolp alist)=%s alist= %s (symbol-value alist)=%s" (symbolp alist) "dum" "dum2") ;alist "dummy");(when (symbolp alist) (symbol-value alist)))
|
||
|
|
(when (symbolp alist)
|
||
|
|
(setq alist (symbol-value alist)))
|
||
|
|
(dolist (assoc alist)
|
||
|
|
(let* (;(assoc (car alist-rec))
|
||
|
|
(var (when (consp assoc) (car assoc)))
|
||
|
|
(val (when (and (symbolp var)
|
||
|
|
(boundp var))
|
||
|
|
(symbol-value var))))
|
||
|
|
;;(message "var= %s, val= %s" var val)
|
||
|
|
(when (and
|
||
|
|
val
|
||
|
|
(or (not (eq list 'minor-mode-map-alist))
|
||
|
|
(not (assq var minor-mode-overriding-map-alist))))
|
||
|
|
;;(message "** Adding this")
|
||
|
|
(setq minor-maps
|
||
|
|
(cons (list (cdr assoc) list var)
|
||
|
|
minor-maps)))
|
||
|
|
)))))
|
||
|
|
(dolist (map minor-maps)
|
||
|
|
;;(message "cdr map= %s" (cdr map))
|
||
|
|
(setq keymaps
|
||
|
|
(cons map
|
||
|
|
keymaps)))
|
||
|
|
(when point-keymap
|
||
|
|
(setq keymaps
|
||
|
|
(cons (list point-keymap 'point-keymap)
|
||
|
|
keymaps))))
|
||
|
|
|
||
|
|
;; Fix-me: compare with current-active-maps
|
||
|
|
(let ((ca-maps (current-active-maps))
|
||
|
|
(wh-maps keymaps)
|
||
|
|
ca
|
||
|
|
wh)
|
||
|
|
(while (or ca-maps wh-maps)
|
||
|
|
(setq ca (car ca-maps))
|
||
|
|
(setq wh (car wh-maps))
|
||
|
|
(setq ca-maps (cdr ca-maps))
|
||
|
|
(setq wh-maps (cdr wh-maps))
|
||
|
|
;;(message "\nca= %s" ca)
|
||
|
|
;;(message "cdr wh= %s" (cdr wh))
|
||
|
|
(unless (equal ca (car wh))
|
||
|
|
(error "Did not match: %s" (cdr wh)))))
|
||
|
|
|
||
|
|
(while keymaps
|
||
|
|
(setq map-rec (car keymaps))
|
||
|
|
(setq map (car map-rec))
|
||
|
|
(when (setq binding (lookup-key map key t))
|
||
|
|
(setq map-sym (ourcomments-find-keymap-variables key binding map))
|
||
|
|
(setq map-sym (delq 'map map-sym))
|
||
|
|
(setq map-sym (delq 'local-map map-sym))
|
||
|
|
(setq map-sym (delq 'point-keymap map-sym))
|
||
|
|
(setq map-sym (delq 'point-local-map map-sym))
|
||
|
|
(setq bindings (cons (list binding map-sym (cdr map-rec)) bindings)))
|
||
|
|
(setq keymaps (cdr keymaps)))
|
||
|
|
|
||
|
|
(nreverse bindings)))
|
||
|
|
|
||
|
|
(defun describe-keymap-placement (keymap-sym)
|
||
|
|
"Find minor mode keymap KEYMAP-SYM in the keymaps searched for key lookup.
|
||
|
|
See Info node `Searching Keymaps'."
|
||
|
|
;;(info "(elisp) Searching Keymaps")
|
||
|
|
(interactive (list (ourcomments-read-symbol "Describe minor mode keymap symbol"
|
||
|
|
(lambda (sym)
|
||
|
|
(and (boundp sym)
|
||
|
|
(keymapp (symbol-value sym)))))))
|
||
|
|
(unless (symbolp keymap-sym)
|
||
|
|
(error "Argument KEYMAP-SYM must be a symbol"))
|
||
|
|
(unless (keymapp (symbol-value keymap-sym))
|
||
|
|
(error "The value of argument KEYMAP-SYM must be a keymap"))
|
||
|
|
(with-output-to-temp-buffer (help-buffer)
|
||
|
|
(help-setup-xref (list #'describe-keymap-placement keymap-sym) (interactive-p))
|
||
|
|
(with-current-buffer (help-buffer)
|
||
|
|
(insert "Placement of keymap `")
|
||
|
|
(insert-text-button (symbol-name keymap-sym)
|
||
|
|
'action
|
||
|
|
(lambda (btn)
|
||
|
|
(describe-variable keymap-sym)))
|
||
|
|
(insert "'\nin minor modes activation maps:\n")
|
||
|
|
(let (found)
|
||
|
|
(dolist (map-root '(emulation-mode-map-alists
|
||
|
|
minor-mode-overriding-map-alist
|
||
|
|
minor-mode-map-alist
|
||
|
|
))
|
||
|
|
(dolist (emul-alist (symbol-value map-root))
|
||
|
|
;;(message "emul-alist=%s" emul-alist)
|
||
|
|
(dolist (keymap-alist
|
||
|
|
(if (memq map-root '(emulation-mode-map-alists))
|
||
|
|
(symbol-value emul-alist)
|
||
|
|
(list emul-alist)))
|
||
|
|
(let* ((map (cdr keymap-alist))
|
||
|
|
(first (catch 'first
|
||
|
|
(map-keymap (lambda (key def)
|
||
|
|
(throw 'first (cons key def)))
|
||
|
|
map)))
|
||
|
|
(key (car first))
|
||
|
|
(def (cdr first))
|
||
|
|
(keymap-variables (when (and key def)
|
||
|
|
(ourcomments-find-keymap-variables
|
||
|
|
(vector key) def map)))
|
||
|
|
(active-var (car keymap-alist))
|
||
|
|
)
|
||
|
|
(assert (keymapp map))
|
||
|
|
;;(message "keymap-alist=%s, %s" keymap-alist first)
|
||
|
|
;;(message "active-var=%s, %s" active-var keymap-variables)
|
||
|
|
(when (memq keymap-sym keymap-variables)
|
||
|
|
(setq found t)
|
||
|
|
(insert (format "\n`%s' " map-root))
|
||
|
|
(insert (propertize "<= Minor mode keymap list holding this map"
|
||
|
|
'face 'font-lock-doc-face))
|
||
|
|
(insert "\n")
|
||
|
|
(when (symbolp emul-alist)
|
||
|
|
(insert (format " `%s' " emul-alist))
|
||
|
|
(insert (propertize "<= Keymap alist variable" 'face 'font-lock-doc-face))
|
||
|
|
(insert "\n"))
|
||
|
|
;;(insert (format " `%s'\n" keymap-alist))
|
||
|
|
(insert (format " `%s' " active-var))
|
||
|
|
(insert (propertize "<= Activation variable" 'face 'font-lock-doc-face))
|
||
|
|
(insert "\n")
|
||
|
|
)))))
|
||
|
|
(unless found
|
||
|
|
(insert (propertize "Not found." 'face 'font-lock-warning-face)))
|
||
|
|
))))
|
||
|
|
|
||
|
|
;; This is a replacement for describe-key-briefly.
|
||
|
|
;;(global-set-key [f1 ?c] 'describe-key-and-map-briefly)
|
||
|
|
;;;###autoload
|
||
|
|
(defun describe-key-and-map-briefly (&optional key insert untranslated)
|
||
|
|
"Try to print names of keymap from which KEY fetch its definition.
|
||
|
|
Look in current active keymaps and find keymap variables with the
|
||
|
|
same value as the keymap where KEY is bound. Print a message
|
||
|
|
with those keymap variable names. Return a list with the keymap
|
||
|
|
variable symbols.
|
||
|
|
|
||
|
|
When called interactively prompt for KEY.
|
||
|
|
|
||
|
|
INSERT and UNTRANSLATED should normall be nil (and I am not sure
|
||
|
|
what they will do ;-)."
|
||
|
|
;; >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
|
||
|
|
;; From describe-key-briefly. Keep this as it is for easier update.
|
||
|
|
(interactive
|
||
|
|
(let ((enable-disabled-menus-and-buttons t)
|
||
|
|
(cursor-in-echo-area t)
|
||
|
|
saved-yank-menu)
|
||
|
|
(unwind-protect
|
||
|
|
(let (key)
|
||
|
|
;; If yank-menu is empty, populate it temporarily, so that
|
||
|
|
;; "Select and Paste" menu can generate a complete event.
|
||
|
|
(when (null (cdr yank-menu))
|
||
|
|
(setq saved-yank-menu (copy-sequence yank-menu))
|
||
|
|
(menu-bar-update-yank-menu "(any string)" nil))
|
||
|
|
(setq key (read-key-sequence "Describe key (or click or menu item): "))
|
||
|
|
;; If KEY is a down-event, read and discard the
|
||
|
|
;; corresponding up-event. Note that there are also
|
||
|
|
;; down-events on scroll bars and mode lines: the actual
|
||
|
|
;; event then is in the second element of the vector.
|
||
|
|
(and (vectorp key)
|
||
|
|
(let ((last-idx (1- (length key))))
|
||
|
|
(and (eventp (aref key last-idx))
|
||
|
|
(memq 'down (event-modifiers (aref key last-idx)))))
|
||
|
|
(read-event))
|
||
|
|
(list
|
||
|
|
key
|
||
|
|
(if current-prefix-arg (prefix-numeric-value current-prefix-arg))
|
||
|
|
1
|
||
|
|
))
|
||
|
|
;; Put yank-menu back as it was, if we changed it.
|
||
|
|
(when saved-yank-menu
|
||
|
|
(setq yank-menu (copy-sequence saved-yank-menu))
|
||
|
|
(fset 'yank-menu (cons 'keymap yank-menu))))))
|
||
|
|
(if (numberp untranslated)
|
||
|
|
(setq untranslated (this-single-command-raw-keys)))
|
||
|
|
(let* ((event (if (and (symbolp (aref key 0))
|
||
|
|
(> (length key) 1)
|
||
|
|
(consp (aref key 1)))
|
||
|
|
(aref key 1)
|
||
|
|
(aref key 0)))
|
||
|
|
(modifiers (event-modifiers event))
|
||
|
|
(standard-output (if insert (current-buffer) t))
|
||
|
|
(mouse-msg (if (or (memq 'click modifiers) (memq 'down modifiers)
|
||
|
|
(memq 'drag modifiers)) " at that spot" ""))
|
||
|
|
(defn (key-binding key t))
|
||
|
|
key-desc)
|
||
|
|
;; Handle the case where we faked an entry in "Select and Paste" menu.
|
||
|
|
(if (and (eq defn nil)
|
||
|
|
(stringp (aref key (1- (length key))))
|
||
|
|
(eq (key-binding (substring key 0 -1)) 'yank-menu))
|
||
|
|
(setq defn 'menu-bar-select-yank))
|
||
|
|
;; Don't bother user with strings from (e.g.) the select-paste menu.
|
||
|
|
(if (stringp (aref key (1- (length key))))
|
||
|
|
(aset key (1- (length key)) "(any string)"))
|
||
|
|
(if (and (> (length untranslated) 0)
|
||
|
|
(stringp (aref untranslated (1- (length untranslated)))))
|
||
|
|
(aset untranslated (1- (length untranslated)) "(any string)"))
|
||
|
|
;; Now describe the key, perhaps as changed.
|
||
|
|
(setq key-desc (help-key-description key untranslated))
|
||
|
|
;;
|
||
|
|
;; End of part from describe-key-briefly.
|
||
|
|
;; <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
|
||
|
|
|
||
|
|
;;(message "bindings=%s" (key-bindings key)) (sit-for 2)
|
||
|
|
;; Find the keymap:
|
||
|
|
(let* ((maps (current-active-maps))
|
||
|
|
ret
|
||
|
|
lk)
|
||
|
|
(if (or (null defn) (integerp defn) (equal defn 'undefined))
|
||
|
|
(setq ret 'not-defined)
|
||
|
|
(catch 'mapped
|
||
|
|
(while (< 1 (length maps))
|
||
|
|
(setq lk (lookup-key (car maps) key t))
|
||
|
|
(when (and lk (not (numberp lk)))
|
||
|
|
(setq ret (ourcomments-find-keymap-variables key lk (car maps)))
|
||
|
|
(when ret
|
||
|
|
(throw 'mapped (car maps))))
|
||
|
|
(setq maps (cdr maps))))
|
||
|
|
(unless ret
|
||
|
|
(setq lk (lookup-key global-map key t))
|
||
|
|
(when (and lk (not (numberp lk)))
|
||
|
|
(setq ret '(global-map)))))
|
||
|
|
(cond
|
||
|
|
((eq ret 'not-defined)
|
||
|
|
(message "%s%s not defined in any keymap" key-desc mouse-msg))
|
||
|
|
((listp ret)
|
||
|
|
(if (not ret)
|
||
|
|
(message "%s%s is bound to `%s', but don't know where"
|
||
|
|
key-desc mouse-msg defn)
|
||
|
|
(if (= 1 (length ret))
|
||
|
|
(message "%s%s is bound to `%s' in `%s'"
|
||
|
|
key-desc mouse-msg defn (car ret))
|
||
|
|
(message "%s%s is bound to `%s' in keymap variables `%s'"
|
||
|
|
key-desc mouse-msg defn ret))))
|
||
|
|
(t
|
||
|
|
(error "ret=%s" ret)))
|
||
|
|
ret)))
|
||
|
|
|
||
|
|
;; (ourcomments-find-keymap-variables (current-local-map))
|
||
|
|
;; (keymapp 'ctl-x-4-prefix)
|
||
|
|
;; (equal 'ctl-x-4-prefix (current-local-map))
|
||
|
|
;;
|
||
|
|
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;;;; Fringes.
|
||
|
|
|
||
|
|
(defvar better-bottom-angles-defaults nil)
|
||
|
|
(defun better-fringes-bottom-angles (on)
|
||
|
|
;;(bottom bottom-left-angle bottom-right-angle top-right-angle top-left-angle)
|
||
|
|
(if (not on)
|
||
|
|
(when better-bottom-angles-defaults
|
||
|
|
(set-default 'fringe-indicator-alist better-bottom-angles-defaults))
|
||
|
|
(unless better-bottom-angles-defaults
|
||
|
|
(setq better-bottom-angles-defaults fringe-indicator-alist))
|
||
|
|
(let ((better
|
||
|
|
'(bottom
|
||
|
|
bottom-right-angle bottom-right-angle
|
||
|
|
bottom-left-angle bottom-left-angle
|
||
|
|
))
|
||
|
|
;;(indicators (copy-list fringe-indicator-alist)))
|
||
|
|
(indicators (copy-sequence fringe-indicator-alist)))
|
||
|
|
(setq indicators (assq-delete-all 'bottom indicators))
|
||
|
|
(set-default 'fringe-indicator-alist (cons better indicators)))))
|
||
|
|
|
||
|
|
(defun better-fringes-faces (face face-important)
|
||
|
|
(dolist (bitmap '(bottom-left-angle
|
||
|
|
bottom-right-angle
|
||
|
|
top-left-angle
|
||
|
|
top-right-angle
|
||
|
|
|
||
|
|
right-curly-arrow
|
||
|
|
left-arrow right-arrow
|
||
|
|
left-curly-arrow right-curly-arrow
|
||
|
|
up-arrow
|
||
|
|
down-arrow
|
||
|
|
left-bracket right-bracket
|
||
|
|
empty-line))
|
||
|
|
(set-fringe-bitmap-face bitmap face))
|
||
|
|
(dolist (bitmap '(right-triangle
|
||
|
|
question-mark))
|
||
|
|
(set-fringe-bitmap-face bitmap face-important)))
|
||
|
|
|
||
|
|
(defface better-fringes-bitmap
|
||
|
|
'((t (:foreground "dark khaki")))
|
||
|
|
"Face for bitmap fringes."
|
||
|
|
:group 'better-fringes
|
||
|
|
:group 'nxhtml)
|
||
|
|
|
||
|
|
(defface better-fringes-important-bitmap
|
||
|
|
'((t (:foreground "red")))
|
||
|
|
"Face for bitmap fringes."
|
||
|
|
:group 'better-fringes
|
||
|
|
:group 'nxhtml)
|
||
|
|
|
||
|
|
;;;###autoload
|
||
|
|
(define-minor-mode better-fringes-mode
|
||
|
|
"Choose another fringe bitmap color and bottom angle."
|
||
|
|
:global t
|
||
|
|
:group 'better-fringes
|
||
|
|
(if better-fringes-mode
|
||
|
|
(progn
|
||
|
|
(better-fringes-faces 'better-fringes-bitmap
|
||
|
|
'better-fringes-important-bitmap)
|
||
|
|
(better-fringes-bottom-angles t))
|
||
|
|
(better-fringes-faces nil nil)
|
||
|
|
(better-fringes-bottom-angles nil)))
|
||
|
|
|
||
|
|
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;;;; Copy+paste
|
||
|
|
|
||
|
|
;; After an idea from andrea on help-gnu-emacs
|
||
|
|
|
||
|
|
(defvar ourcomments-copy+paste-point nil)
|
||
|
|
|
||
|
|
;;(global-set-key [(control ?c) ?y] 'ourcomments-copy+paste-set-point)
|
||
|
|
;;;###autoload
|
||
|
|
(defun ourcomments-copy+paste-set-point ()
|
||
|
|
"Set point for copy+paste here.
|
||
|
|
Enable temporary minor mode `ourcomments-copy+paste-mode'.
|
||
|
|
However if point for copy+paste already is set then cancel it and
|
||
|
|
disable the minor mode.
|
||
|
|
|
||
|
|
The purpose of this command is to make it easy to grab a piece of
|
||
|
|
text and paste it at current position. After this command you
|
||
|
|
should select a piece of text to copy and then call the command
|
||
|
|
`ourcomments-copy+paste'."
|
||
|
|
(interactive)
|
||
|
|
(if ourcomments-copy+paste-point
|
||
|
|
(ourcomments-copy+paste-mode -1)
|
||
|
|
(setq ourcomments-copy+paste-point (list (copy-marker (point))
|
||
|
|
(selected-window)
|
||
|
|
(current-frame-configuration)
|
||
|
|
))
|
||
|
|
(ourcomments-copy+paste-mode 1)
|
||
|
|
(let ((key (where-is-internal 'ourcomments-copy+paste))
|
||
|
|
(ckeys (key-description (this-command-keys))))
|
||
|
|
(setq key (if key (key-description (car key))
|
||
|
|
"M-x ourcomments-copy+paste"))
|
||
|
|
(when (> (length ckeys) 12)
|
||
|
|
(setq ckeys "this command"))
|
||
|
|
(message "Paste point set; select region and do %s to copy+paste (or cancel with %s)" key ckeys))))
|
||
|
|
|
||
|
|
(defvar ourcomments-copy+paste-mode-map
|
||
|
|
(let ((map (make-sparse-keymap)))
|
||
|
|
;; Bind the copy+paste command to C-S-v which reminds of cua-paste
|
||
|
|
;; binding and is hopefully not bound.
|
||
|
|
(define-key map [(control shift ?v)] 'ourcomments-copy+paste)
|
||
|
|
map))
|
||
|
|
|
||
|
|
(define-minor-mode ourcomments-copy+paste-mode
|
||
|
|
"Temporary mode for copy+paste.
|
||
|
|
This minor mode is enabled by `ourcomments-copy+paste-set-point'.
|
||
|
|
|
||
|
|
When this mode is active there is a key binding for
|
||
|
|
`ourcomments-copy+paste':
|
||
|
|
\\<ourcomments-copy+paste-mode-map>
|
||
|
|
\\[ourcomments-copy+paste]
|
||
|
|
|
||
|
|
You should not turn on this minor mode yourself. It is turned on
|
||
|
|
by `ourcomments-copy+paste-set-point'. For more information see
|
||
|
|
that command."
|
||
|
|
:lighter " COPY+PASTE"
|
||
|
|
:global t
|
||
|
|
:group 'ourcomments-util
|
||
|
|
(if ourcomments-copy+paste-mode
|
||
|
|
(unless ourcomments-copy+paste-point
|
||
|
|
(message "Do not call this minor mode, use `ourcomments-copy+paste-set-point'.")
|
||
|
|
(setq ourcomments-copy+paste-mode nil))
|
||
|
|
(when ourcomments-copy+paste-point
|
||
|
|
(setq ourcomments-copy+paste-point nil)
|
||
|
|
(message "Canceled copy+paste mode"))))
|
||
|
|
|
||
|
|
(defvar ourcomments-copy+paste-ovl nil)
|
||
|
|
|
||
|
|
(defun ourcomments-copy+paste-cancel-highlight ()
|
||
|
|
(when (overlayp ourcomments-copy+paste-ovl)
|
||
|
|
(delete-overlay ourcomments-copy+paste-ovl))
|
||
|
|
(setq ourcomments-copy+paste-ovl nil))
|
||
|
|
|
||
|
|
(defun ourcomments-copy+paste (restore-frames)
|
||
|
|
"Copy region to copy+paste point set by `ourcomments-copy+paste-set-point'.
|
||
|
|
Also if prefix argument is given then restore frame configuration
|
||
|
|
at the time that command was called. Otherwise look for the
|
||
|
|
buffer for copy+paste point in current frame. If found select
|
||
|
|
that window. If not then use `switch-to-buffer-other-window' to
|
||
|
|
display it."
|
||
|
|
(interactive "P")
|
||
|
|
(cond
|
||
|
|
((not ourcomments-copy+paste-point)
|
||
|
|
(let ((key (where-is-internal 'ourcomments-copy+paste-set-point)))
|
||
|
|
(setq key (if key (key-description (car key))
|
||
|
|
"M-x ourcomments-copy+paste-set-point"))
|
||
|
|
(message "Please select destination of copy+paste first with %s" key)))
|
||
|
|
((not mark-active)
|
||
|
|
(message "Please select a region to copy+paste first"))
|
||
|
|
(t
|
||
|
|
;;(copy-region-as-kill (region-beginning) (region-end))
|
||
|
|
(clipboard-kill-ring-save (region-beginning) (region-end))
|
||
|
|
(let* ((marker (nth 0 ourcomments-copy+paste-point))
|
||
|
|
(orig-win (nth 1 ourcomments-copy+paste-point))
|
||
|
|
(orig-fcfg (nth 2 ourcomments-copy+paste-point))
|
||
|
|
(buf (marker-buffer marker))
|
||
|
|
(win (or (when (window-live-p orig-win) orig-win)
|
||
|
|
(get-buffer-window buf))))
|
||
|
|
(message "win=%s, buf=%s" win buf)
|
||
|
|
(cond (restore-frames
|
||
|
|
(set-frame-configuration orig-fcfg))
|
||
|
|
((and win (eq (window-buffer win) buf))
|
||
|
|
(select-window win))
|
||
|
|
(t
|
||
|
|
(switch-to-buffer-other-window buf)))
|
||
|
|
(goto-char marker))
|
||
|
|
(let ((here (point))
|
||
|
|
ovl)
|
||
|
|
(yank)
|
||
|
|
(setq ovl (make-overlay here (point)))
|
||
|
|
(overlay-put ovl 'face 'highlight)
|
||
|
|
(run-with-idle-timer 2 nil 'ourcomments-copy+paste-cancel-highlight)
|
||
|
|
(setq ourcomments-copy+paste-ovl ovl))
|
||
|
|
(setq ourcomments-copy+paste-point nil)
|
||
|
|
(ourcomments-copy+paste-mode -1))))
|
||
|
|
|
||
|
|
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;;;; Misc.
|
||
|
|
|
||
|
|
;;(describe-timers)
|
||
|
|
;;;###autoload
|
||
|
|
(defun describe-timers ()
|
||
|
|
"Show timers with readable time format."
|
||
|
|
(interactive)
|
||
|
|
(with-output-to-temp-buffer (help-buffer)
|
||
|
|
(help-setup-xref (list #'ourcommenst-show-timers) (interactive-p))
|
||
|
|
(with-current-buffer (help-buffer)
|
||
|
|
(insert (format-time-string "Timers at %Y-%m-%d %H:%M:%S\n\n" (current-time)))
|
||
|
|
(if (not timer-list)
|
||
|
|
(insert " None\n")
|
||
|
|
(insert (propertize
|
||
|
|
" When Rpt What\n"
|
||
|
|
'face 'font-lock-doc-face))
|
||
|
|
(dolist (tmr timer-list)
|
||
|
|
(let* ((hi-sec (timer--high-seconds tmr))
|
||
|
|
(lo-sec (timer--low-seconds tmr))
|
||
|
|
(mi-sec (timer--usecs tmr))
|
||
|
|
(fun (timer--function tmr))
|
||
|
|
(args (timer--args tmr))
|
||
|
|
(idle-d (timer--idle-delay tmr))
|
||
|
|
(rpt-d (timer--repeat-delay tmr))
|
||
|
|
(time (concat (format-time-string " %Y-%m-%d %H:%M:%S" (list hi-sec lo-sec 0))
|
||
|
|
(substring
|
||
|
|
(format "%.1f" (/ mi-sec 1000000.0))
|
||
|
|
1))))
|
||
|
|
(assert (not idle-d) t)
|
||
|
|
(insert (format "%s %4s (`%-3s' %S)\n" time rpt-d fun args)))))
|
||
|
|
(insert "\nIdle timers:\n\n")
|
||
|
|
(if (not timer-idle-list)
|
||
|
|
(insert " None\n")
|
||
|
|
(insert (propertize
|
||
|
|
" After Rpt What\n"
|
||
|
|
'face 'font-lock-doc-face))
|
||
|
|
(dolist (tmr timer-idle-list)
|
||
|
|
(let* ((hi-sec (timer--high-seconds tmr))
|
||
|
|
(lo-sec (timer--low-seconds tmr))
|
||
|
|
(mi-sec (timer--usecs tmr))
|
||
|
|
(fun (timer--function tmr))
|
||
|
|
(args (timer--args tmr))
|
||
|
|
(idle-d (timer--idle-delay tmr))
|
||
|
|
(rpt-d (timer--repeat-delay tmr))
|
||
|
|
(time (+ (* hi-sec 256 256) lo-sec (/ mi-sec 1000000.0)))
|
||
|
|
)
|
||
|
|
(assert (not (not idle-d)) t)
|
||
|
|
(insert (format " %.2f sec %3s (`%s' %S)\n" time rpt-d fun args))))))))
|
||
|
|
|
||
|
|
(defcustom ourcomments-insert-date-and-time "%Y-%m-%d %R"
|
||
|
|
"Time format for command `ourcomments-insert-date-and-time'.
|
||
|
|
See `format-time-string'."
|
||
|
|
:type 'string
|
||
|
|
:group 'ourcomments-util)
|
||
|
|
|
||
|
|
;;;###autoload
|
||
|
|
(defun ourcomments-insert-date-and-time ()
|
||
|
|
"Insert date and time.
|
||
|
|
See option `ourcomments-insert-date-and-time' for how to
|
||
|
|
customize it."
|
||
|
|
(interactive)
|
||
|
|
(insert (format-time-string ourcomments-insert-date-and-time)))
|
||
|
|
|
||
|
|
;;;###autoload
|
||
|
|
(defun find-emacs-other-file (display-file)
|
||
|
|
"Find corresponding file to source or installed elisp file.
|
||
|
|
If you have checked out and compiled Emacs yourself you may have
|
||
|
|
Emacs lisp files in two places, the checked out source tree and
|
||
|
|
the installed Emacs tree. If buffer contains an Emacs elisp file
|
||
|
|
in one of these places then find the corresponding elisp file in
|
||
|
|
the other place. Return the file name of this file.
|
||
|
|
|
||
|
|
Rename current buffer using your `uniquify-buffer-name-style' if
|
||
|
|
it is set.
|
||
|
|
|
||
|
|
When DISPLAY-FILE is non-nil display this file in other window
|
||
|
|
and go to the same line number as in the current buffer."
|
||
|
|
(interactive (list t))
|
||
|
|
(unless (buffer-file-name)
|
||
|
|
(error "This buffer is not visiting a file"))
|
||
|
|
(unless source-directory
|
||
|
|
(error "Can't find the checked out Emacs sources"))
|
||
|
|
(let* ((installed-directory (file-name-as-directory
|
||
|
|
(expand-file-name ".." exec-directory)))
|
||
|
|
(relative-installed (file-relative-name
|
||
|
|
(buffer-file-name) installed-directory))
|
||
|
|
(relative-source (file-relative-name
|
||
|
|
(buffer-file-name) source-directory))
|
||
|
|
(name-nondir (file-name-nondirectory (buffer-file-name)))
|
||
|
|
source-file
|
||
|
|
installed-file
|
||
|
|
other-file
|
||
|
|
(line-num (save-restriction
|
||
|
|
(widen)
|
||
|
|
(line-number-at-pos))))
|
||
|
|
(cond
|
||
|
|
((and relative-installed
|
||
|
|
(not (string= name-nondir relative-installed))
|
||
|
|
(not (file-name-absolute-p relative-installed))
|
||
|
|
(not (string= ".." (substring relative-installed 0 2))))
|
||
|
|
(setq source-file (expand-file-name relative-installed source-directory)))
|
||
|
|
((and relative-source
|
||
|
|
(not (string= name-nondir relative-source))
|
||
|
|
(not (file-name-absolute-p relative-source))
|
||
|
|
(not (string= ".." (substring relative-source 0 2))))
|
||
|
|
(setq installed-file (expand-file-name relative-source installed-directory))))
|
||
|
|
(setq other-file (or source-file installed-file))
|
||
|
|
(unless other-file
|
||
|
|
(error "This file is not in Emacs source or installed lisp tree"))
|
||
|
|
(unless (file-exists-p other-file)
|
||
|
|
(error "Can't find the corresponding file %s" other-file))
|
||
|
|
(when display-file
|
||
|
|
(when uniquify-buffer-name-style
|
||
|
|
(rename-buffer (file-name-nondirectory buffer-file-name) t))
|
||
|
|
(find-file-other-window other-file)
|
||
|
|
(ourcomments-goto-line line-num))
|
||
|
|
other-file))
|
||
|
|
|
||
|
|
;;;###autoload
|
||
|
|
(defun ourcomments-ediff-files (def-dir file-a file-b)
|
||
|
|
"In directory DEF-DIR run `ediff-files' on files FILE-A and FILE-B.
|
||
|
|
The purpose of this function is to make it eaiser to start
|
||
|
|
`ediff-files' from a shell through Emacs Client.
|
||
|
|
|
||
|
|
This is used in EmacsW32 in the file ediff.cmd where Emacs Client
|
||
|
|
is called like this:
|
||
|
|
|
||
|
|
@%emacs_client% -e \"(setq default-directory \\\"%emacs_cd%\\\")\"
|
||
|
|
@%emacs_client% -n -e \"(ediff-files \\\"%f1%\\\" \\\"%f2%\\\")\"
|
||
|
|
|
||
|
|
It can of course be done in a similar way with other shells."
|
||
|
|
(let ((default-directory def-dir))
|
||
|
|
(ediff-files file-a file-b)))
|
||
|
|
|
||
|
|
|
||
|
|
(defun ourcomments-latest-changelog ()
|
||
|
|
"not ready"
|
||
|
|
(let ((changelogs
|
||
|
|
'("ChangeLog"
|
||
|
|
"admin/ChangeLog"
|
||
|
|
"doc/emacs/ChangeLog"
|
||
|
|
"doc/lispintro/ChangeLog"
|
||
|
|
"doc/lispref/ChangeLog"
|
||
|
|
"doc/man/ChangeLog"
|
||
|
|
"doc/misc/ChangeLog"
|
||
|
|
"etc/ChangeLog"
|
||
|
|
"leim/ChangeLog"
|
||
|
|
"lib-src/ChangeLog"
|
||
|
|
"lisp/ChangeLog"
|
||
|
|
"lisp/erc/ChangeLog"
|
||
|
|
"lisp/gnus/ChangeLog"
|
||
|
|
"lisp/mh-e/ChangeLog"
|
||
|
|
"lisp/org/ChangeLog"
|
||
|
|
"lisp/url/ChangeLog"
|
||
|
|
"lwlib/ChangeLog"
|
||
|
|
"msdos/ChangeLog"
|
||
|
|
"nextstep/ChangeLog"
|
||
|
|
"nt/ChangeLog"
|
||
|
|
"oldXMenu/ChangeLog"
|
||
|
|
"src/ChangeLog"
|
||
|
|
"test/ChangeLog"))
|
||
|
|
(emacs-root (expand-file-name ".." exec-directory)
|
||
|
|
))))
|
||
|
|
|
||
|
|
(defun ourcomments-read-symbol (prompt predicate)
|
||
|
|
"Basic function for reading a symbol for describe-* functions.
|
||
|
|
Prompt with PROMPT and show only symbols satisfying function
|
||
|
|
PREDICATE. PREDICATE takes one argument, the symbol."
|
||
|
|
(let* ((symbol (symbol-at-point))
|
||
|
|
(enable-recursive-minibuffers t)
|
||
|
|
val)
|
||
|
|
(when predicate
|
||
|
|
(unless (and symbol
|
||
|
|
(symbolp symbol)
|
||
|
|
(funcall predicate symbol))
|
||
|
|
(setq symbol nil)))
|
||
|
|
(setq val (completing-read (if symbol
|
||
|
|
(format
|
||
|
|
"%s (default %s): " prompt symbol)
|
||
|
|
(format "%s: " prompt))
|
||
|
|
obarray
|
||
|
|
predicate
|
||
|
|
t nil nil
|
||
|
|
(if symbol (symbol-name symbol))))
|
||
|
|
(if (equal val "") symbol (intern val))))
|
||
|
|
|
||
|
|
(defun ourcomments-command-at-point ()
|
||
|
|
(let ((fun (function-called-at-point)))
|
||
|
|
(when (commandp fun)
|
||
|
|
fun)))
|
||
|
|
|
||
|
|
;;;###autoload
|
||
|
|
(defun describe-command (command)
|
||
|
|
"Like `describe-function', but prompts only for interactive commands."
|
||
|
|
(interactive
|
||
|
|
(let* ((fn (ourcomments-command-at-point))
|
||
|
|
(prompt (if fn
|
||
|
|
(format "Describe command (default %s): " fn)
|
||
|
|
"Describe command: "))
|
||
|
|
(enable-recursive-minibuffers t)
|
||
|
|
val)
|
||
|
|
(setq val (completing-read prompt
|
||
|
|
obarray 'commandp t nil nil
|
||
|
|
(and fn (symbol-name fn))))
|
||
|
|
(list (if (equal val "") fn (intern val)))))
|
||
|
|
(describe-function command))
|
||
|
|
|
||
|
|
|
||
|
|
;;;###autoload
|
||
|
|
(defun buffer-narrowed-p ()
|
||
|
|
"Return non-nil if the current buffer is narrowed."
|
||
|
|
(/= (buffer-size)
|
||
|
|
(- (point-max)
|
||
|
|
(point-min))))
|
||
|
|
|
||
|
|
;;;###autoload
|
||
|
|
(defun narrow-to-comment ()
|
||
|
|
(interactive)
|
||
|
|
(let* ((here (point-marker))
|
||
|
|
(size 1000)
|
||
|
|
(beg (progn (forward-comment (- size))
|
||
|
|
;; It looks like the wrong syntax-table is used here:
|
||
|
|
;;(message "skipped %s " (skip-chars-forward "[:space:]"))
|
||
|
|
;; See Emacs bug 3823, http://debbugs.gnu.org/cgi/bugreport.cgi?bug=3823
|
||
|
|
(message "skipped %s " (skip-chars-forward " \t\r\n"))
|
||
|
|
(point)))
|
||
|
|
(end (progn (forward-comment size)
|
||
|
|
;;(message "skipped %s " (skip-chars-backward "[:space:]"))
|
||
|
|
(message "skipped %s " (skip-chars-backward " \t\r\n"))
|
||
|
|
(point))))
|
||
|
|
(goto-char here)
|
||
|
|
(if (not (and (>= here beg)
|
||
|
|
(<= here end)))
|
||
|
|
(error "Not in a comment")
|
||
|
|
(narrow-to-region beg end))))
|
||
|
|
|
||
|
|
(defvar describe-symbol-alist nil)
|
||
|
|
|
||
|
|
(defun describe-symbol-add-known(property description)
|
||
|
|
(when (assq property describe-symbol-alist)
|
||
|
|
(error "Already known property"))
|
||
|
|
(setq describe-symbol-alist
|
||
|
|
(cons (list property description)
|
||
|
|
describe-symbol-alist)))
|
||
|
|
|
||
|
|
;;(describe-symbol-add-known 'variable-documentation "Doc for variable")
|
||
|
|
;;(describe-symbol-add-known 'cl-struct-slots "defstruct slots")
|
||
|
|
|
||
|
|
(defun property-list-keys (plist)
|
||
|
|
"Return list of key names in property list PLIST."
|
||
|
|
(let ((keys))
|
||
|
|
(while plist
|
||
|
|
(setq keys (cons (car plist) keys))
|
||
|
|
(setq plist (cddr plist)))
|
||
|
|
keys))
|
||
|
|
|
||
|
|
(defun ourcomments-symbol-type (symbol)
|
||
|
|
"Return a list of types where symbol SYMBOL is used.
|
||
|
|
The can include 'variable, 'function and variaus 'cl-*."
|
||
|
|
(symbol-file symbol)
|
||
|
|
)
|
||
|
|
|
||
|
|
(defun ourcomments-defstruct-p (symbol)
|
||
|
|
"Return non-nil if symbol SYMBOL is a CL defstruct."
|
||
|
|
(let ((plist (symbol-plist symbol)))
|
||
|
|
(and (plist-member plist 'cl-struct-slots)
|
||
|
|
(plist-member plist 'cl-struct-type)
|
||
|
|
(plist-member plist 'cl-struct-include)
|
||
|
|
(plist-member plist 'cl-struct-print))))
|
||
|
|
|
||
|
|
(defun ourcomments-defstruct-slots (symbol)
|
||
|
|
(unless (ourcomments-defstruct-p symbol)
|
||
|
|
(error "Not a CL defstruct symbol: %s" symbol))
|
||
|
|
(let ((cl-struct-slots (get symbol 'cl-struct-slots)))
|
||
|
|
(delq 'cl-tag-slot
|
||
|
|
(loop for rec in cl-struct-slots
|
||
|
|
collect (nth 0 rec)))))
|
||
|
|
|
||
|
|
;; (ourcomments-defstruct-slots 'ert-test)
|
||
|
|
|
||
|
|
(defun ourcomments-defstruct-file (symbol)
|
||
|
|
(unless (ourcomments-defstruct-p symbol)
|
||
|
|
(error "Not a CL defstruct symbol: %s" symbol))
|
||
|
|
)
|
||
|
|
|
||
|
|
(defun ourcomments-member-defstruct (symbol)
|
||
|
|
"Return defstruct name if member."
|
||
|
|
(when (and (functionp symbol)
|
||
|
|
(plist-member (symbol-plist symbol) 'cl-compiler-macro))
|
||
|
|
(let* (in-defstruct
|
||
|
|
(symbol-file (symbol-file symbol))
|
||
|
|
buf
|
||
|
|
was-here)
|
||
|
|
(unless symbol-file
|
||
|
|
(error "Can't check if defstruct member since don't know symbol file"))
|
||
|
|
(setq buf (find-buffer-visiting symbol-file))
|
||
|
|
(setq was-here (with-current-buffer buf (point)))
|
||
|
|
(unless buf
|
||
|
|
(setq buf (find-file-noselect symbol-file)))
|
||
|
|
(with-current-buffer buf
|
||
|
|
(save-restriction
|
||
|
|
(widen)
|
||
|
|
(let* ((buf-point (find-definition-noselect symbol nil)))
|
||
|
|
(goto-char (cdr buf-point))
|
||
|
|
(save-match-data
|
||
|
|
(when (looking-at "(defstruct (?\\(\\(?:\\sw\\|\\s_\\)+\\)")
|
||
|
|
(setq in-defstruct (match-string-no-properties 1))))))
|
||
|
|
(if was-here
|
||
|
|
(goto-char was-here)
|
||
|
|
(kill-buffer (current-buffer))))
|
||
|
|
in-defstruct)))
|
||
|
|
;; (ourcomments-member-defstruct 'ert-test-name)
|
||
|
|
;; (ourcomments-member-defstruct 'ert-test-error-condition)
|
||
|
|
|
||
|
|
(defun ourcomments-custom-group-p (symbol)
|
||
|
|
(and (intern-soft symbol)
|
||
|
|
(or (and (get symbol 'custom-loads)
|
||
|
|
(not (get symbol 'custom-autoload)))
|
||
|
|
(get symbol 'custom-group))))
|
||
|
|
|
||
|
|
;;;###autoload
|
||
|
|
(defun describe-custom-group (symbol)
|
||
|
|
"Describe customization group SYMBOL."
|
||
|
|
(interactive
|
||
|
|
(list
|
||
|
|
(ourcomments-read-symbol "Customization group"
|
||
|
|
'ourcomments-custom-group-p)))
|
||
|
|
;; Fix-me:
|
||
|
|
(message "g=%s" symbol))
|
||
|
|
;; nxhtml
|
||
|
|
|
||
|
|
;; Added this to current-load-list in cl-macs.el
|
||
|
|
;; (describe-defstruct 'ert-stats)
|
||
|
|
;;;###autoload
|
||
|
|
(defun describe-defstruct (symbol)
|
||
|
|
(interactive (list (ourcomments-read-symbol "Describe defstruct"
|
||
|
|
'ourcomments-defstruct-p)))
|
||
|
|
(if (not (ourcomments-defstruct-p symbol))
|
||
|
|
(message "%s is not a CL defstruct." symbol)
|
||
|
|
(with-output-to-temp-buffer (help-buffer)
|
||
|
|
(help-setup-xref (list #'describe-defstruct symbol) (interactive-p))
|
||
|
|
(with-current-buffer (help-buffer)
|
||
|
|
(insert "This is a description of a CL thing.")
|
||
|
|
(insert "\n\n")
|
||
|
|
(insert (format "%s is a CL `defstruct'" symbol))
|
||
|
|
(let ((file (symbol-file symbol)))
|
||
|
|
(if file
|
||
|
|
;; Fix-me: .elc => .el
|
||
|
|
(let ((name (file-name-nondirectory file)))
|
||
|
|
(insert "defined in file %s.\n" (file-name-nondirectory file)))
|
||
|
|
(insert ".\n")))
|
||
|
|
(insert "\n\nIt has the following slot functions:\n")
|
||
|
|
(let ((num-slot-funs 0)
|
||
|
|
(slots (ourcomments-defstruct-slots symbol)))
|
||
|
|
(dolist (slot slots)
|
||
|
|
(if (not (fboundp (intern-soft (format "%s-%s" symbol slot))))
|
||
|
|
(insert (format " Do not know function for slot %s\n" slot))
|
||
|
|
(setq num-slot-funs (1+ num-slot-funs))
|
||
|
|
(insert (format " `%s-%s'\n" symbol slot))))
|
||
|
|
(unless (= num-slot-funs (length slots))
|
||
|
|
(insert " No information about some slots, maybe :conc-name was used\n")))))))
|
||
|
|
|
||
|
|
;;(defun describe-deftype (type)
|
||
|
|
;;;###autoload
|
||
|
|
(defun describe-symbol(symbol)
|
||
|
|
"Show information about SYMBOL.
|
||
|
|
Show SYMBOL plist and whether is is a variable or/and a
|
||
|
|
function."
|
||
|
|
(interactive (list (ourcomments-read-symbol "Describe symbol" nil)))
|
||
|
|
;;; (let* ((s (symbol-at-point))
|
||
|
|
;;; (val (completing-read (if (and (symbolp s)
|
||
|
|
;;; (not (eq s nil)))
|
||
|
|
;;; (format
|
||
|
|
;;; "Describe symbol (default %s): " s)
|
||
|
|
;;; "Describe symbol: ")
|
||
|
|
;;; obarray
|
||
|
|
;;; nil
|
||
|
|
;;; t nil nil
|
||
|
|
;;; (if (symbolp s) (symbol-name s)))))
|
||
|
|
;;; (list (if (equal val "") s (intern val)))))
|
||
|
|
(require 'apropos)
|
||
|
|
(with-output-to-temp-buffer (help-buffer)
|
||
|
|
(help-setup-xref (list #'describe-symbol symbol) (interactive-p))
|
||
|
|
(with-current-buffer (help-buffer)
|
||
|
|
(insert (format "Description of symbol %s\n\n" symbol))
|
||
|
|
(when (plist-get (symbol-plist symbol) 'cl-compiler-macro)
|
||
|
|
(insert "(Looks like a CL thing.)\n"))
|
||
|
|
(if (boundp symbol)
|
||
|
|
(insert (format "- There is a variable `%s'.\n" symbol))
|
||
|
|
(insert "- This symbol is not a variable.\n"))
|
||
|
|
(if (fboundp symbol)
|
||
|
|
(progn
|
||
|
|
(insert (format "- There is a function `%s'" symbol))
|
||
|
|
(when (ourcomments-member-defstruct symbol)
|
||
|
|
(let ((ds-name (ourcomments-member-defstruct symbol)))
|
||
|
|
(insert "\n which is a member of defstruct ")
|
||
|
|
(insert-text-button (format "%s" ds-name)
|
||
|
|
'symbol (intern-soft ds-name)
|
||
|
|
'action (lambda (button)
|
||
|
|
(describe-symbol
|
||
|
|
(button-get button 'symbol))))))
|
||
|
|
(insert ".\n"))
|
||
|
|
(insert "- This symbol is not a function.\n"))
|
||
|
|
(if (facep symbol)
|
||
|
|
(insert (format "- There is a face `%s'.\n" symbol))
|
||
|
|
(insert "- This symbol is not a face.\n"))
|
||
|
|
(if (ourcomments-custom-group-p symbol)
|
||
|
|
(progn
|
||
|
|
(insert "- There is a customization group ")
|
||
|
|
(insert-text-button (format "%s" symbol)
|
||
|
|
'symbol symbol
|
||
|
|
'action (lambda (button)
|
||
|
|
(describe-custom-group
|
||
|
|
(button-get button 'symbol))))
|
||
|
|
(insert ".\n"))
|
||
|
|
(insert "- This symbol is not a customization group.\n"))
|
||
|
|
(if (ourcomments-defstruct-p symbol)
|
||
|
|
(progn
|
||
|
|
(insert (format "- There is a CL defstruct %s with setf-able slots:\n" symbol))
|
||
|
|
(let ((num-slot-funs 0)
|
||
|
|
(slots (ourcomments-defstruct-slots symbol)))
|
||
|
|
(dolist (slot slots)
|
||
|
|
(if (not (fboundp (intern-soft (format "%s-%s" symbol slot))))
|
||
|
|
(insert (format " Do not know function for slot %s\n" slot))
|
||
|
|
(setq num-slot-funs (1+ num-slot-funs))
|
||
|
|
(insert (format " `%s-%s'\n" symbol slot))))
|
||
|
|
(unless (= num-slot-funs (length slots))
|
||
|
|
(insert " No information about some slots, maybe :conc-name was used\n"))))
|
||
|
|
(insert "- This symbol is not a CL defstruct.\n"))
|
||
|
|
(insert "\n")
|
||
|
|
(let* ((pl (symbol-plist symbol))
|
||
|
|
(pl-not-known (property-list-keys pl))
|
||
|
|
any-known)
|
||
|
|
(if (not pl)
|
||
|
|
(insert (format "Symbol %s has no property list\n\n" symbol))
|
||
|
|
;; Known properties
|
||
|
|
(dolist (rec describe-symbol-alist)
|
||
|
|
(let ((prop (nth 0 rec))
|
||
|
|
(desc (nth 1 rec)))
|
||
|
|
(when (plist-member pl prop)
|
||
|
|
(setq any-known (cons prop any-known))
|
||
|
|
(setq pl-not-known (delq prop pl-not-known))
|
||
|
|
(insert
|
||
|
|
"The following keys in the property list are known:\n\n")
|
||
|
|
(insert (format "* %s: %s\n" prop desc))
|
||
|
|
)))
|
||
|
|
(unless any-known
|
||
|
|
(insert "The are no known keys in the property list.\n"))
|
||
|
|
(let ((pl (ourcomments-format-plist pl "\n ")))
|
||
|
|
;;(insert (format "plist=%s\n" (symbol-plist symbol)))
|
||
|
|
;;(insert (format "pl-not-known=%s\n" pl-not-known))
|
||
|
|
(insert "\nFull property list:\n\n (")
|
||
|
|
(insert (propertize pl 'face 'default))
|
||
|
|
(insert ")\n\n")))))))
|
||
|
|
|
||
|
|
(defun ourcomments-format-plist (pl sep &optional compare)
|
||
|
|
(when (symbolp pl)
|
||
|
|
(setq pl (symbol-plist pl)))
|
||
|
|
(let (p desc p-out)
|
||
|
|
(while pl
|
||
|
|
(setq p (format "%s" (car pl)))
|
||
|
|
(if (or (not compare) (string-match apropos-regexp p))
|
||
|
|
(if apropos-property-face
|
||
|
|
(put-text-property 0 (length (symbol-name (car pl)))
|
||
|
|
'face apropos-property-face p))
|
||
|
|
(setq p nil))
|
||
|
|
(if p
|
||
|
|
(progn
|
||
|
|
(and compare apropos-match-face
|
||
|
|
(put-text-property (match-beginning 0) (match-end 0)
|
||
|
|
'face apropos-match-face
|
||
|
|
p))
|
||
|
|
(setq desc (pp-to-string (nth 1 pl)))
|
||
|
|
(setq desc (split-string desc "\n"))
|
||
|
|
(if (= 1 (length desc))
|
||
|
|
(setq desc (concat " " (car desc)))
|
||
|
|
(let* ((indent " ")
|
||
|
|
(ind-nl (concat "\n" indent)))
|
||
|
|
(setq desc
|
||
|
|
(concat
|
||
|
|
ind-nl
|
||
|
|
(mapconcat 'identity desc ind-nl)))))
|
||
|
|
(setq p-out (concat p-out (if p-out sep) p desc))))
|
||
|
|
(setq pl (nthcdr 2 pl)))
|
||
|
|
p-out))
|
||
|
|
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;;;; ido
|
||
|
|
|
||
|
|
(defvar ourcomments-ido-visit-method nil)
|
||
|
|
|
||
|
|
;;;###autoload
|
||
|
|
(defun ourcomments-ido-buffer-other-window ()
|
||
|
|
"Show buffer in other window."
|
||
|
|
(interactive)
|
||
|
|
(setq ourcomments-ido-visit-method 'other-window)
|
||
|
|
(call-interactively 'ido-exit-minibuffer))
|
||
|
|
|
||
|
|
;;;###autoload
|
||
|
|
(defun ourcomments-ido-buffer-other-frame ()
|
||
|
|
"Show buffer in other frame."
|
||
|
|
(interactive)
|
||
|
|
(setq ourcomments-ido-visit-method 'other-frame)
|
||
|
|
(call-interactively 'ido-exit-minibuffer))
|
||
|
|
|
||
|
|
;;;###autoload
|
||
|
|
(defun ourcomments-ido-buffer-raise-frame ()
|
||
|
|
"Raise frame showing buffer."
|
||
|
|
(interactive)
|
||
|
|
(setq ourcomments-ido-visit-method 'raise-frame)
|
||
|
|
(call-interactively 'ido-exit-minibuffer))
|
||
|
|
|
||
|
|
(defun ourcomments-ido-switch-buffer-or-next-entry ()
|
||
|
|
(interactive)
|
||
|
|
(if (active-minibuffer-window)
|
||
|
|
(ido-next-match)
|
||
|
|
(ido-switch-buffer)))
|
||
|
|
|
||
|
|
(defun ourcomments-ido-mode-advice()
|
||
|
|
(when (memq ido-mode '(both buffer))
|
||
|
|
(let ((the-ido-minor-map (cdr ido-minor-mode-map-entry)))
|
||
|
|
;;(define-key the-ido-minor-map [(control tab)] 'ido-switch-buffer))
|
||
|
|
(define-key the-ido-minor-map [(control tab)] 'ourcomments-ido-switch-buffer-or-next-entry))
|
||
|
|
(dolist (the-map (list ido-buffer-completion-map ido-completion-map ido-common-completion-map))
|
||
|
|
(when the-map
|
||
|
|
(let ((map the-map))
|
||
|
|
(define-key map [(control tab)] 'ido-next-match)
|
||
|
|
(define-key map [(control shift tab)] 'ido-prev-match)
|
||
|
|
(define-key map [(control backtab)] 'ido-prev-match)
|
||
|
|
(define-key map [(shift return)] 'ourcomments-ido-buffer-other-window)
|
||
|
|
(define-key map [(control return)] 'ourcomments-ido-buffer-other-frame)
|
||
|
|
(define-key map [(meta return)] 'ourcomments-ido-buffer-raise-frame))))))
|
||
|
|
|
||
|
|
;; (defun ourcomments-ido-setup-completion-map ()
|
||
|
|
;; "Set up the keymap for `ido'."
|
||
|
|
|
||
|
|
;; (ourcomments-ido-mode-advice)
|
||
|
|
|
||
|
|
;; ;; generated every time so that it can inherit new functions.
|
||
|
|
;; (let ((map (make-sparse-keymap))
|
||
|
|
;; (viper-p (if (boundp 'viper-mode) viper-mode)))
|
||
|
|
|
||
|
|
;; (when viper-p
|
||
|
|
;; (define-key map [remap viper-intercept-ESC-key] 'ignore))
|
||
|
|
|
||
|
|
;; (cond
|
||
|
|
;; ((memq ido-cur-item '(file dir))
|
||
|
|
;; (when ido-context-switch-command
|
||
|
|
;; (define-key map "\C-x\C-b" ido-context-switch-command)
|
||
|
|
;; (define-key map "\C-x\C-d" 'ignore))
|
||
|
|
;; (when viper-p
|
||
|
|
;; (define-key map [remap viper-backward-char] 'ido-delete-backward-updir)
|
||
|
|
;; (define-key map [remap viper-del-backward-char-in-insert] 'ido-delete-backward-updir)
|
||
|
|
;; (define-key map [remap viper-delete-backward-word] 'ido-delete-backward-word-updir))
|
||
|
|
;; (set-keymap-parent map
|
||
|
|
;; (if (eq ido-cur-item 'file)
|
||
|
|
;; ido-file-completion-map
|
||
|
|
;; ido-file-dir-completion-map)))
|
||
|
|
|
||
|
|
;; ((eq ido-cur-item 'buffer)
|
||
|
|
;; (when ido-context-switch-command
|
||
|
|
;; (define-key map "\C-x\C-f" ido-context-switch-command))
|
||
|
|
;; (set-keymap-parent map ido-buffer-completion-map))
|
||
|
|
|
||
|
|
;; (t
|
||
|
|
;; (set-keymap-parent map ido-common-completion-map)))
|
||
|
|
|
||
|
|
;; ;; ctrl-tab etc
|
||
|
|
;; (define-key map [(control tab)] 'ido-next-match)
|
||
|
|
;; (define-key map [(control shift tab)] 'ido-prev-match)
|
||
|
|
;; (define-key map [(control backtab)] 'ido-prev-match)
|
||
|
|
;; (define-key map [(shift return)] 'ourcomments-ido-buffer-other-window)
|
||
|
|
;; (define-key map [(control return)] 'ourcomments-ido-buffer-other-frame)
|
||
|
|
;; (define-key map [(meta return)] 'ourcomments-ido-buffer-raise-frame)
|
||
|
|
|
||
|
|
;; (setq ido-completion-map map)))
|
||
|
|
|
||
|
|
;; (defadvice ido-setup-completion-map (around
|
||
|
|
;; ourcomments-advice-ido-setup-completion-map
|
||
|
|
;; disable)
|
||
|
|
;; (setq ad-return-value (ourcomments-ido-setup-completion-map))
|
||
|
|
;; )
|
||
|
|
|
||
|
|
;;(add-hook 'ido-setup-hook 'ourcomments-ido-mode-advice)
|
||
|
|
;;(remove-hook 'ido-setup-hook 'ourcomments-ido-mode-advice)
|
||
|
|
(defvar ourcomments-ido-adviced nil)
|
||
|
|
(unless ourcomments-ido-adviced
|
||
|
|
(defadvice ido-mode (after
|
||
|
|
ourcomments-advice-ido-mode
|
||
|
|
;;activate
|
||
|
|
;;compile
|
||
|
|
disable)
|
||
|
|
"Add C-tab to ido buffer completion."
|
||
|
|
(ourcomments-ido-mode-advice)
|
||
|
|
;;ad-return-value
|
||
|
|
)
|
||
|
|
;; (ad-activate 'ido-mode)
|
||
|
|
;; (ad-deactivate 'ido-mode)
|
||
|
|
|
||
|
|
(defadvice ido-visit-buffer (before
|
||
|
|
ourcomments-advice-ido-visit-buffer
|
||
|
|
;;activate
|
||
|
|
;;compile
|
||
|
|
disable)
|
||
|
|
"Advice to show buffers in other window, frame etc."
|
||
|
|
(when ourcomments-ido-visit-method
|
||
|
|
(ad-set-arg 1 ourcomments-ido-visit-method)
|
||
|
|
(setq ourcomments-ido-visit-method nil)
|
||
|
|
))
|
||
|
|
(setq ourcomments-ido-adviced t)
|
||
|
|
)
|
||
|
|
|
||
|
|
;;(message "after advising ido")
|
||
|
|
;;(ad-deactivate 'ido-visit-buffer)
|
||
|
|
;;(ad-activate 'ido-visit-buffer)
|
||
|
|
|
||
|
|
(defvar ourcomments-ido-old-state ido-mode)
|
||
|
|
|
||
|
|
(defun ourcomments-ido-ctrl-tab-activate ()
|
||
|
|
;;(message "ourcomments-ido-ctrl-tab-activate running")
|
||
|
|
;;(ad-update 'ido-visit-buffer)
|
||
|
|
;;(unless (ad-get-advice-info 'ido-visit-buffer)
|
||
|
|
;; Fix-me: The advice must be enabled before activation. Send bug report.
|
||
|
|
(ad-enable-advice 'ido-visit-buffer 'before 'ourcomments-advice-ido-visit-buffer)
|
||
|
|
(unless (cdr (assoc 'active (ad-get-advice-info 'ido-visit-buffer)))
|
||
|
|
(ad-activate 'ido-visit-buffer))
|
||
|
|
;; (ad-enable-advice 'ido-setup-completion-map 'around 'ourcomments-advice-ido-setup-completion-map)
|
||
|
|
;; (unless (cdr (assoc 'active (ad-get-advice-info 'ido-setup-completion-map)))
|
||
|
|
;; (ad-activate 'ido-setup-completion-map))
|
||
|
|
;;(ad-update 'ido-mode)
|
||
|
|
(ad-enable-advice 'ido-mode 'after 'ourcomments-advice-ido-mode)
|
||
|
|
(unless (cdr (assoc 'active (ad-get-advice-info 'ido-mode)))
|
||
|
|
(ad-activate 'ido-mode))
|
||
|
|
(setq ourcomments-ido-old-state ido-mode)
|
||
|
|
(ido-mode (or ido-mode 'buffer)))
|
||
|
|
|
||
|
|
;;;###autoload
|
||
|
|
(define-minor-mode ourcomments-ido-ctrl-tab
|
||
|
|
"Enable buffer switching using C-Tab with function `ido-mode'.
|
||
|
|
This changes buffer switching with function `ido-mode' the
|
||
|
|
following way:
|
||
|
|
|
||
|
|
- You can use C-Tab.
|
||
|
|
|
||
|
|
- You can show the selected buffer in three ways independent of
|
||
|
|
how you entered function `ido-mode' buffer switching:
|
||
|
|
|
||
|
|
* S-return: other window
|
||
|
|
* C-return: other frame
|
||
|
|
* M-return: raise frame
|
||
|
|
|
||
|
|
Those keys are selected to at least be a little bit reminiscent
|
||
|
|
of those in for example common web browsers."
|
||
|
|
:global t
|
||
|
|
:group 'emacsw32
|
||
|
|
:group 'convenience
|
||
|
|
(if ourcomments-ido-ctrl-tab
|
||
|
|
(ourcomments-ido-ctrl-tab-activate)
|
||
|
|
(ad-disable-advice 'ido-visit-buffer 'before
|
||
|
|
'ourcomments-advice-ido-visit-buffer)
|
||
|
|
(ad-disable-advice 'ido-mode 'after
|
||
|
|
'ourcomments-advice-ido-mode)
|
||
|
|
;; For some reason this little complicated construct is
|
||
|
|
;; needed. If they are not there the defadvice
|
||
|
|
;; disappears. Huh.
|
||
|
|
;;(if ourcomments-ido-old-state
|
||
|
|
;; (ido-mode ourcomments-ido-old-state)
|
||
|
|
;; (when ido-mode (ido-mode -1)))
|
||
|
|
))
|
||
|
|
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;;;; New Emacs instance
|
||
|
|
|
||
|
|
(defun ourcomments-find-emacs ()
|
||
|
|
(locate-file invocation-name
|
||
|
|
(list invocation-directory)
|
||
|
|
exec-suffixes
|
||
|
|
;; 1 ;; Fix-me: This parameter is depreceated, but used
|
||
|
|
;; in executable-find, why?
|
||
|
|
))
|
||
|
|
|
||
|
|
(defvar ourcomments-restart-server-mode nil)
|
||
|
|
|
||
|
|
(defun emacs-restart-in-kill ()
|
||
|
|
"Last step in restart Emacs and start `server-mode' if on before."
|
||
|
|
(let* ((restart-args (when ourcomments-restart-server-mode
|
||
|
|
;; Delay 3+2 sec to be sure the old server has stopped.
|
||
|
|
(list "--eval=(run-with-idle-timer 5 nil 'server-mode 1)")))
|
||
|
|
;; Fix-me: There is an Emacs bug here, default-directory shows
|
||
|
|
;; up in load-path in the new Eamcs if restart-args is like
|
||
|
|
;; this, but not otherwise. And it has w32 file syntax. The
|
||
|
|
;; work around below is the best I can find at the moment.
|
||
|
|
(first-path (catch 'first
|
||
|
|
(dolist (p load-path)
|
||
|
|
(when (file-directory-p p)
|
||
|
|
(throw 'first p)))))
|
||
|
|
(default-directory (file-name-as-directory (expand-file-name first-path))))
|
||
|
|
;; Fix-me: Adding -nw to restart in console does not work. Any way to fix it?
|
||
|
|
(unless window-system (setq restart-args (cons "-nw" restart-args)))
|
||
|
|
;;(apply 'call-process (ourcomments-find-emacs) nil 0 nil restart-args)
|
||
|
|
(apply 'emacs restart-args)
|
||
|
|
;; Wait to give focus to new Emacs instance:
|
||
|
|
(sleep-for 3)))
|
||
|
|
|
||
|
|
;;;###autoload
|
||
|
|
(defun emacs-restart ()
|
||
|
|
"Restart Emacs and start `server-mode' if on before."
|
||
|
|
(interactive)
|
||
|
|
(if (not window-system)
|
||
|
|
(message "Can't restart emacs if window-system is nil")
|
||
|
|
(let ((wait 4))
|
||
|
|
(while (> (setq wait (1- wait)) 0)
|
||
|
|
(message (propertize (format "Will restart Emacs in %d seconds..." wait)
|
||
|
|
'face 'secondary-selection))
|
||
|
|
(sit-for 1)))
|
||
|
|
(setq ourcomments-restart-server-mode server-mode)
|
||
|
|
(add-hook 'kill-emacs-hook 'emacs-restart-in-kill t)
|
||
|
|
(save-buffers-kill-emacs)))
|
||
|
|
|
||
|
|
(defvar ourcomments-started-emacs-use-output-buffer nil
|
||
|
|
"If non-nil then save output form `emacs'.
|
||
|
|
Set this to `t' to debug problems with starting a new Emacs.
|
||
|
|
|
||
|
|
If non-nil save output to buffer 'call-process emacs output'.
|
||
|
|
Note that this will lock the Emacs calling `emacs' until the new
|
||
|
|
Emacs has finished.")
|
||
|
|
;;(setq ourcomments-started-emacs-use-output-buffer t)
|
||
|
|
;;(defun my-test () (interactive) (emacs-Q "-bad-arg"))
|
||
|
|
|
||
|
|
;;;###autoload
|
||
|
|
(defun emacs (&rest args)
|
||
|
|
"Start a new Emacs with default parameters.
|
||
|
|
Additional ARGS are passed to the new Emacs.
|
||
|
|
|
||
|
|
See also `ourcomments-started-emacs-use-output-buffer'."
|
||
|
|
(interactive)
|
||
|
|
(recentf-save-list)
|
||
|
|
(let* ((out-buf (when ourcomments-started-emacs-use-output-buffer
|
||
|
|
(get-buffer-create "call-process emacs output")))
|
||
|
|
(buf-arg (or out-buf 0))
|
||
|
|
(args-text (mapconcat 'identity (cons "" args) " "))
|
||
|
|
ret
|
||
|
|
(fin-msg ""))
|
||
|
|
(when out-buf
|
||
|
|
(display-buffer out-buf)
|
||
|
|
(setq fin-msg ". Finished.")
|
||
|
|
(message "Started 'emacs%s' => %s. Locked until this is finished." args-text ret fin-msg)
|
||
|
|
(redisplay))
|
||
|
|
(setq ret (apply 'call-process (ourcomments-find-emacs) nil buf-arg nil args))
|
||
|
|
(message "Started 'emacs%s' => %s%s" args-text ret fin-msg)
|
||
|
|
ret))
|
||
|
|
|
||
|
|
;;;###autoload
|
||
|
|
(defun emacs-buffer-file()
|
||
|
|
"Start a new Emacs showing current buffer file.
|
||
|
|
Go to the current line and column in that file.
|
||
|
|
If there is no buffer file then instead start with `dired'.
|
||
|
|
|
||
|
|
This calls the function `emacs' with argument --no-desktop and
|
||
|
|
the file or a call to dired."
|
||
|
|
(interactive)
|
||
|
|
(recentf-save-list)
|
||
|
|
(let ((file (buffer-file-name))
|
||
|
|
(lin (line-number-at-pos))
|
||
|
|
(col (current-column)))
|
||
|
|
(if file
|
||
|
|
(apply 'emacs "--no-desktop" (format "+%d:%d" lin col) file nil)
|
||
|
|
(applay 'emacs "--no-desktop" "--eval" (format "(dired \"%s\")" default-directory nil)))))
|
||
|
|
|
||
|
|
;;;###autoload
|
||
|
|
(defun emacs--debug-init(&rest args)
|
||
|
|
"Start a new Emacs with --debug-init parameter.
|
||
|
|
This calls the function `emacs' with added arguments ARGS."
|
||
|
|
(interactive)
|
||
|
|
(apply 'emacs "--debug-init" args))
|
||
|
|
|
||
|
|
;;;###autoload
|
||
|
|
(defun emacs--no-desktop (&rest args)
|
||
|
|
"Start a new Emacs with --no-desktop parameter.
|
||
|
|
This calls the function `emacs' with added arguments ARGS."
|
||
|
|
(interactive)
|
||
|
|
(apply 'emacs "--no-desktop" args))
|
||
|
|
|
||
|
|
;;;###autoload
|
||
|
|
(defun emacs-Q (&rest args)
|
||
|
|
"Start a new Emacs with -Q parameter.
|
||
|
|
Start new Emacs without any customization whatsoever.
|
||
|
|
This calls the function `emacs' with added arguments ARGS."
|
||
|
|
(interactive)
|
||
|
|
(apply 'emacs "-Q" args))
|
||
|
|
|
||
|
|
;;;###autoload
|
||
|
|
(defun emacs-Q-nxhtml(&rest args)
|
||
|
|
"Start new Emacs with -Q and load nXhtml.
|
||
|
|
This calls the function `emacs' with added arguments ARGS."
|
||
|
|
(interactive)
|
||
|
|
(let ((autostart (if (boundp 'nxhtml-install-dir)
|
||
|
|
(expand-file-name "autostart.el" nxhtml-install-dir)
|
||
|
|
(expand-file-name "../../EmacsW32/nxhtml/autostart.el"
|
||
|
|
exec-directory))))
|
||
|
|
(apply 'emacs-Q "--debug-init" "--load" autostart args)))
|
||
|
|
|
||
|
|
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;;;; Searching
|
||
|
|
|
||
|
|
(defun grep-get-buffer-files ()
|
||
|
|
"Return list of files in a `grep-mode' buffer."
|
||
|
|
(or (and (compilation-buffer-p (current-buffer))
|
||
|
|
(derived-mode-p 'grep-mode))
|
||
|
|
(error "Not in a grep buffer"))
|
||
|
|
(let ((here (point))
|
||
|
|
files
|
||
|
|
loc)
|
||
|
|
(font-lock-fontify-buffer)
|
||
|
|
(goto-char (point-min))
|
||
|
|
(while (setq loc
|
||
|
|
(condition-case err
|
||
|
|
(compilation-next-error 1)
|
||
|
|
(error
|
||
|
|
;; This should be the end, but give a message for
|
||
|
|
;; easier debugging.
|
||
|
|
(message "%s" err)
|
||
|
|
nil)))
|
||
|
|
;;(message "here =%s, loc=%s" (point) loc)
|
||
|
|
(let ((file (caar (nth 2 (car loc)))))
|
||
|
|
(setq file (expand-file-name file))
|
||
|
|
(add-to-list 'files file)))
|
||
|
|
(goto-char here)
|
||
|
|
;;(message "files=%s" files)
|
||
|
|
files))
|
||
|
|
|
||
|
|
(defvar grep-query-replace-defaults nil
|
||
|
|
"Default values of FROM-STRING and TO-STRING for `grep-query-replace'.
|
||
|
|
This is a cons cell (FROM-STRING . TO-STRING), or nil if there is
|
||
|
|
no default value.")
|
||
|
|
|
||
|
|
;; Mostly copied from `dired-do-query-replace-regexp'. Fix-me: finish, test
|
||
|
|
;;;###autoload
|
||
|
|
(defun grep-query-replace(from to &optional delimited)
|
||
|
|
"Do `query-replace-regexp' of FROM with TO, on all files in *grep*.
|
||
|
|
Third arg DELIMITED (prefix arg) means replace only word-delimited matches.
|
||
|
|
If you exit (\\[keyboard-quit], RET or q), you can resume the query replace
|
||
|
|
with the command \\[tags-loop-continue]."
|
||
|
|
(interactive
|
||
|
|
(let ((common
|
||
|
|
;; Use the regexps that have been used in grep
|
||
|
|
(let ((query-replace-from-history-variable 'grep-regexp-history)
|
||
|
|
(query-replace-defaults (or grep-query-replace-defaults
|
||
|
|
query-replace-defaults)))
|
||
|
|
(query-replace-read-args
|
||
|
|
"Query replace regexp in files in *grep*" t t))))
|
||
|
|
(setq grep-query-replace-defaults (cons (nth 0 common)
|
||
|
|
(nth 1 common)))
|
||
|
|
(list (nth 0 common) (nth 1 common) (nth 2 common))))
|
||
|
|
(dolist (file (grep-get-buffer-files))
|
||
|
|
(let ((buffer (get-file-buffer file)))
|
||
|
|
(if (and buffer (with-current-buffer buffer
|
||
|
|
buffer-read-only))
|
||
|
|
(error "File `%s' is visited read-only" file))))
|
||
|
|
(tags-query-replace from to delimited
|
||
|
|
'(grep-get-buffer-files)))
|
||
|
|
|
||
|
|
;;;###autoload
|
||
|
|
(defun ldir-query-replace (from to files dir &optional delimited)
|
||
|
|
"Replace FROM with TO in FILES in directory DIR.
|
||
|
|
This runs `query-replace-regexp' in files matching FILES in
|
||
|
|
directory DIR.
|
||
|
|
|
||
|
|
See `tags-query-replace' for DELIMETED and more information."
|
||
|
|
(interactive (dir-replace-read-parameters nil nil))
|
||
|
|
(message "%s" (list from to files dir delimited))
|
||
|
|
;;(let ((files (directory-files root nil file-regexp))) (message "files=%s" files))
|
||
|
|
(tags-query-replace from to delimited
|
||
|
|
`(directory-files ,dir t ,files)))
|
||
|
|
|
||
|
|
;;;###autoload
|
||
|
|
(defun rdir-query-replace (from to file-regexp root &optional delimited)
|
||
|
|
"Replace FROM with TO in FILES in directory tree ROOT.
|
||
|
|
This runs `query-replace-regexp' in files matching FILES in
|
||
|
|
directory tree ROOT.
|
||
|
|
|
||
|
|
See `tags-query-replace' for DELIMETED and more information."
|
||
|
|
(interactive (dir-replace-read-parameters nil t))
|
||
|
|
(message "%s" (list from to file-regexp root delimited))
|
||
|
|
;;(let ((files (directory-files root nil file-regexp))) (message "files=%s" files))
|
||
|
|
(tags-query-replace from to delimited
|
||
|
|
`(rdir-get-files ,root ,file-regexp)))
|
||
|
|
|
||
|
|
;; (rdir-get-files ".." "^a.*\.el$")
|
||
|
|
(defun rdir-get-files (root file-regexp)
|
||
|
|
(let ((files (directory-files root t file-regexp))
|
||
|
|
(subdirs (directory-files root t)))
|
||
|
|
(dolist (subdir subdirs)
|
||
|
|
(when (and (file-directory-p subdir)
|
||
|
|
(not (or (string= "/." (substring subdir -2))
|
||
|
|
(string= "/.." (substring subdir -3)))))
|
||
|
|
(setq files (append files (rdir-get-files subdir file-regexp) nil))))
|
||
|
|
files))
|
||
|
|
|
||
|
|
(defun dir-replace-read-parameters (has-dir recursive)
|
||
|
|
(let* ((common
|
||
|
|
(let (;;(query-replace-from-history-variable 'grep-regexp-history)
|
||
|
|
;;(query-replace-defaults (or grep-query-replace-defaults
|
||
|
|
;; query-replace-defaults))
|
||
|
|
)
|
||
|
|
(query-replace-read-args
|
||
|
|
"Query replace regexp in files" t t)))
|
||
|
|
(from (nth 0 common))
|
||
|
|
(to (nth 1 common))
|
||
|
|
(delimited (nth 2 common))
|
||
|
|
(files (replace-read-files from to))
|
||
|
|
(root (unless has-dir (read-directory-name (if recursive "Root directory: "
|
||
|
|
"In single directory: ")))))
|
||
|
|
(list from to files root delimited)))
|
||
|
|
|
||
|
|
;; Mostly copied from `grep-read-files'. Could possible be merged with
|
||
|
|
;; that.
|
||
|
|
(defvar replace-read-files-history nil)
|
||
|
|
;;;###autoload
|
||
|
|
(defun replace-read-files (regexp &optional replace)
|
||
|
|
"Read files arg for replace."
|
||
|
|
(let* ((bn (or (buffer-file-name) (buffer-name)))
|
||
|
|
(fn (and bn
|
||
|
|
(stringp bn)
|
||
|
|
(file-name-nondirectory bn)))
|
||
|
|
(default
|
||
|
|
(let ((pre-default
|
||
|
|
(or (and fn
|
||
|
|
(let ((aliases grep-files-aliases)
|
||
|
|
alias)
|
||
|
|
(while aliases
|
||
|
|
(setq alias (car aliases)
|
||
|
|
aliases (cdr aliases))
|
||
|
|
(if (string-match (wildcard-to-regexp
|
||
|
|
(cdr alias)) fn)
|
||
|
|
(setq aliases nil)
|
||
|
|
(setq alias nil)))
|
||
|
|
(cdr alias)))
|
||
|
|
(and fn
|
||
|
|
(let ((ext (file-name-extension fn)))
|
||
|
|
(and ext (concat "^.*\." ext))))
|
||
|
|
(car replace-read-files-history)
|
||
|
|
(car (car grep-files-aliases)))))
|
||
|
|
(if (string-match-p "^\\*\\.[a-zA-Z0-9]*$" pre-default)
|
||
|
|
(concat "\\." (substring pre-default 2) "$")
|
||
|
|
pre-default)))
|
||
|
|
(files (read-string
|
||
|
|
(if replace
|
||
|
|
(concat "Replace \"" regexp
|
||
|
|
"\" with \"" replace "\" in files"
|
||
|
|
(if default (concat " (default " default
|
||
|
|
", regexp or *.EXT)"))
|
||
|
|
": ")
|
||
|
|
(concat "Search for \"" regexp
|
||
|
|
"\" in files"
|
||
|
|
(if default (concat " (default " default ")"))
|
||
|
|
": "))
|
||
|
|
nil 'replace-read-files-history default)))
|
||
|
|
(let ((pattern (and files
|
||
|
|
(or (cdr (assoc files grep-files-aliases))
|
||
|
|
files))))
|
||
|
|
(if (and pattern
|
||
|
|
(string-match-p "^\\*\\.[a-zA-Z0-9]*$" pattern))
|
||
|
|
(concat "\\." (substring pattern 2) "$")
|
||
|
|
pattern))))
|
||
|
|
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;;;; Info
|
||
|
|
|
||
|
|
;;;###autoload
|
||
|
|
(defun info-open-file (info-file)
|
||
|
|
"Open an info file in `Info-mode'."
|
||
|
|
(interactive
|
||
|
|
(let ((name (read-file-name "Info file: "
|
||
|
|
nil ;; dir
|
||
|
|
nil ;; default-filename
|
||
|
|
t ;; mustmatch
|
||
|
|
nil ;; initial
|
||
|
|
;; predicate:
|
||
|
|
(lambda (file)
|
||
|
|
(or (file-directory-p file)
|
||
|
|
(string-match ".*\\.info\\'" file))))))
|
||
|
|
(list name)))
|
||
|
|
(info info-file))
|
||
|
|
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;;;; Exec path etc
|
||
|
|
|
||
|
|
(defun ourcomments-which (prog)
|
||
|
|
"Look for first program PROG in `exec-path' using `exec-suffixes'.
|
||
|
|
Return full path if found."
|
||
|
|
(interactive "sProgram: ")
|
||
|
|
(let ((path (executable-find prog)))
|
||
|
|
(when (with-no-warnings (called-interactively-p))
|
||
|
|
(message "%s found in %s" prog path))
|
||
|
|
path))
|
||
|
|
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;;;; Custom faces and keys
|
||
|
|
|
||
|
|
;;;###autoload
|
||
|
|
(defun use-custom-style ()
|
||
|
|
"Setup like in `Custom-mode', but without things specific to Custom."
|
||
|
|
(make-local-variable 'widget-documentation-face)
|
||
|
|
(setq widget-documentation-face 'custom-documentation)
|
||
|
|
(make-local-variable 'widget-button-face)
|
||
|
|
(setq widget-button-face custom-button)
|
||
|
|
(setq show-trailing-whitespace nil)
|
||
|
|
|
||
|
|
;; We need this because of the "More" button on docstrings.
|
||
|
|
;; Otherwise clicking on "More" can push point offscreen, which
|
||
|
|
;; causes the window to recenter on point, which pushes the
|
||
|
|
;; newly-revealed docstring offscreen; which is annoying. -- cyd.
|
||
|
|
(set (make-local-variable 'widget-button-click-moves-point) t)
|
||
|
|
|
||
|
|
(set (make-local-variable 'widget-button-pressed-face) custom-button-pressed)
|
||
|
|
(set (make-local-variable 'widget-mouse-face) custom-button-mouse)
|
||
|
|
|
||
|
|
;; When possible, use relief for buttons, not bracketing. This test
|
||
|
|
;; may not be optimal.
|
||
|
|
(when custom-raised-buttons
|
||
|
|
(set (make-local-variable 'widget-push-button-prefix) "")
|
||
|
|
(set (make-local-variable 'widget-push-button-suffix) "")
|
||
|
|
(set (make-local-variable 'widget-link-prefix) "")
|
||
|
|
(set (make-local-variable 'widget-link-suffix) ""))
|
||
|
|
|
||
|
|
;; From widget-keymap
|
||
|
|
(local-set-key "\t" 'widget-forward)
|
||
|
|
(local-set-key "\e\t" 'widget-backward)
|
||
|
|
(local-set-key [(shift tab)] 'advertised-widget-backward)
|
||
|
|
(local-set-key [backtab] 'widget-backward)
|
||
|
|
(local-set-key [down-mouse-2] 'widget-button-click)
|
||
|
|
(local-set-key [down-mouse-1] 'widget-button-click)
|
||
|
|
(local-set-key [(control ?m)] 'widget-button-press)
|
||
|
|
;; From custom-mode-map
|
||
|
|
(local-set-key " " 'scroll-up)
|
||
|
|
(local-set-key "\177" 'scroll-down)
|
||
|
|
(local-set-key "n" 'widget-forward)
|
||
|
|
(local-set-key "p" 'widget-backward))
|
||
|
|
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;;;; Bookmarks
|
||
|
|
|
||
|
|
(defun bookmark-next-marked ()
|
||
|
|
(interactive)
|
||
|
|
(let ((bb (get-buffer "*Bookmark List*"))
|
||
|
|
pos)
|
||
|
|
(when bb
|
||
|
|
(with-current-buffer bb
|
||
|
|
(setq pos (re-search-forward "^>" nil t))
|
||
|
|
(unless pos
|
||
|
|
(goto-char (point-min))
|
||
|
|
(setq pos (re-search-forward "^>" nil t)))))
|
||
|
|
(if pos
|
||
|
|
(with-current-buffer bb
|
||
|
|
;; Defined in bookmark.el, should be loaded now.
|
||
|
|
(bookmark-bmenu-this-window))
|
||
|
|
(call-interactively 'bookmark-bmenu-list)
|
||
|
|
(message "Please select bookmark for bookmark next command, then press n"))))
|
||
|
|
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;;;; Org Mode
|
||
|
|
|
||
|
|
(defun ourcomments-org-complete-and-replace-file-link ()
|
||
|
|
"If on a org file link complete file name and replace it."
|
||
|
|
(interactive)
|
||
|
|
(require 'org)
|
||
|
|
(let* ((here (point-marker))
|
||
|
|
(on-link (eq 'org-link (get-text-property (point) 'face)))
|
||
|
|
(link-beg (when on-link
|
||
|
|
(previous-single-property-change (1+ here) 'face)))
|
||
|
|
(link-end (when on-link
|
||
|
|
(next-single-property-change here 'face)))
|
||
|
|
(link (when on-link (buffer-substring-no-properties link-beg link-end)))
|
||
|
|
type+link
|
||
|
|
link-link
|
||
|
|
link-link-beg
|
||
|
|
link-link-end
|
||
|
|
new-link
|
||
|
|
dir
|
||
|
|
ovl)
|
||
|
|
(when (and on-link
|
||
|
|
(string-match (rx string-start "[["
|
||
|
|
(group (0+ (not (any "]"))))) link))
|
||
|
|
(setq type+link (match-string 1 link))
|
||
|
|
(when (string-match "^file:\\(.*\\)" type+link)
|
||
|
|
(setq link-link (match-string 1 type+link))
|
||
|
|
(setq link-link-beg (+ 2 link-beg (match-beginning 1)))
|
||
|
|
(setq link-link-end (+ 2 link-beg (match-end 1)))
|
||
|
|
(unwind-protect
|
||
|
|
(progn
|
||
|
|
(setq ovl (make-overlay link-link-beg link-link-end))
|
||
|
|
(overlay-put ovl 'face 'highlight)
|
||
|
|
(when link-link
|
||
|
|
(setq link-link (org-link-unescape link-link))
|
||
|
|
(setq dir (when (and link-link (> (length link-link) 0))
|
||
|
|
(file-name-directory link-link)))
|
||
|
|
(setq new-link (read-file-name "Org file:" dir nil nil (file-name-nondirectory link-link)))
|
||
|
|
(delete-overlay ovl)
|
||
|
|
(setq new-link (expand-file-name new-link))
|
||
|
|
(setq new-link (file-relative-name new-link))
|
||
|
|
(delete-region link-link-beg link-link-end)
|
||
|
|
(goto-char link-link-beg)
|
||
|
|
(insert (org-link-escape new-link))
|
||
|
|
t))
|
||
|
|
(delete-overlay ovl)
|
||
|
|
(goto-char here))))))
|
||
|
|
|
||
|
|
;; (defun ourcomments-org-paste-html-link (html-link)
|
||
|
|
;; "If there is an html link on clipboard paste it as an org link.
|
||
|
|
;; If you have this on the clipboard
|
||
|
|
;; <a href=\"http://my.site.org/\">My Site</a>
|
||
|
|
;; It will paste this
|
||
|
|
;; [[http://my.site.org/][My Site]]
|
||
|
|
;; If the URL is to a local file it will create an org link to the
|
||
|
|
;; file.
|
||
|
|
;; Tip: You can use the Firefox plugin Copy as HTML Link, see URL
|
||
|
|
;; `https://addons.mozilla.org/en-US/firefox/addon/2617'.
|
||
|
|
;; "
|
||
|
|
;; (interactive (list (current-kill 0)))
|
||
|
|
;; (let ((conv-link (ourcomments-org-convert-html-link html-link)))
|
||
|
|
;; (if (not conv-link)
|
||
|
|
;; (message (propertize "No html link on clipboard" 'face 'font-lock-warning-face))
|
||
|
|
;; (insert conv-link))))
|
||
|
|
|
||
|
|
;; (defun ourcomments-org-convert-html-link (html-link)
|
||
|
|
;; (let (converted url str)
|
||
|
|
;; (save-match-data
|
||
|
|
;; (while (string-match ourcomments-org-paste-html-link-regexp html-link)
|
||
|
|
;; (setq converted t)
|
||
|
|
;; (setq url (match-string 1 html-link))
|
||
|
|
;; (setq str (match-string 2 html-link))
|
||
|
|
;; ;;(setq str (concat str (format "%s" (setq temp-n (1+ temp-n)))))
|
||
|
|
;; (setq html-link (replace-match (concat "[[" url "][" str "]]") nil nil html-link 0))))
|
||
|
|
;; (when converted
|
||
|
|
;; html-link)))
|
||
|
|
|
||
|
|
(defconst ourcomments-org-paste-html-link-regexp
|
||
|
|
"\\`\\(?:<a [^>]*?href=\"\\(.*?\\)\"[^>]*?>\\([^<]*\\)</a>\\)\\'")
|
||
|
|
|
||
|
|
;;(string-match-p ourcomments-org-paste-html-link-regexp "<a href=\"link\">text</a>")
|
||
|
|
|
||
|
|
;;(defvar temp-n 0)
|
||
|
|
(defun ourcomments-org-convert-html-links-in-buffer (beg end)
|
||
|
|
"Convert html link between BEG and END to org mode links.
|
||
|
|
If there is an html link in the buffer
|
||
|
|
|
||
|
|
<a href=\"http://my.site.org/\">My Site</a>
|
||
|
|
|
||
|
|
that starts at BEG and ends at END then convert it to this
|
||
|
|
|
||
|
|
[[http://my.site.org/][My Site]]
|
||
|
|
|
||
|
|
If the URL is to a local file and the buffer is visiting a file
|
||
|
|
make the link relative.
|
||
|
|
|
||
|
|
However, if the html link is inside an #+BEGIN - #+END block or a
|
||
|
|
variant of such blocks then leave the link as it is."
|
||
|
|
(when (derived-mode-p 'org-mode)
|
||
|
|
(save-match-data
|
||
|
|
(let ((here (copy-marker (point)))
|
||
|
|
url str converted
|
||
|
|
lit-beg lit-end)
|
||
|
|
(goto-char beg)
|
||
|
|
(save-restriction
|
||
|
|
(widen)
|
||
|
|
(setq lit-beg (search-backward "#+BEGIN" nil t))
|
||
|
|
(when lit-beg
|
||
|
|
(goto-char lit-beg)
|
||
|
|
(setq lit-end (or (search-forward "#+END" nil t)
|
||
|
|
(point-max)))))
|
||
|
|
(when (or (not lit-beg)
|
||
|
|
(> beg lit-end))
|
||
|
|
(goto-char beg)
|
||
|
|
(when (save-restriction
|
||
|
|
(narrow-to-region beg end)
|
||
|
|
(looking-at ourcomments-org-paste-html-link-regexp))
|
||
|
|
(setq converted t)
|
||
|
|
(setq url (match-string-no-properties 1))
|
||
|
|
(setq str (match-string-no-properties 2))
|
||
|
|
;; Check if the URL is to a local file and absolute. And we
|
||
|
|
;; have a buffer.
|
||
|
|
(when (and (buffer-file-name)
|
||
|
|
(> (length url) 5)
|
||
|
|
(string= (substring url 0 6) "file:/"))
|
||
|
|
(let ((abs-file-url
|
||
|
|
(if (not (memq system-type '(windows-nt ms-dos)))
|
||
|
|
(substring url 8)
|
||
|
|
(if (string= (substring url 0 8) "file:///")
|
||
|
|
(substring url 8)
|
||
|
|
;; file://c:/some/where.txt
|
||
|
|
(substring url 7)))))
|
||
|
|
(setq url (concat "file:"
|
||
|
|
(file-relative-name abs-file-url
|
||
|
|
(file-name-directory
|
||
|
|
(buffer-file-name)))))))
|
||
|
|
(replace-match (concat "[[" url "][" str "]]") nil nil nil 0)))
|
||
|
|
(goto-char here)
|
||
|
|
nil))))
|
||
|
|
|
||
|
|
(defvar ourcomments-paste-with-convert-hook nil
|
||
|
|
"Normal hook run after certain paste commands.
|
||
|
|
These paste commands are in the list
|
||
|
|
`ourcomments-paste-with-convert-commands'.
|
||
|
|
|
||
|
|
Each function in this hook is called with two parameters, the
|
||
|
|
start and end of the pasted text, until a function returns
|
||
|
|
non-nil.")
|
||
|
|
(add-hook 'ourcomments-paste-with-convert-hook 'ourcomments-org-convert-html-links-in-buffer)
|
||
|
|
|
||
|
|
(defvar ourcomments-paste-beg) ;; dyn var
|
||
|
|
(defvar ourcomments-paste-end) ;; dyn var
|
||
|
|
(defun ourcomments-grab-paste-bounds (beg end len)
|
||
|
|
(setq ourcomments-paste-beg (min beg ourcomments-paste-beg))
|
||
|
|
(setq ourcomments-paste-end (max end ourcomments-paste-end)))
|
||
|
|
|
||
|
|
(defmacro ourcomments-advice-paste-command (paste-command)
|
||
|
|
(let ((adv-name (make-symbol (concat "ourcomments-org-ad-"
|
||
|
|
(symbol-name paste-command)))))
|
||
|
|
`(defadvice ,paste-command (around
|
||
|
|
,adv-name)
|
||
|
|
(let ((ourcomments-paste-beg (point-max)) ;; dyn var
|
||
|
|
(ourcomments-paste-end (point-min))) ;; dyn var
|
||
|
|
(add-hook 'after-change-functions `ourcomments-grab-paste-bounds nil t)
|
||
|
|
ad-do-it ;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
(remove-hook 'after-change-functions `ourcomments-grab-paste-bounds t)
|
||
|
|
(run-hook-with-args-until-success 'ourcomments-paste-with-convert-hook
|
||
|
|
ourcomments-paste-beg
|
||
|
|
ourcomments-paste-end)))))
|
||
|
|
|
||
|
|
(defcustom ourcomments-paste-with-convert-commands '(yank cua-paste viper-put-back viper-Put-back)
|
||
|
|
"Commands for which past converting is done.
|
||
|
|
See `ourcomments-paste-with-convert-mode' for more information."
|
||
|
|
:type '(repeat function)
|
||
|
|
:group 'ourcomments-util)
|
||
|
|
|
||
|
|
;;;###autoload
|
||
|
|
(define-minor-mode ourcomments-paste-with-convert-mode
|
||
|
|
"Pasted text may be automatically converted in this mode.
|
||
|
|
The functions in `ourcomments-paste-with-convert-hook' are run
|
||
|
|
after commands in `ourcomments-paste-with-convert-commands' if any
|
||
|
|
of the functions returns non-nil that text is inserted instead of
|
||
|
|
the original text.
|
||
|
|
|
||
|
|
For exampel when this mode is on and you paste an html link in an
|
||
|
|
`org-mode' buffer it will be directly converted to an org style
|
||
|
|
link. \(This is the default behaviour.)
|
||
|
|
|
||
|
|
Tip: The Firefox plugin Copy as HTML Link is handy, see URL
|
||
|
|
`https://addons.mozilla.org/en-US/firefox/addon/2617'.
|
||
|
|
|
||
|
|
Note: This minor mode will defadvice the paste commands."
|
||
|
|
:global t
|
||
|
|
:group 'cua
|
||
|
|
:group 'viper
|
||
|
|
:group 'ourcomments-util
|
||
|
|
(if ourcomments-paste-with-convert-mode
|
||
|
|
(progn
|
||
|
|
(dolist (command ourcomments-paste-with-convert-commands)
|
||
|
|
(eval `(ourcomments-advice-paste-command ,command))
|
||
|
|
(ad-activate command)))
|
||
|
|
(dolist (command ourcomments-paste-with-convert-commands)
|
||
|
|
(ad-unadvise command))))
|
||
|
|
|
||
|
|
;; (ourcomments-advice-paste-command cua-paste)
|
||
|
|
;; (ad-activate 'cua-paste)
|
||
|
|
;; (ad-deactivate 'cua-paste)
|
||
|
|
;; (ad-update 'cua-paste)
|
||
|
|
;; (ad-unadvise 'cua-paste)
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;;;; Menu commands to M-x history
|
||
|
|
|
||
|
|
;; (where-is-internal 'mumamo-mark-chunk nil nil)
|
||
|
|
;; (where-is-internal 'mark-whole-buffer nil nil)
|
||
|
|
;; (where-is-internal 'save-buffer nil nil)
|
||
|
|
;; (where-is-internal 'revert-buffer nil nil)
|
||
|
|
;; (setq extended-command-history nil)
|
||
|
|
(defun ourcomments-M-x-menu-pre ()
|
||
|
|
"Add menu command to M-x history."
|
||
|
|
(let ((is-menu-command (equal '(menu-bar)
|
||
|
|
(when (< 0 (length (this-command-keys-vector)))
|
||
|
|
(elt (this-command-keys-vector) 0))))
|
||
|
|
(pre-len (length extended-command-history)))
|
||
|
|
(when (and is-menu-command
|
||
|
|
(not (memq this-command '(ourcomments-M-x-menu-mode))))
|
||
|
|
(pushnew (symbol-name this-command) extended-command-history)
|
||
|
|
(when (< pre-len (length extended-command-history))
|
||
|
|
;; This message is given pre-command and is therefore likely
|
||
|
|
;; to be overwritten, but that is ok in this case. If the user
|
||
|
|
;; has seen one of these messages s?he knows.
|
||
|
|
(message (propertize "(Added %s to M-x history so you can run it from there)"
|
||
|
|
'face 'file-name-shadow)
|
||
|
|
this-command)))))
|
||
|
|
|
||
|
|
;;;###autoload
|
||
|
|
(define-minor-mode ourcomments-M-x-menu-mode
|
||
|
|
"Add commands started from Emacs menus to M-x history.
|
||
|
|
The purpose of this is to make it easier to redo them and easier
|
||
|
|
to learn how to do them from the command line \(which is often
|
||
|
|
faster if you know how to do it).
|
||
|
|
|
||
|
|
Only commands that are not already in M-x history are added."
|
||
|
|
:global t
|
||
|
|
(if ourcomments-M-x-menu-mode
|
||
|
|
(add-hook 'pre-command-hook 'ourcomments-M-x-menu-pre)
|
||
|
|
(remove-hook 'pre-command-hook 'ourcomments-M-x-menu-pre)))
|
||
|
|
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;;;; Warnings etc
|
||
|
|
|
||
|
|
(defvar ourcomments-warnings nil)
|
||
|
|
|
||
|
|
(defun ourcomments-display-warnings ()
|
||
|
|
(condition-case err
|
||
|
|
(let ((msg (mapconcat 'identity (reverse ourcomments-warnings) "\n")))
|
||
|
|
(setq ourcomments-warnings nil)
|
||
|
|
(message "%s" (propertize msg 'face 'secondary-selection)))
|
||
|
|
(error (message "ourcomments-display-warnings: %s" err))))
|
||
|
|
|
||
|
|
(defun ourcomments-warning-post ()
|
||
|
|
(condition-case err
|
||
|
|
(run-with-idle-timer 0.5 nil 'ourcomments-display-warnings)
|
||
|
|
(error (message "ourcomments-warning-post: %s" err))))
|
||
|
|
|
||
|
|
;;;###autoload
|
||
|
|
(defun ourcomments-warning (format-string &rest args)
|
||
|
|
(setq ourcomments-warnings (cons (apply 'format format-string args)
|
||
|
|
ourcomments-warnings))
|
||
|
|
(add-hook 'post-command-hook 'ourcomments-warning-post))
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
(provide 'ourcomments-util)
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;;; ourcomments-util.el ends here
|