1 ;;; ourcomments-util.el --- Utility routines
3 ;; Author: Lennart Borgman <lennart dot borgman at gmail dot com>
4 ;; Created: Wed Feb 21 2007
5 (defconst ourcomments-util:version "0.25") ;;Version:
6 ;; Last-Updated: 2009-08-04 Tue
8 ;; Compatibility: Emacs 22
10 ;; Features that might be required by this library:
14 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
18 ;; The functionality given by these small routines should in my
19 ;; opinion be part of Emacs (but they are not that currently).
21 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
26 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
28 ;; This program is free software; you can redistribute it and/or modify
29 ;; it under the terms of the GNU General Public License as published by
30 ;; the Free Software Foundation; either version 2, or (at your option)
33 ;; This program is distributed in the hope that it will be useful,
34 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
35 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
36 ;; GNU General Public License for more details.
38 ;; You should have received a copy of the GNU General Public License
39 ;; along with this program; see the file COPYING. If not, write to the
40 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
41 ;; Boston, MA 02111-1307, USA.
43 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
47 (eval-when-compile (require 'apropos))
48 (eval-when-compile (require 'bookmark))
49 (eval-when-compile (require 'cl))
50 (eval-when-compile (require 'grep))
51 (eval-when-compile (require 'ido))
52 (eval-when-compile (require 'org))
53 (eval-when-compile (require 'recentf))
54 (eval-when-compile (require 'uniquify))
58 ;; (ourcomments-indirect-fun 'html-mumamo)
59 ;; (ourcomments-indirect-fun 'html-mumamo-mode)
61 (defun ourcomments-indirect-fun (fun)
62 "Get the alias symbol for function FUN if any."
63 ;; This code is from `describe-function-1'.
64 (when (and (symbolp fun)
66 (let ((def (symbol-function fun)))
68 (while (and (fboundp def)
69 (symbolp (symbol-function def)))
70 (setq def (symbol-function def)))
73 (defun ourcomments-goto-line (line)
74 "A version of `goto-line' for use in elisp code."
77 (goto-char (point-min))
78 (forward-line (1- line))))
80 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
83 (defun point-to-coord (point)
84 "Return coordinates of POINT in selected window.
85 The coordinates are in the form \(\(XOFFSET YOFFSET) WINDOW).
86 This form is suitable for `popup-menu'."
87 ;; Fix-me: showtip.el adds (window-inside-pixel-edges
88 ;; (selected-window)). Why?
89 (let* ((pn (posn-at-point point))
93 (pos (list (list x (+ y 20)) (selected-window))))
97 (defun popup-menu-at-point (menu &optional prefix)
98 "Popup the given menu at point.
99 This is similar to `popup-menu' and MENU and PREFIX has the same
100 meaning as there. The position for the popup is however where
101 the window point is."
102 (let ((where (point-to-coord (point))))
103 (popup-menu menu where prefix)))
108 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
109 ;;;; Toggles in menus
112 (defmacro define-toggle (symbol value doc &rest args)
113 "Declare SYMBOL as a customizable variable with a toggle function.
114 The purpose of this macro is to define a defcustom and a toggle
115 function suitable for use in a menu.
117 The arguments have the same meaning as for `defcustom' with these
120 - The :type keyword cannot be used. Type is always 'boolean.
121 - VALUE must be t or nil.
123 DOC and ARGS are just passed to `defcustom'.
125 A `defcustom' named SYMBOL with doc-string DOC and a function
126 named SYMBOL-toggle is defined. The function toggles the value
127 of SYMBOL. It takes no parameters.
129 To create a menu item something similar to this can be used:
131 \(define-key map [SYMBOL]
132 \(list 'menu-item \"Toggle nice SYMBOL\"
134 :button '(:toggle . SYMBOL)))"
138 (let* ((SYMBOL-toggle (intern (concat (symbol-name symbol) "-toggle")))
139 (SYMBOL-name (symbol-name symbol))
141 (fun-doc (concat "Toggles the \(boolean) value of `"
144 "For how to set it permanently see this variable.\n"
146 (let ((var (append `(defcustom ,symbol ,value ,var-doc)
149 (fun `(defun ,SYMBOL-toggle ()
152 (customize-set-variable (quote ,symbol) (not ,symbol)))))
153 ;;(message "\nvar=%S\nfun=%S\n" var fun)
154 ;; Fix-me: I am having problems with this one, see
155 ;; http://lists.gnu.org/archive/html/help-gnu-emacs/2009-12/msg00608.html
159 ;;(macroexpand '(define-toggle my-toggle t "doc" :tag "Short help" :group 'popcmp))
160 ;;(macroexpand-all (define-toggle my-toggle t "doc" :tag "Short help" :group 'popcmp))
163 (defmacro define-toggle-old (symbol value doc &rest args)
164 (declare (doc-string 3))
167 (let ((var-decl (list 'custom-declare-variable
172 (let ((arg (car args)))
173 (setq args (cdr args))
174 (unless (symbolp arg)
175 (error "Junk in args %S" args))
179 (error "Keyword %s is missing an argument" keyword))
180 (setq args (cdr args))
182 ((not (memq keyword '(:type)))
183 (setq var-decl (append var-decl (list keyword value))))
185 (lwarn '(define-toggle) :error "Keyword %s can't be used here"
187 (when (assoc :type var-decl) (error ":type is set. Should not happen!"))
188 (setq var-decl (append var-decl (list :type '(quote boolean))))
190 (let* ((SYMBOL-toggle (intern (concat (symbol-name symbol) "-toggle")))
191 (SYMBOL-name (symbol-name symbol))
192 (fun-doc (concat "Toggles the \(boolean) value of `"
195 "For how to set it permanently see this variable.\n"
196 ;;"\nDescription of `" SYMBOL-name "':\n" doc
198 `(defun ,SYMBOL-toggle ()
201 (customize-set-variable (quote ,symbol) (not ,symbol)))
206 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
207 ;;;; Indentation of regions
209 ;; From an idea by weber <hugows@gmail.com>
210 ;; (defun indent-line-or-region ()
211 ;; "Indent line or region.
212 ;; Only do this if indentation seems bound to \\t.
214 ;; Call `indent-region' if region is active, otherwise
215 ;; `indent-according-to-mode'."
217 ;; ;; Do a wild guess if we should indent or not ...
218 ;; (let* ((indent-region-mode)
219 ;; ;; The above hides the `indent-line-or-region' binding
220 ;; (t-bound (key-binding [?\t])))
223 ;; (string-match "indent" (symbol-name t-bound))))
224 ;; (call-interactively t-bound t)
225 ;; (if (and mark-active ;; there is a visible region selected
226 ;; transient-mark-mode)
227 ;; (indent-region (region-beginning) (region-end))
228 ;; (indent-according-to-mode))))) ;; indent line
230 ;; (define-minor-mode indent-region-mode
231 ;; "Use \\t to indent line or region.
232 ;; The key \\t is bound to `indent-line-or-region' if this mode is
235 ;; :keymap '(([?\t] . indent-line-or-region)))
236 ;; (when indent-region-mode (indent-region-mode 1))
239 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
242 ;; (defmacro define-globalized-minor-mode-with-on-off (global-mode mode
245 ;; "Make a global mode GLOBAL-MODE corresponding to buffer-local minor MODE.
246 ;; This is a special variant of `define-globalized-minor-mode' for
247 ;; mumamo. It let bounds the variable GLOBAL-MODE-checking before
248 ;; calling TURN-ON or TURN-OFF.
250 ;; TURN-ON is a function that will be called with no args in every buffer
251 ;; and that should try to turn MODE on if applicable for that buffer.
252 ;; TURN-OFF is a function that turns off MODE in a buffer.
253 ;; KEYS is a list of CL-style keyword arguments. As the minor mode
254 ;; defined by this function is always global, any :global keyword is
255 ;; ignored. Other keywords have the same meaning as in `define-minor-mode',
256 ;; which see. In particular, :group specifies the custom group.
257 ;; The most useful keywords are those that are passed on to the
258 ;; `defcustom'. It normally makes no sense to pass the :lighter
259 ;; or :keymap keywords to `define-globalized-minor-mode', since these
260 ;; are usually passed to the buffer-local version of the minor mode.
262 ;; If MODE's set-up depends on the major mode in effect when it was
263 ;; enabled, then disabling and reenabling MODE should make MODE work
264 ;; correctly with the current major mode. This is important to
265 ;; prevent problems with derived modes, that is, major modes that
266 ;; call another major mode in their body."
268 ;; (let* ((global-mode-name (symbol-name global-mode))
269 ;; (pretty-name (easy-mmode-pretty-mode-name mode))
270 ;; (pretty-global-name (easy-mmode-pretty-mode-name global-mode))
272 ;; (extra-keywords nil)
273 ;; (MODE-buffers (intern (concat global-mode-name "-buffers")))
274 ;; (MODE-enable-in-buffers
275 ;; (intern (concat global-mode-name "-enable-in-buffers")))
276 ;; (MODE-check-buffers
277 ;; (intern (concat global-mode-name "-check-buffers")))
278 ;; (MODE-cmhh (intern (concat global-mode-name "-cmhh")))
279 ;; (MODE-major-mode (intern (concat (symbol-name mode)
281 ;; (MODE-checking (intern (concat global-mode-name "-checking")))
285 ;; (while (keywordp (setq keyw (car keys)))
286 ;; (setq keys (cdr keys))
288 ;; (:group (setq group (nconc group (list :group (pop keys)))))
289 ;; (:global (setq keys (cdr keys)))
290 ;; (t (push keyw extra-keywords) (push (pop keys) extra-keywords))))
293 ;; ;; We might as well provide a best-guess default group.
295 ;; `(:group ',(intern (replace-regexp-in-string
296 ;; "-mode\\'" "" (symbol-name mode))))))
300 ;; ;; Define functions for the global mode first so that it can be
301 ;; ;; turned on during load:
303 ;; ;; List of buffers left to process.
304 ;; (defvar ,MODE-buffers nil)
306 ;; ;; The function that calls TURN-ON in each buffer.
307 ;; (defun ,MODE-enable-in-buffers ()
308 ;; (let ((,MODE-checking nil))
309 ;; (dolist (buf ,MODE-buffers)
310 ;; (when (buffer-live-p buf)
311 ;; (with-current-buffer buf
313 ;; (unless (eq ,MODE-major-mode major-mode)
314 ;; (setq ,MODE-checking t)
317 ;; (setq ,MODE-checking nil)
318 ;; (setq ,MODE-major-mode major-mode))
319 ;; (setq ,MODE-checking t)
321 ;; (setq ,MODE-checking nil)
322 ;; (setq ,MODE-major-mode major-mode)))))))
323 ;; (put ',MODE-enable-in-buffers 'definition-name ',global-mode)
325 ;; (defun ,MODE-check-buffers ()
326 ;; (,MODE-enable-in-buffers)
327 ;; (setq ,MODE-buffers nil)
328 ;; (remove-hook 'post-command-hook ',MODE-check-buffers))
329 ;; (put ',MODE-check-buffers 'definition-name ',global-mode)
331 ;; ;; The function that catches kill-all-local-variables.
332 ;; (defun ,MODE-cmhh ()
333 ;; (add-to-list ',MODE-buffers (current-buffer))
334 ;; (add-hook 'post-command-hook ',MODE-check-buffers))
335 ;; (put ',MODE-cmhh 'definition-name ',global-mode)
338 ;; (defvar ,MODE-major-mode nil)
339 ;; (make-variable-buffer-local ',MODE-major-mode)
341 ;; ;; The actual global minor-mode
342 ;; (define-minor-mode ,global-mode
343 ;; ,(format "Toggle %s in every possible buffer.
344 ;; With prefix ARG, turn %s on if and only if ARG is positive.
345 ;; %s is enabled in all buffers where `%s' would do it.
346 ;; See `%s' for more information on %s."
347 ;; pretty-name pretty-global-name pretty-name turn-on
349 ;; :global t ,@group ,@(nreverse extra-keywords)
351 ;; ;; Setup hook to handle future mode changes and new buffers.
354 ;; (add-hook 'after-change-major-mode-hook
355 ;; ',MODE-enable-in-buffers)
356 ;; ;;(add-hook 'find-file-hook ',MODE-check-buffers)
357 ;; (add-hook 'find-file-hook ',MODE-cmhh)
358 ;; (add-hook 'change-major-mode-hook ',MODE-cmhh))
359 ;; (remove-hook 'after-change-major-mode-hook ',MODE-enable-in-buffers)
360 ;; ;;(remove-hook 'find-file-hook ',MODE-check-buffers)
361 ;; (remove-hook 'find-file-hook ',MODE-cmhh)
362 ;; (remove-hook 'change-major-mode-hook ',MODE-cmhh))
364 ;; ;; Go through existing buffers.
365 ;; (let ((,MODE-checking t))
366 ;; (dolist (buf (buffer-list))
367 ;; (with-current-buffer buf
368 ;; ;;(if ,global-mode (,turn-on) (when ,mode (,mode -1)))
369 ;; (if ,global-mode (,turn-on) (,turn-off))
375 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
379 ;; http://interglacial.com/~sburke/pub/emacs/sburke_dot_emacs.config
382 (defun unfill-paragraph ()
383 "Unfill the current paragraph."
384 (interactive) (with-unfilling 'fill-paragraph))
385 ;;(defalias 'unwrap-paragraph 'unfill-paragraph)
388 (defun unfill-region ()
389 "Unfill the current region."
390 (interactive) (with-unfilling 'fill-region))
391 ;;(defalias 'unwrap-region 'unfill-region)
394 (defun unfill-individual-paragraphs ()
395 "Unfill individual paragraphs in the current region."
396 (interactive) (with-unfilling 'fill-individual-paragraphs))
397 ;;(defalias 'unwrap-individual-paragraphs 'unfill-individual-paragraphs)
399 (defun with-unfilling (fn)
400 "Unfill using the fill function FN."
401 (let ((fill-column (1+ (point-max)))) (call-interactively fn)))
403 (defvar fill-dwim-state nil)
404 (defvar fill-dwim-mark nil)
407 (defun fill-dwim (arg)
408 "Fill or unfill paragraph or region.
409 With prefix ARG fill only current line."
413 (equal (point-marker) fill-dwim-mark)
414 (setq fill-dwim-state nil))
416 ;; This avoids deactivating the mark
419 (call-interactively 'unfill-region)
420 (call-interactively 'fill-region))
421 (setq deactivate-mark nil))
423 (fill-region (line-beginning-position) (line-end-position))
425 (call-interactively 'unfill-paragraph)
426 (call-interactively 'fill-paragraph))))
427 (setq fill-dwim-mark (copy-marker (point)))
429 (setq fill-dwim-state (not fill-dwim-state))))
431 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
435 (defun ourcomments-mark-whole-buffer-or-field ()
436 "Mark whole buffer or editable field at point."
438 (let* ((field (widget-field-at (point)))
439 (from (when field (widget-field-start field)))
440 (to (when field (widget-field-end field)))
441 (size (when field (widget-get field :size))))
447 (eq (char-after (1- to)) ?\s))
450 (push-mark from nil t)
453 ;; (rassq 'genshi-nxhtml-mumamo-mode mumamo-defined-turn-on-functions)
454 ;; (major-modep 'nxhtml-mode)
455 ;; (major-modep 'nxhtml-mumamo-mode)
456 ;; (major-modep 'jsp-nxhtml-mumamo-mode)
457 ;; (major-modep 'gsp-nxhtml-mumamo-mode)
458 ;; (major-modep 'asp-nxhtml-mumamo-mode)
459 ;; (major-modep 'django-nxhtml-mumamo-mode)
460 ;; (major-modep 'eruby-nxhtml-mumamo-mode)
461 ;; (major-modep 'eruby-nxhtml-mumamo-mode)
462 ;; (major-modep 'smarty-nxhtml-mumamo-mode)
463 ;; (major-modep 'embperl-nxhtml-mumamo-mode)
464 ;; (major-modep 'laszlo-nxml-mumamo-mode)
465 ;; (major-modep 'genshi-nxhtml-mumamo-mode)
466 ;; (major-modep 'javascript-mode)
467 ;; (major-modep 'espresso-mode)
468 ;; (major-modep 'css-mode)
469 ;; (major-modep 'js-mode)
472 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
475 ;; Changed from move-beginning-of-line to beginning-of-line to support
476 ;; physical-line-mode.
477 ;; Fix-me: use end-of-visual-line etc.
479 (defun ourcomments-move-beginning-of-line(arg)
480 "Move point to beginning of line or indentation.
481 See `beginning-of-line' for ARG.
483 If `line-move-visual' is non-nil then the visual line beginning
486 If in a widget field stay in that."
490 (field (widget-field-at (point))))
491 (when line-move-visual
492 (line-move-visual -1 t)
494 (setq vis-pos (point))
496 (call-interactively 'beginning-of-line arg)
499 (while (and (> pos (point))
502 (line-move-visual 1 t)))
503 (line-move-visual -1 t))
504 (when (= pos (point))
505 (if (= 0 (current-column))
506 (skip-chars-forward " \t")
508 (beginning-of-line)))
510 (< (point) (widget-field-start field)))
511 (goto-char (widget-field-start field)))))
512 (put 'ourcomments-move-beginning-of-line 'CUA 'move)
515 (defun ourcomments-move-end-of-line(arg)
516 "Move point to end of line or after last non blank char.
517 See `end-of-line' for ARG.
519 Similar to `ourcomments-move-beginning-of-line' but for end of
522 (or arg (setq arg 1))
526 (when line-move-visual
527 (let (last-command) (line-move-visual 1 t))
529 (setq vis-pos (point))
531 (call-interactively 'end-of-line arg)
534 (setq eol-pos (point))
536 (let (last-command) (line-move-visual 1 t))
537 ;; move backwards if we moved to a new line
538 (unless (= (point) eol-pos)
540 (when (= pos (point))
541 (if (= (line-end-position) (point))
542 (skip-chars-backward " \t")
545 (put 'ourcomments-move-end-of-line 'CUA 'move)
547 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
550 (defun ourcomments-find-keymap-variables (key--- binding--- keymap---)
551 "Return a list of matching keymap variables.
552 They should have key KEY--- bound to BINDING--- and have value
555 Ignore `special-event-map', `global-map', `overriding-local-map'
556 and `overriding-terminal-local-map'."
559 (let ((parent (keymap-parent keymap---)))
561 (setq ancestors--- (cons parent ancestors---))
562 (setq parent (keymap-parent parent))))
563 (mapatoms (lambda (symbol)
564 (unless (memq symbol '(keymap---
570 overriding-terminal-local-map
574 (setq val (symbol-value symbol))
575 (when (keymapp symbol)
576 (setq val (symbol-function symbol))))
579 (eq binding--- (lookup-key val key--- t)))
580 (if (equal val keymap---)
581 (push symbol vars---)
584 (dolist (ancestor ancestors---)
585 (when (equal val ancestor)
586 (push symbol vars---)
587 (throw 'found nil)))))))))))
588 ;;; (let ((childs nil))
589 ;;; (dolist (var vars---)
590 ;;; (dolist (ancestor ancestors---)
591 ;;; (when (equal (keymap-parent var)
595 ;; This is modelled after `current-active-maps'.
596 (defun key-bindings (key &optional olp position)
597 "Return list of bindings for key sequence KEY in current keymaps.
598 The first binding is the active binding and the others are
599 bindings shadowed by this in the order of their priority level
600 \(see Info node `(elisp) Searching Keymaps').
602 The entries in the list have the form
604 \(BINDING (MAPS) MORE-INFO)
606 where BINDING is the command bound to and MAPS are matching maps
607 \(according to `ourcomments-find-keymap-variables').
609 MORE-INFO is a list with more information
611 \(PRIORITY-LEVEL \[ACTIVE-WHEN])
613 where PRIORITY-LEVEL is a symbol matching the level where the
614 keymap is found and ACTIVE-WHEN is a symbol which must be non-nil
615 for the keymap to be active \(minor mode levels only)."
616 ;;(message "\nkey-bindings %s %s %s" key olp position)
617 (let* ((bindings nil)
618 (maps (current-active-maps))
628 (local-map (current-local-map))
629 (pt (or position (point)))
630 (point-keymap (get-char-property pt 'keymap))
631 (point-local-map (get-char-property pt 'local-map))
634 (cons (list global-map 'global-map)
636 (when overriding-terminal-local-map
638 (cons (list overriding-terminal-local-map 'overriding-terminal-local-map)
640 (when overriding-local-map
642 (cons (list overriding-local-map 'overriding-local-map)
644 (unless (cdr keymaps)
645 (when point-local-map
647 (cons (list point-local-map 'point-local-map)
650 ;;/* If on a mode line string with a local keymap,
654 (cons (list local-map 'local-map)
658 ;;(message "================ Minor-modes")
659 (dolist (list '(emulation-mode-map-alists
660 minor-mode-overriding-map-alist
661 minor-mode-map-alist))
662 ;;(message "------- %s" list)
663 (let ((alists (if (eq list 'emulation-mode-map-alists)
665 (list (symbol-value list)))))
666 (dolist (alist alists)
667 ;;(message "\n(symbolp alist)=%s alist= %s (symbol-value alist)=%s" (symbolp alist) "dum" "dum2") ;alist "dummy");(when (symbolp alist) (symbol-value alist)))
668 (when (symbolp alist)
669 (setq alist (symbol-value alist)))
670 (dolist (assoc alist)
671 (let* (;(assoc (car alist-rec))
672 (var (when (consp assoc) (car assoc)))
673 (val (when (and (symbolp var)
675 (symbol-value var))))
676 ;;(message "var= %s, val= %s" var val)
679 (or (not (eq list 'minor-mode-map-alist))
680 (not (assq var minor-mode-overriding-map-alist))))
681 ;;(message "** Adding this")
683 (cons (list (cdr assoc) list var)
686 (dolist (map minor-maps)
687 ;;(message "cdr map= %s" (cdr map))
693 (cons (list point-keymap 'point-keymap)
696 ;; Fix-me: compare with current-active-maps
697 (let ((ca-maps (current-active-maps))
701 (while (or ca-maps wh-maps)
702 (setq ca (car ca-maps))
703 (setq wh (car wh-maps))
704 (setq ca-maps (cdr ca-maps))
705 (setq wh-maps (cdr wh-maps))
706 ;;(message "\nca= %s" ca)
707 ;;(message "cdr wh= %s" (cdr wh))
708 (unless (equal ca (car wh))
709 (error "Did not match: %s" (cdr wh)))))
712 (setq map-rec (car keymaps))
713 (setq map (car map-rec))
714 (when (setq binding (lookup-key map key t))
715 (setq map-sym (ourcomments-find-keymap-variables key binding map))
716 (setq map-sym (delq 'map map-sym))
717 (setq map-sym (delq 'local-map map-sym))
718 (setq map-sym (delq 'point-keymap map-sym))
719 (setq map-sym (delq 'point-local-map map-sym))
720 (setq bindings (cons (list binding map-sym (cdr map-rec)) bindings)))
721 (setq keymaps (cdr keymaps)))
723 (nreverse bindings)))
725 (defun describe-keymap-placement (keymap-sym)
726 "Find minor mode keymap KEYMAP-SYM in the keymaps searched for key lookup.
727 See Info node `Searching Keymaps'."
728 ;;(info "(elisp) Searching Keymaps")
729 (interactive (list (ourcomments-read-symbol "Describe minor mode keymap symbol"
732 (keymapp (symbol-value sym)))))))
733 (unless (symbolp keymap-sym)
734 (error "Argument KEYMAP-SYM must be a symbol"))
735 (unless (keymapp (symbol-value keymap-sym))
736 (error "The value of argument KEYMAP-SYM must be a keymap"))
737 (with-output-to-temp-buffer (help-buffer)
738 (help-setup-xref (list #'describe-keymap-placement keymap-sym) (interactive-p))
739 (with-current-buffer (help-buffer)
740 (insert "Placement of keymap `")
741 (insert-text-button (symbol-name keymap-sym)
744 (describe-variable keymap-sym)))
745 (insert "'\nin minor modes activation maps:\n")
747 (dolist (map-root '(emulation-mode-map-alists
748 minor-mode-overriding-map-alist
751 (dolist (emul-alist (symbol-value map-root))
752 ;;(message "emul-alist=%s" emul-alist)
753 (dolist (keymap-alist
754 (if (memq map-root '(emulation-mode-map-alists))
755 (symbol-value emul-alist)
757 (let* ((map (cdr keymap-alist))
759 (map-keymap (lambda (key def)
760 (throw 'first (cons key def)))
764 (keymap-variables (when (and key def)
765 (ourcomments-find-keymap-variables
766 (vector key) def map)))
767 (active-var (car keymap-alist))
769 (assert (keymapp map))
770 ;;(message "keymap-alist=%s, %s" keymap-alist first)
771 ;;(message "active-var=%s, %s" active-var keymap-variables)
772 (when (memq keymap-sym keymap-variables)
774 (insert (format "\n`%s' " map-root))
775 (insert (propertize "<= Minor mode keymap list holding this map"
776 'face 'font-lock-doc-face))
778 (when (symbolp emul-alist)
779 (insert (format " `%s' " emul-alist))
780 (insert (propertize "<= Keymap alist variable" 'face 'font-lock-doc-face))
782 ;;(insert (format " `%s'\n" keymap-alist))
783 (insert (format " `%s' " active-var))
784 (insert (propertize "<= Activation variable" 'face 'font-lock-doc-face))
788 (insert (propertize "Not found." 'face 'font-lock-warning-face)))
791 ;; This is a replacement for describe-key-briefly.
792 ;;(global-set-key [f1 ?c] 'describe-key-and-map-briefly)
794 (defun describe-key-and-map-briefly (&optional key insert untranslated)
795 "Try to print names of keymap from which KEY fetch its definition.
796 Look in current active keymaps and find keymap variables with the
797 same value as the keymap where KEY is bound. Print a message
798 with those keymap variable names. Return a list with the keymap
801 When called interactively prompt for KEY.
803 INSERT and UNTRANSLATED should normall be nil (and I am not sure
804 what they will do ;-)."
805 ;; >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
806 ;; From describe-key-briefly. Keep this as it is for easier update.
808 (let ((enable-disabled-menus-and-buttons t)
809 (cursor-in-echo-area t)
813 ;; If yank-menu is empty, populate it temporarily, so that
814 ;; "Select and Paste" menu can generate a complete event.
815 (when (null (cdr yank-menu))
816 (setq saved-yank-menu (copy-sequence yank-menu))
817 (menu-bar-update-yank-menu "(any string)" nil))
818 (setq key (read-key-sequence "Describe key (or click or menu item): "))
819 ;; If KEY is a down-event, read and discard the
820 ;; corresponding up-event. Note that there are also
821 ;; down-events on scroll bars and mode lines: the actual
822 ;; event then is in the second element of the vector.
824 (let ((last-idx (1- (length key))))
825 (and (eventp (aref key last-idx))
826 (memq 'down (event-modifiers (aref key last-idx)))))
830 (if current-prefix-arg (prefix-numeric-value current-prefix-arg))
833 ;; Put yank-menu back as it was, if we changed it.
834 (when saved-yank-menu
835 (setq yank-menu (copy-sequence saved-yank-menu))
836 (fset 'yank-menu (cons 'keymap yank-menu))))))
837 (if (numberp untranslated)
838 (setq untranslated (this-single-command-raw-keys)))
839 (let* ((event (if (and (symbolp (aref key 0))
841 (consp (aref key 1)))
844 (modifiers (event-modifiers event))
845 (standard-output (if insert (current-buffer) t))
846 (mouse-msg (if (or (memq 'click modifiers) (memq 'down modifiers)
847 (memq 'drag modifiers)) " at that spot" ""))
848 (defn (key-binding key t))
850 ;; Handle the case where we faked an entry in "Select and Paste" menu.
851 (if (and (eq defn nil)
852 (stringp (aref key (1- (length key))))
853 (eq (key-binding (substring key 0 -1)) 'yank-menu))
854 (setq defn 'menu-bar-select-yank))
855 ;; Don't bother user with strings from (e.g.) the select-paste menu.
856 (if (stringp (aref key (1- (length key))))
857 (aset key (1- (length key)) "(any string)"))
858 (if (and (> (length untranslated) 0)
859 (stringp (aref untranslated (1- (length untranslated)))))
860 (aset untranslated (1- (length untranslated)) "(any string)"))
861 ;; Now describe the key, perhaps as changed.
862 (setq key-desc (help-key-description key untranslated))
864 ;; End of part from describe-key-briefly.
865 ;; <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
867 ;;(message "bindings=%s" (key-bindings key)) (sit-for 2)
869 (let* ((maps (current-active-maps))
872 (if (or (null defn) (integerp defn) (equal defn 'undefined))
873 (setq ret 'not-defined)
875 (while (< 1 (length maps))
876 (setq lk (lookup-key (car maps) key t))
877 (when (and lk (not (numberp lk)))
878 (setq ret (ourcomments-find-keymap-variables key lk (car maps)))
880 (throw 'mapped (car maps))))
881 (setq maps (cdr maps))))
883 (setq lk (lookup-key global-map key t))
884 (when (and lk (not (numberp lk)))
885 (setq ret '(global-map)))))
887 ((eq ret 'not-defined)
888 (message "%s%s not defined in any keymap" key-desc mouse-msg))
891 (message "%s%s is bound to `%s', but don't know where"
892 key-desc mouse-msg defn)
893 (if (= 1 (length ret))
894 (message "%s%s is bound to `%s' in `%s'"
895 key-desc mouse-msg defn (car ret))
896 (message "%s%s is bound to `%s' in keymap variables `%s'"
897 key-desc mouse-msg defn ret))))
899 (error "ret=%s" ret)))
902 ;; (ourcomments-find-keymap-variables (current-local-map))
903 ;; (keymapp 'ctl-x-4-prefix)
904 ;; (equal 'ctl-x-4-prefix (current-local-map))
907 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
910 (defvar better-bottom-angles-defaults nil)
911 (defun better-fringes-bottom-angles (on)
912 ;;(bottom bottom-left-angle bottom-right-angle top-right-angle top-left-angle)
914 (when better-bottom-angles-defaults
915 (set-default 'fringe-indicator-alist better-bottom-angles-defaults))
916 (unless better-bottom-angles-defaults
917 (setq better-bottom-angles-defaults fringe-indicator-alist))
920 bottom-right-angle bottom-right-angle
921 bottom-left-angle bottom-left-angle
923 ;;(indicators (copy-list fringe-indicator-alist)))
924 (indicators (copy-sequence fringe-indicator-alist)))
925 (setq indicators (assq-delete-all 'bottom indicators))
926 (set-default 'fringe-indicator-alist (cons better indicators)))))
928 (defun better-fringes-faces (face face-important)
929 (dolist (bitmap '(bottom-left-angle
935 left-arrow right-arrow
936 left-curly-arrow right-curly-arrow
939 left-bracket right-bracket
941 (set-fringe-bitmap-face bitmap face))
942 (dolist (bitmap '(right-triangle
944 (set-fringe-bitmap-face bitmap face-important)))
946 (defface better-fringes-bitmap
947 '((t (:foreground "dark khaki")))
948 "Face for bitmap fringes."
949 :group 'better-fringes
952 (defface better-fringes-important-bitmap
953 '((t (:foreground "red")))
954 "Face for bitmap fringes."
955 :group 'better-fringes
959 (define-minor-mode better-fringes-mode
960 "Choose another fringe bitmap color and bottom angle."
962 :group 'better-fringes
963 (if better-fringes-mode
965 (better-fringes-faces 'better-fringes-bitmap
966 'better-fringes-important-bitmap)
967 (better-fringes-bottom-angles t))
968 (better-fringes-faces nil nil)
969 (better-fringes-bottom-angles nil)))
972 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
975 ;; After an idea from andrea on help-gnu-emacs
977 (defvar ourcomments-copy+paste-point nil)
979 ;;(global-set-key [(control ?c) ?y] 'ourcomments-copy+paste-set-point)
981 (defun ourcomments-copy+paste-set-point ()
982 "Set point for copy+paste here.
983 Enable temporary minor mode `ourcomments-copy+paste-mode'.
984 However if point for copy+paste already is set then cancel it and
985 disable the minor mode.
987 The purpose of this command is to make it easy to grab a piece of
988 text and paste it at current position. After this command you
989 should select a piece of text to copy and then call the command
990 `ourcomments-copy+paste'."
992 (if ourcomments-copy+paste-point
993 (ourcomments-copy+paste-mode -1)
994 (setq ourcomments-copy+paste-point (list (copy-marker (point))
996 (current-frame-configuration)
998 (ourcomments-copy+paste-mode 1)
999 (let ((key (where-is-internal 'ourcomments-copy+paste))
1000 (ckeys (key-description (this-command-keys))))
1001 (setq key (if key (key-description (car key))
1002 "M-x ourcomments-copy+paste"))
1003 (when (> (length ckeys) 12)
1004 (setq ckeys "this command"))
1005 (message "Paste point set; select region and do %s to copy+paste (or cancel with %s)" key ckeys))))
1007 (defvar ourcomments-copy+paste-mode-map
1008 (let ((map (make-sparse-keymap)))
1009 ;; Bind the copy+paste command to C-S-v which reminds of cua-paste
1010 ;; binding and is hopefully not bound.
1011 (define-key map [(control shift ?v)] 'ourcomments-copy+paste)
1014 (define-minor-mode ourcomments-copy+paste-mode
1015 "Temporary mode for copy+paste.
1016 This minor mode is enabled by `ourcomments-copy+paste-set-point'.
1018 When this mode is active there is a key binding for
1019 `ourcomments-copy+paste':
1020 \\<ourcomments-copy+paste-mode-map>
1021 \\[ourcomments-copy+paste]
1023 You should not turn on this minor mode yourself. It is turned on
1024 by `ourcomments-copy+paste-set-point'. For more information see
1026 :lighter " COPY+PASTE"
1028 :group 'ourcomments-util
1029 (if ourcomments-copy+paste-mode
1030 (unless ourcomments-copy+paste-point
1031 (message "Do not call this minor mode, use `ourcomments-copy+paste-set-point'.")
1032 (setq ourcomments-copy+paste-mode nil))
1033 (when ourcomments-copy+paste-point
1034 (setq ourcomments-copy+paste-point nil)
1035 (message "Canceled copy+paste mode"))))
1037 (defvar ourcomments-copy+paste-ovl nil)
1039 (defun ourcomments-copy+paste-cancel-highlight ()
1040 (when (overlayp ourcomments-copy+paste-ovl)
1041 (delete-overlay ourcomments-copy+paste-ovl))
1042 (setq ourcomments-copy+paste-ovl nil))
1044 (defun ourcomments-copy+paste (restore-frames)
1045 "Copy region to copy+paste point set by `ourcomments-copy+paste-set-point'.
1046 Also if prefix argument is given then restore frame configuration
1047 at the time that command was called. Otherwise look for the
1048 buffer for copy+paste point in current frame. If found select
1049 that window. If not then use `switch-to-buffer-other-window' to
1053 ((not ourcomments-copy+paste-point)
1054 (let ((key (where-is-internal 'ourcomments-copy+paste-set-point)))
1055 (setq key (if key (key-description (car key))
1056 "M-x ourcomments-copy+paste-set-point"))
1057 (message "Please select destination of copy+paste first with %s" key)))
1059 (message "Please select a region to copy+paste first"))
1061 ;;(copy-region-as-kill (region-beginning) (region-end))
1062 (clipboard-kill-ring-save (region-beginning) (region-end))
1063 (let* ((marker (nth 0 ourcomments-copy+paste-point))
1064 (orig-win (nth 1 ourcomments-copy+paste-point))
1065 (orig-fcfg (nth 2 ourcomments-copy+paste-point))
1066 (buf (marker-buffer marker))
1067 (win (or (when (window-live-p orig-win) orig-win)
1068 (get-buffer-window buf))))
1069 (message "win=%s, buf=%s" win buf)
1070 (cond (restore-frames
1071 (set-frame-configuration orig-fcfg))
1072 ((and win (eq (window-buffer win) buf))
1073 (select-window win))
1075 (switch-to-buffer-other-window buf)))
1077 (let ((here (point))
1080 (setq ovl (make-overlay here (point)))
1081 (overlay-put ovl 'face 'highlight)
1082 (run-with-idle-timer 2 nil 'ourcomments-copy+paste-cancel-highlight)
1083 (setq ourcomments-copy+paste-ovl ovl))
1084 (setq ourcomments-copy+paste-point nil)
1085 (ourcomments-copy+paste-mode -1))))
1088 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1093 (defun describe-timers ()
1094 "Show timers with readable time format."
1096 (with-output-to-temp-buffer (help-buffer)
1097 (help-setup-xref (list #'ourcommenst-show-timers) (interactive-p))
1098 (with-current-buffer (help-buffer)
1099 (insert (format-time-string "Timers at %Y-%m-%d %H:%M:%S\n\n" (current-time)))
1100 (if (not timer-list)
1104 'face 'font-lock-doc-face))
1105 (dolist (tmr timer-list)
1106 (let* ((hi-sec (timer--high-seconds tmr))
1107 (lo-sec (timer--low-seconds tmr))
1108 (mi-sec (timer--usecs tmr))
1109 (fun (timer--function tmr))
1110 (args (timer--args tmr))
1111 (idle-d (timer--idle-delay tmr))
1112 (rpt-d (timer--repeat-delay tmr))
1113 (time (concat (format-time-string " %Y-%m-%d %H:%M:%S" (list hi-sec lo-sec 0))
1115 (format "%.1f" (/ mi-sec 1000000.0))
1117 (assert (not idle-d) t)
1118 (insert (format "%s %4s (`%-3s' %S)\n" time rpt-d fun args)))))
1119 (insert "\nIdle timers:\n\n")
1120 (if (not timer-idle-list)
1124 'face 'font-lock-doc-face))
1125 (dolist (tmr timer-idle-list)
1126 (let* ((hi-sec (timer--high-seconds tmr))
1127 (lo-sec (timer--low-seconds tmr))
1128 (mi-sec (timer--usecs tmr))
1129 (fun (timer--function tmr))
1130 (args (timer--args tmr))
1131 (idle-d (timer--idle-delay tmr))
1132 (rpt-d (timer--repeat-delay tmr))
1133 (time (+ (* hi-sec 256 256) lo-sec (/ mi-sec 1000000.0)))
1135 (assert (not (not idle-d)) t)
1136 (insert (format " %.2f sec %3s (`%s' %S)\n" time rpt-d fun args))))))))
1138 (defcustom ourcomments-insert-date-and-time "%Y-%m-%d %R"
1139 "Time format for command `ourcomments-insert-date-and-time'.
1140 See `format-time-string'."
1142 :group 'ourcomments-util)
1145 (defun ourcomments-insert-date-and-time ()
1146 "Insert date and time.
1147 See option `ourcomments-insert-date-and-time' for how to
1150 (insert (format-time-string ourcomments-insert-date-and-time)))
1153 (defun find-emacs-other-file (display-file)
1154 "Find corresponding file to source or installed elisp file.
1155 If you have checked out and compiled Emacs yourself you may have
1156 Emacs lisp files in two places, the checked out source tree and
1157 the installed Emacs tree. If buffer contains an Emacs elisp file
1158 in one of these places then find the corresponding elisp file in
1159 the other place. Return the file name of this file.
1161 Rename current buffer using your `uniquify-buffer-name-style' if
1164 When DISPLAY-FILE is non-nil display this file in other window
1165 and go to the same line number as in the current buffer."
1166 (interactive (list t))
1167 (unless (buffer-file-name)
1168 (error "This buffer is not visiting a file"))
1169 (unless source-directory
1170 (error "Can't find the checked out Emacs sources"))
1171 (let* ((installed-directory (file-name-as-directory
1172 (expand-file-name ".." exec-directory)))
1173 (relative-installed (file-relative-name
1174 (buffer-file-name) installed-directory))
1175 (relative-source (file-relative-name
1176 (buffer-file-name) source-directory))
1177 (name-nondir (file-name-nondirectory (buffer-file-name)))
1181 (line-num (save-restriction
1183 (line-number-at-pos))))
1185 ((and relative-installed
1186 (not (string= name-nondir relative-installed))
1187 (not (file-name-absolute-p relative-installed))
1188 (not (string= ".." (substring relative-installed 0 2))))
1189 (setq source-file (expand-file-name relative-installed source-directory)))
1190 ((and relative-source
1191 (not (string= name-nondir relative-source))
1192 (not (file-name-absolute-p relative-source))
1193 (not (string= ".." (substring relative-source 0 2))))
1194 (setq installed-file (expand-file-name relative-source installed-directory))))
1195 (setq other-file (or source-file installed-file))
1197 (error "This file is not in Emacs source or installed lisp tree"))
1198 (unless (file-exists-p other-file)
1199 (error "Can't find the corresponding file %s" other-file))
1201 (when uniquify-buffer-name-style
1202 (rename-buffer (file-name-nondirectory buffer-file-name) t))
1203 (find-file-other-window other-file)
1204 (ourcomments-goto-line line-num))
1208 (defun ourcomments-ediff-files (def-dir file-a file-b)
1209 "In directory DEF-DIR run `ediff-files' on files FILE-A and FILE-B.
1210 The purpose of this function is to make it eaiser to start
1211 `ediff-files' from a shell through Emacs Client.
1213 This is used in EmacsW32 in the file ediff.cmd where Emacs Client
1214 is called like this:
1216 @%emacs_client% -e \"(setq default-directory \\\"%emacs_cd%\\\")\"
1217 @%emacs_client% -n -e \"(ediff-files \\\"%f1%\\\" \\\"%f2%\\\")\"
1219 It can of course be done in a similar way with other shells."
1220 (let ((default-directory def-dir))
1221 (ediff-files file-a file-b)))
1224 (defun ourcomments-latest-changelog ()
1229 "doc/emacs/ChangeLog"
1230 "doc/lispintro/ChangeLog"
1231 "doc/lispref/ChangeLog"
1233 "doc/misc/ChangeLog"
1238 "lisp/erc/ChangeLog"
1239 "lisp/gnus/ChangeLog"
1240 "lisp/mh-e/ChangeLog"
1241 "lisp/org/ChangeLog"
1242 "lisp/url/ChangeLog"
1245 "nextstep/ChangeLog"
1247 "oldXMenu/ChangeLog"
1250 (emacs-root (expand-file-name ".." exec-directory)
1253 (defun ourcomments-read-symbol (prompt predicate)
1254 "Basic function for reading a symbol for describe-* functions.
1255 Prompt with PROMPT and show only symbols satisfying function
1256 PREDICATE. PREDICATE takes one argument, the symbol."
1257 (let* ((symbol (symbol-at-point))
1258 (enable-recursive-minibuffers t)
1263 (funcall predicate symbol))
1265 (setq val (completing-read (if symbol
1267 "%s (default %s): " prompt symbol)
1268 (format "%s: " prompt))
1272 (if symbol (symbol-name symbol))))
1273 (if (equal val "") symbol (intern val))))
1275 (defun ourcomments-command-at-point ()
1276 (let ((fun (function-called-at-point)))
1277 (when (commandp fun)
1281 (defun describe-command (command)
1282 "Like `describe-function', but prompts only for interactive commands."
1284 (let* ((fn (ourcomments-command-at-point))
1286 (format "Describe command (default %s): " fn)
1287 "Describe command: "))
1288 (enable-recursive-minibuffers t)
1290 (setq val (completing-read prompt
1291 obarray 'commandp t nil nil
1292 (and fn (symbol-name fn))))
1293 (list (if (equal val "") fn (intern val)))))
1294 (describe-function command))
1298 (defun buffer-narrowed-p ()
1299 "Return non-nil if the current buffer is narrowed."
1305 (defun narrow-to-comment ()
1307 (let* ((here (point-marker))
1309 (beg (progn (forward-comment (- size))
1310 ;; It looks like the wrong syntax-table is used here:
1311 ;;(message "skipped %s " (skip-chars-forward "[:space:]"))
1312 ;; See Emacs bug 3823, http://debbugs.gnu.org/cgi/bugreport.cgi?bug=3823
1313 (message "skipped %s " (skip-chars-forward " \t\r\n"))
1315 (end (progn (forward-comment size)
1316 ;;(message "skipped %s " (skip-chars-backward "[:space:]"))
1317 (message "skipped %s " (skip-chars-backward " \t\r\n"))
1320 (if (not (and (>= here beg)
1322 (error "Not in a comment")
1323 (narrow-to-region beg end))))
1325 (defvar describe-symbol-alist nil)
1327 (defun describe-symbol-add-known(property description)
1328 (when (assq property describe-symbol-alist)
1329 (error "Already known property"))
1330 (setq describe-symbol-alist
1331 (cons (list property description)
1332 describe-symbol-alist)))
1334 ;;(describe-symbol-add-known 'variable-documentation "Doc for variable")
1335 ;;(describe-symbol-add-known 'cl-struct-slots "defstruct slots")
1337 (defun property-list-keys (plist)
1338 "Return list of key names in property list PLIST."
1341 (setq keys (cons (car plist) keys))
1342 (setq plist (cddr plist)))
1345 (defun ourcomments-symbol-type (symbol)
1346 "Return a list of types where symbol SYMBOL is used.
1347 The can include 'variable, 'function and variaus 'cl-*."
1348 (symbol-file symbol)
1351 (defun ourcomments-defstruct-p (symbol)
1352 "Return non-nil if symbol SYMBOL is a CL defstruct."
1353 (let ((plist (symbol-plist symbol)))
1354 (and (plist-member plist 'cl-struct-slots)
1355 (plist-member plist 'cl-struct-type)
1356 (plist-member plist 'cl-struct-include)
1357 (plist-member plist 'cl-struct-print))))
1359 (defun ourcomments-defstruct-slots (symbol)
1360 (unless (ourcomments-defstruct-p symbol)
1361 (error "Not a CL defstruct symbol: %s" symbol))
1362 (let ((cl-struct-slots (get symbol 'cl-struct-slots)))
1364 (loop for rec in cl-struct-slots
1365 collect (nth 0 rec)))))
1367 ;; (ourcomments-defstruct-slots 'ert-test)
1369 (defun ourcomments-defstruct-file (symbol)
1370 (unless (ourcomments-defstruct-p symbol)
1371 (error "Not a CL defstruct symbol: %s" symbol))
1374 (defun ourcomments-member-defstruct (symbol)
1375 "Return defstruct name if member."
1376 (when (and (functionp symbol)
1377 (plist-member (symbol-plist symbol) 'cl-compiler-macro))
1379 (symbol-file (symbol-file symbol))
1383 (error "Can't check if defstruct member since don't know symbol file"))
1384 (setq buf (find-buffer-visiting symbol-file))
1385 (setq was-here (with-current-buffer buf (point)))
1387 (setq buf (find-file-noselect symbol-file)))
1388 (with-current-buffer buf
1391 (let* ((buf-point (find-definition-noselect symbol nil)))
1392 (goto-char (cdr buf-point))
1394 (when (looking-at "(defstruct (?\\(\\(?:\\sw\\|\\s_\\)+\\)")
1395 (setq in-defstruct (match-string-no-properties 1))))))
1397 (goto-char was-here)
1398 (kill-buffer (current-buffer))))
1400 ;; (ourcomments-member-defstruct 'ert-test-name)
1401 ;; (ourcomments-member-defstruct 'ert-test-error-condition)
1403 (defun ourcomments-custom-group-p (symbol)
1404 (and (intern-soft symbol)
1405 (or (and (get symbol 'custom-loads)
1406 (not (get symbol 'custom-autoload)))
1407 (get symbol 'custom-group))))
1410 (defun describe-custom-group (symbol)
1411 "Describe customization group SYMBOL."
1414 (ourcomments-read-symbol "Customization group"
1415 'ourcomments-custom-group-p)))
1417 (message "g=%s" symbol))
1420 ;; Added this to current-load-list in cl-macs.el
1421 ;; (describe-defstruct 'ert-stats)
1423 (defun describe-defstruct (symbol)
1424 (interactive (list (ourcomments-read-symbol "Describe defstruct"
1425 'ourcomments-defstruct-p)))
1426 (if (not (ourcomments-defstruct-p symbol))
1427 (message "%s is not a CL defstruct." symbol)
1428 (with-output-to-temp-buffer (help-buffer)
1429 (help-setup-xref (list #'describe-defstruct symbol) (interactive-p))
1430 (with-current-buffer (help-buffer)
1431 (insert "This is a description of a CL thing.")
1433 (insert (format "%s is a CL `defstruct'" symbol))
1434 (let ((file (symbol-file symbol)))
1436 ;; Fix-me: .elc => .el
1437 (let ((name (file-name-nondirectory file)))
1438 (insert "defined in file %s.\n" (file-name-nondirectory file)))
1440 (insert "\n\nIt has the following slot functions:\n")
1441 (let ((num-slot-funs 0)
1442 (slots (ourcomments-defstruct-slots symbol)))
1443 (dolist (slot slots)
1444 (if (not (fboundp (intern-soft (format "%s-%s" symbol slot))))
1445 (insert (format " Do not know function for slot %s\n" slot))
1446 (setq num-slot-funs (1+ num-slot-funs))
1447 (insert (format " `%s-%s'\n" symbol slot))))
1448 (unless (= num-slot-funs (length slots))
1449 (insert " No information about some slots, maybe :conc-name was used\n")))))))
1451 ;;(defun describe-deftype (type)
1453 (defun describe-symbol(symbol)
1454 "Show information about SYMBOL.
1455 Show SYMBOL plist and whether is is a variable or/and a
1457 (interactive (list (ourcomments-read-symbol "Describe symbol" nil)))
1458 ;;; (let* ((s (symbol-at-point))
1459 ;;; (val (completing-read (if (and (symbolp s)
1460 ;;; (not (eq s nil)))
1462 ;;; "Describe symbol (default %s): " s)
1463 ;;; "Describe symbol: ")
1467 ;;; (if (symbolp s) (symbol-name s)))))
1468 ;;; (list (if (equal val "") s (intern val)))))
1470 (with-output-to-temp-buffer (help-buffer)
1471 (help-setup-xref (list #'describe-symbol symbol) (interactive-p))
1472 (with-current-buffer (help-buffer)
1473 (insert (format "Description of symbol %s\n\n" symbol))
1474 (when (plist-get (symbol-plist symbol) 'cl-compiler-macro)
1475 (insert "(Looks like a CL thing.)\n"))
1477 (insert (format "- There is a variable `%s'.\n" symbol))
1478 (insert "- This symbol is not a variable.\n"))
1479 (if (fboundp symbol)
1481 (insert (format "- There is a function `%s'" symbol))
1482 (when (ourcomments-member-defstruct symbol)
1483 (let ((ds-name (ourcomments-member-defstruct symbol)))
1484 (insert "\n which is a member of defstruct ")
1485 (insert-text-button (format "%s" ds-name)
1486 'symbol (intern-soft ds-name)
1487 'action (lambda (button)
1489 (button-get button 'symbol))))))
1491 (insert "- This symbol is not a function.\n"))
1493 (insert (format "- There is a face `%s'.\n" symbol))
1494 (insert "- This symbol is not a face.\n"))
1495 (if (ourcomments-custom-group-p symbol)
1497 (insert "- There is a customization group ")
1498 (insert-text-button (format "%s" symbol)
1500 'action (lambda (button)
1501 (describe-custom-group
1502 (button-get button 'symbol))))
1504 (insert "- This symbol is not a customization group.\n"))
1505 (if (ourcomments-defstruct-p symbol)
1507 (insert (format "- There is a CL defstruct %s with setf-able slots:\n" symbol))
1508 (let ((num-slot-funs 0)
1509 (slots (ourcomments-defstruct-slots symbol)))
1510 (dolist (slot slots)
1511 (if (not (fboundp (intern-soft (format "%s-%s" symbol slot))))
1512 (insert (format " Do not know function for slot %s\n" slot))
1513 (setq num-slot-funs (1+ num-slot-funs))
1514 (insert (format " `%s-%s'\n" symbol slot))))
1515 (unless (= num-slot-funs (length slots))
1516 (insert " No information about some slots, maybe :conc-name was used\n"))))
1517 (insert "- This symbol is not a CL defstruct.\n"))
1519 (let* ((pl (symbol-plist symbol))
1520 (pl-not-known (property-list-keys pl))
1523 (insert (format "Symbol %s has no property list\n\n" symbol))
1525 (dolist (rec describe-symbol-alist)
1526 (let ((prop (nth 0 rec))
1528 (when (plist-member pl prop)
1529 (setq any-known (cons prop any-known))
1530 (setq pl-not-known (delq prop pl-not-known))
1532 "The following keys in the property list are known:\n\n")
1533 (insert (format "* %s: %s\n" prop desc))
1536 (insert "The are no known keys in the property list.\n"))
1537 (let ((pl (ourcomments-format-plist pl "\n ")))
1538 ;;(insert (format "plist=%s\n" (symbol-plist symbol)))
1539 ;;(insert (format "pl-not-known=%s\n" pl-not-known))
1540 (insert "\nFull property list:\n\n (")
1541 (insert (propertize pl 'face 'default))
1542 (insert ")\n\n")))))))
1544 (defun ourcomments-format-plist (pl sep &optional compare)
1546 (setq pl (symbol-plist pl)))
1549 (setq p (format "%s" (car pl)))
1550 (if (or (not compare) (string-match apropos-regexp p))
1551 (if apropos-property-face
1552 (put-text-property 0 (length (symbol-name (car pl)))
1553 'face apropos-property-face p))
1557 (and compare apropos-match-face
1558 (put-text-property (match-beginning 0) (match-end 0)
1559 'face apropos-match-face
1561 (setq desc (pp-to-string (nth 1 pl)))
1562 (setq desc (split-string desc "\n"))
1563 (if (= 1 (length desc))
1564 (setq desc (concat " " (car desc)))
1566 (ind-nl (concat "\n" indent)))
1570 (mapconcat 'identity desc ind-nl)))))
1571 (setq p-out (concat p-out (if p-out sep) p desc))))
1572 (setq pl (nthcdr 2 pl)))
1575 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1578 (defvar ourcomments-ido-visit-method nil)
1581 (defun ourcomments-ido-buffer-other-window ()
1582 "Show buffer in other window."
1584 (setq ourcomments-ido-visit-method 'other-window)
1585 (call-interactively 'ido-exit-minibuffer))
1588 (defun ourcomments-ido-buffer-other-frame ()
1589 "Show buffer in other frame."
1591 (setq ourcomments-ido-visit-method 'other-frame)
1592 (call-interactively 'ido-exit-minibuffer))
1595 (defun ourcomments-ido-buffer-raise-frame ()
1596 "Raise frame showing buffer."
1598 (setq ourcomments-ido-visit-method 'raise-frame)
1599 (call-interactively 'ido-exit-minibuffer))
1601 (defun ourcomments-ido-switch-buffer-or-next-entry ()
1603 (if (active-minibuffer-window)
1605 (ido-switch-buffer)))
1607 (defun ourcomments-ido-mode-advice()
1608 (when (memq ido-mode '(both buffer))
1609 (let ((the-ido-minor-map (cdr ido-minor-mode-map-entry)))
1610 ;;(define-key the-ido-minor-map [(control tab)] 'ido-switch-buffer))
1611 (define-key the-ido-minor-map [(control tab)] 'ourcomments-ido-switch-buffer-or-next-entry))
1612 (dolist (the-map (list ido-buffer-completion-map ido-completion-map ido-common-completion-map))
1614 (let ((map the-map))
1615 (define-key map [(control tab)] 'ido-next-match)
1616 (define-key map [(control shift tab)] 'ido-prev-match)
1617 (define-key map [(control backtab)] 'ido-prev-match)
1618 (define-key map [(shift return)] 'ourcomments-ido-buffer-other-window)
1619 (define-key map [(control return)] 'ourcomments-ido-buffer-other-frame)
1620 (define-key map [(meta return)] 'ourcomments-ido-buffer-raise-frame))))))
1622 ;; (defun ourcomments-ido-setup-completion-map ()
1623 ;; "Set up the keymap for `ido'."
1625 ;; (ourcomments-ido-mode-advice)
1627 ;; ;; generated every time so that it can inherit new functions.
1628 ;; (let ((map (make-sparse-keymap))
1629 ;; (viper-p (if (boundp 'viper-mode) viper-mode)))
1632 ;; (define-key map [remap viper-intercept-ESC-key] 'ignore))
1635 ;; ((memq ido-cur-item '(file dir))
1636 ;; (when ido-context-switch-command
1637 ;; (define-key map "\C-x\C-b" ido-context-switch-command)
1638 ;; (define-key map "\C-x\C-d" 'ignore))
1640 ;; (define-key map [remap viper-backward-char] 'ido-delete-backward-updir)
1641 ;; (define-key map [remap viper-del-backward-char-in-insert] 'ido-delete-backward-updir)
1642 ;; (define-key map [remap viper-delete-backward-word] 'ido-delete-backward-word-updir))
1643 ;; (set-keymap-parent map
1644 ;; (if (eq ido-cur-item 'file)
1645 ;; ido-file-completion-map
1646 ;; ido-file-dir-completion-map)))
1648 ;; ((eq ido-cur-item 'buffer)
1649 ;; (when ido-context-switch-command
1650 ;; (define-key map "\C-x\C-f" ido-context-switch-command))
1651 ;; (set-keymap-parent map ido-buffer-completion-map))
1654 ;; (set-keymap-parent map ido-common-completion-map)))
1657 ;; (define-key map [(control tab)] 'ido-next-match)
1658 ;; (define-key map [(control shift tab)] 'ido-prev-match)
1659 ;; (define-key map [(control backtab)] 'ido-prev-match)
1660 ;; (define-key map [(shift return)] 'ourcomments-ido-buffer-other-window)
1661 ;; (define-key map [(control return)] 'ourcomments-ido-buffer-other-frame)
1662 ;; (define-key map [(meta return)] 'ourcomments-ido-buffer-raise-frame)
1664 ;; (setq ido-completion-map map)))
1666 ;; (defadvice ido-setup-completion-map (around
1667 ;; ourcomments-advice-ido-setup-completion-map
1669 ;; (setq ad-return-value (ourcomments-ido-setup-completion-map))
1672 ;;(add-hook 'ido-setup-hook 'ourcomments-ido-mode-advice)
1673 ;;(remove-hook 'ido-setup-hook 'ourcomments-ido-mode-advice)
1674 (defvar ourcomments-ido-adviced nil)
1675 (unless ourcomments-ido-adviced
1676 (defadvice ido-mode (after
1677 ourcomments-advice-ido-mode
1681 "Add C-tab to ido buffer completion."
1682 (ourcomments-ido-mode-advice)
1685 ;; (ad-activate 'ido-mode)
1686 ;; (ad-deactivate 'ido-mode)
1688 (defadvice ido-visit-buffer (before
1689 ourcomments-advice-ido-visit-buffer
1693 "Advice to show buffers in other window, frame etc."
1694 (when ourcomments-ido-visit-method
1695 (ad-set-arg 1 ourcomments-ido-visit-method)
1696 (setq ourcomments-ido-visit-method nil)
1698 (setq ourcomments-ido-adviced t)
1701 ;;(message "after advising ido")
1702 ;;(ad-deactivate 'ido-visit-buffer)
1703 ;;(ad-activate 'ido-visit-buffer)
1705 (defvar ourcomments-ido-old-state ido-mode)
1707 (defun ourcomments-ido-ctrl-tab-activate ()
1708 ;;(message "ourcomments-ido-ctrl-tab-activate running")
1709 ;;(ad-update 'ido-visit-buffer)
1710 ;;(unless (ad-get-advice-info 'ido-visit-buffer)
1711 ;; Fix-me: The advice must be enabled before activation. Send bug report.
1712 (ad-enable-advice 'ido-visit-buffer 'before 'ourcomments-advice-ido-visit-buffer)
1713 (unless (cdr (assoc 'active (ad-get-advice-info 'ido-visit-buffer)))
1714 (ad-activate 'ido-visit-buffer))
1715 ;; (ad-enable-advice 'ido-setup-completion-map 'around 'ourcomments-advice-ido-setup-completion-map)
1716 ;; (unless (cdr (assoc 'active (ad-get-advice-info 'ido-setup-completion-map)))
1717 ;; (ad-activate 'ido-setup-completion-map))
1718 ;;(ad-update 'ido-mode)
1719 (ad-enable-advice 'ido-mode 'after 'ourcomments-advice-ido-mode)
1720 (unless (cdr (assoc 'active (ad-get-advice-info 'ido-mode)))
1721 (ad-activate 'ido-mode))
1722 (setq ourcomments-ido-old-state ido-mode)
1723 (ido-mode (or ido-mode 'buffer)))
1726 (define-minor-mode ourcomments-ido-ctrl-tab
1727 "Enable buffer switching using C-Tab with function `ido-mode'.
1728 This changes buffer switching with function `ido-mode' the
1731 - You can use C-Tab.
1733 - You can show the selected buffer in three ways independent of
1734 how you entered function `ido-mode' buffer switching:
1736 * S-return: other window
1737 * C-return: other frame
1738 * M-return: raise frame
1740 Those keys are selected to at least be a little bit reminiscent
1741 of those in for example common web browsers."
1745 (if ourcomments-ido-ctrl-tab
1746 (ourcomments-ido-ctrl-tab-activate)
1747 (ad-disable-advice 'ido-visit-buffer 'before
1748 'ourcomments-advice-ido-visit-buffer)
1749 (ad-disable-advice 'ido-mode 'after
1750 'ourcomments-advice-ido-mode)
1751 ;; For some reason this little complicated construct is
1752 ;; needed. If they are not there the defadvice
1754 ;;(if ourcomments-ido-old-state
1755 ;; (ido-mode ourcomments-ido-old-state)
1756 ;; (when ido-mode (ido-mode -1)))
1759 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1760 ;;;; New Emacs instance
1762 (defun ourcomments-find-emacs ()
1763 (locate-file invocation-name
1764 (list invocation-directory)
1766 ;; 1 ;; Fix-me: This parameter is depreceated, but used
1767 ;; in executable-find, why?
1770 (defvar ourcomments-restart-server-mode nil)
1772 (defun emacs-restart-in-kill ()
1773 "Last step in restart Emacs and start `server-mode' if on before."
1774 (let* ((restart-args (when ourcomments-restart-server-mode
1775 ;; Delay 3+2 sec to be sure the old server has stopped.
1776 (list "--eval=(run-with-idle-timer 5 nil 'server-mode 1)")))
1777 ;; Fix-me: There is an Emacs bug here, default-directory shows
1778 ;; up in load-path in the new Eamcs if restart-args is like
1779 ;; this, but not otherwise. And it has w32 file syntax. The
1780 ;; work around below is the best I can find at the moment.
1781 (first-path (catch 'first
1782 (dolist (p load-path)
1783 (when (file-directory-p p)
1784 (throw 'first p)))))
1785 (default-directory (file-name-as-directory (expand-file-name first-path))))
1786 ;; Fix-me: Adding -nw to restart in console does not work. Any way to fix it?
1787 (unless window-system (setq restart-args (cons "-nw" restart-args)))
1788 ;;(apply 'call-process (ourcomments-find-emacs) nil 0 nil restart-args)
1789 (apply 'emacs restart-args)
1790 ;; Wait to give focus to new Emacs instance:
1794 (defun emacs-restart ()
1795 "Restart Emacs and start `server-mode' if on before."
1797 (if (not window-system)
1798 (message "Can't restart emacs if window-system is nil")
1800 (while (> (setq wait (1- wait)) 0)
1801 (message (propertize (format "Will restart Emacs in %d seconds..." wait)
1802 'face 'secondary-selection))
1804 (setq ourcomments-restart-server-mode server-mode)
1805 (add-hook 'kill-emacs-hook 'emacs-restart-in-kill t)
1806 (save-buffers-kill-emacs)))
1808 (defvar ourcomments-started-emacs-use-output-buffer nil
1809 "If non-nil then save output form `emacs'.
1810 Set this to `t' to debug problems with starting a new Emacs.
1812 If non-nil save output to buffer 'call-process emacs output'.
1813 Note that this will lock the Emacs calling `emacs' until the new
1814 Emacs has finished.")
1815 ;;(setq ourcomments-started-emacs-use-output-buffer t)
1816 ;;(defun my-test () (interactive) (emacs-Q "-bad-arg"))
1819 (defun emacs (&rest args)
1820 "Start a new Emacs with default parameters.
1821 Additional ARGS are passed to the new Emacs.
1823 See also `ourcomments-started-emacs-use-output-buffer'."
1826 (let* ((out-buf (when ourcomments-started-emacs-use-output-buffer
1827 (get-buffer-create "call-process emacs output")))
1828 (buf-arg (or out-buf 0))
1829 (args-text (mapconcat 'identity (cons "" args) " "))
1833 (display-buffer out-buf)
1834 (setq fin-msg ". Finished.")
1835 (message "Started 'emacs%s' => %s. Locked until this is finished." args-text ret fin-msg)
1837 (setq ret (apply 'call-process (ourcomments-find-emacs) nil buf-arg nil args))
1838 (message "Started 'emacs%s' => %s%s" args-text ret fin-msg)
1842 (defun emacs-buffer-file()
1843 "Start a new Emacs showing current buffer file.
1844 Go to the current line and column in that file.
1845 If there is no buffer file then instead start with `dired'.
1847 This calls the function `emacs' with argument --no-desktop and
1848 the file or a call to dired."
1851 (let ((file (buffer-file-name))
1852 (lin (line-number-at-pos))
1853 (col (current-column)))
1855 (apply 'emacs "--no-desktop" (format "+%d:%d" lin col) file nil)
1856 (applay 'emacs "--no-desktop" "--eval" (format "(dired \"%s\")" default-directory nil)))))
1859 (defun emacs--debug-init(&rest args)
1860 "Start a new Emacs with --debug-init parameter.
1861 This calls the function `emacs' with added arguments ARGS."
1863 (apply 'emacs "--debug-init" args))
1866 (defun emacs--no-desktop (&rest args)
1867 "Start a new Emacs with --no-desktop parameter.
1868 This calls the function `emacs' with added arguments ARGS."
1870 (apply 'emacs "--no-desktop" args))
1873 (defun emacs-Q (&rest args)
1874 "Start a new Emacs with -Q parameter.
1875 Start new Emacs without any customization whatsoever.
1876 This calls the function `emacs' with added arguments ARGS."
1878 (apply 'emacs "-Q" args))
1881 (defun emacs-Q-nxhtml(&rest args)
1882 "Start new Emacs with -Q and load nXhtml.
1883 This calls the function `emacs' with added arguments ARGS."
1885 (let ((autostart (if (boundp 'nxhtml-install-dir)
1886 (expand-file-name "autostart.el" nxhtml-install-dir)
1887 (expand-file-name "../../EmacsW32/nxhtml/autostart.el"
1889 (apply 'emacs-Q "--debug-init" "--load" autostart args)))
1892 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1895 (defun grep-get-buffer-files ()
1896 "Return list of files in a `grep-mode' buffer."
1897 (or (and (compilation-buffer-p (current-buffer))
1898 (derived-mode-p 'grep-mode))
1899 (error "Not in a grep buffer"))
1900 (let ((here (point))
1903 (font-lock-fontify-buffer)
1904 (goto-char (point-min))
1907 (compilation-next-error 1)
1909 ;; This should be the end, but give a message for
1910 ;; easier debugging.
1913 ;;(message "here =%s, loc=%s" (point) loc)
1914 (let ((file (caar (nth 2 (car loc)))))
1915 (setq file (expand-file-name file))
1916 (add-to-list 'files file)))
1918 ;;(message "files=%s" files)
1921 (defvar grep-query-replace-defaults nil
1922 "Default values of FROM-STRING and TO-STRING for `grep-query-replace'.
1923 This is a cons cell (FROM-STRING . TO-STRING), or nil if there is
1926 ;; Mostly copied from `dired-do-query-replace-regexp'. Fix-me: finish, test
1928 (defun grep-query-replace(from to &optional delimited)
1929 "Do `query-replace-regexp' of FROM with TO, on all files in *grep*.
1930 Third arg DELIMITED (prefix arg) means replace only word-delimited matches.
1931 If you exit (\\[keyboard-quit], RET or q), you can resume the query replace
1932 with the command \\[tags-loop-continue]."
1935 ;; Use the regexps that have been used in grep
1936 (let ((query-replace-from-history-variable 'grep-regexp-history)
1937 (query-replace-defaults (or grep-query-replace-defaults
1938 query-replace-defaults)))
1939 (query-replace-read-args
1940 "Query replace regexp in files in *grep*" t t))))
1941 (setq grep-query-replace-defaults (cons (nth 0 common)
1943 (list (nth 0 common) (nth 1 common) (nth 2 common))))
1944 (dolist (file (grep-get-buffer-files))
1945 (let ((buffer (get-file-buffer file)))
1946 (if (and buffer (with-current-buffer buffer
1948 (error "File `%s' is visited read-only" file))))
1949 (tags-query-replace from to delimited
1950 '(grep-get-buffer-files)))
1953 (defun ldir-query-replace (from to files dir &optional delimited)
1954 "Replace FROM with TO in FILES in directory DIR.
1955 This runs `query-replace-regexp' in files matching FILES in
1958 See `tags-query-replace' for DELIMETED and more information."
1959 (interactive (dir-replace-read-parameters nil nil))
1960 (message "%s" (list from to files dir delimited))
1961 ;;(let ((files (directory-files root nil file-regexp))) (message "files=%s" files))
1962 (tags-query-replace from to delimited
1963 `(directory-files ,dir t ,files)))
1966 (defun rdir-query-replace (from to file-regexp root &optional delimited)
1967 "Replace FROM with TO in FILES in directory tree ROOT.
1968 This runs `query-replace-regexp' in files matching FILES in
1969 directory tree ROOT.
1971 See `tags-query-replace' for DELIMETED and more information."
1972 (interactive (dir-replace-read-parameters nil t))
1973 (message "%s" (list from to file-regexp root delimited))
1974 ;;(let ((files (directory-files root nil file-regexp))) (message "files=%s" files))
1975 (tags-query-replace from to delimited
1976 `(rdir-get-files ,root ,file-regexp)))
1978 ;; (rdir-get-files ".." "^a.*\.el$")
1979 (defun rdir-get-files (root file-regexp)
1980 (let ((files (directory-files root t file-regexp))
1981 (subdirs (directory-files root t)))
1982 (dolist (subdir subdirs)
1983 (when (and (file-directory-p subdir)
1984 (not (or (string= "/." (substring subdir -2))
1985 (string= "/.." (substring subdir -3)))))
1986 (setq files (append files (rdir-get-files subdir file-regexp) nil))))
1989 (defun dir-replace-read-parameters (has-dir recursive)
1991 (let (;;(query-replace-from-history-variable 'grep-regexp-history)
1992 ;;(query-replace-defaults (or grep-query-replace-defaults
1993 ;; query-replace-defaults))
1995 (query-replace-read-args
1996 "Query replace regexp in files" t t)))
1997 (from (nth 0 common))
1999 (delimited (nth 2 common))
2000 (files (replace-read-files from to))
2001 (root (unless has-dir (read-directory-name (if recursive "Root directory: "
2002 "In single directory: ")))))
2003 (list from to files root delimited)))
2005 ;; Mostly copied from `grep-read-files'. Could possible be merged with
2007 (defvar replace-read-files-history nil)
2009 (defun replace-read-files (regexp &optional replace)
2010 "Read files arg for replace."
2011 (let* ((bn (or (buffer-file-name) (buffer-name)))
2014 (file-name-nondirectory bn)))
2018 (let ((aliases grep-files-aliases)
2021 (setq alias (car aliases)
2022 aliases (cdr aliases))
2023 (if (string-match (wildcard-to-regexp
2029 (let ((ext (file-name-extension fn)))
2030 (and ext (concat "^.*\." ext))))
2031 (car replace-read-files-history)
2032 (car (car grep-files-aliases)))))
2033 (if (string-match-p "^\\*\\.[a-zA-Z0-9]*$" pre-default)
2034 (concat "\\." (substring pre-default 2) "$")
2038 (concat "Replace \"" regexp
2039 "\" with \"" replace "\" in files"
2040 (if default (concat " (default " default
2041 ", regexp or *.EXT)"))
2043 (concat "Search for \"" regexp
2045 (if default (concat " (default " default ")"))
2047 nil 'replace-read-files-history default)))
2048 (let ((pattern (and files
2049 (or (cdr (assoc files grep-files-aliases))
2052 (string-match-p "^\\*\\.[a-zA-Z0-9]*$" pattern))
2053 (concat "\\." (substring pattern 2) "$")
2056 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2060 (defun info-open-file (info-file)
2061 "Open an info file in `Info-mode'."
2063 (let ((name (read-file-name "Info file: "
2065 nil ;; default-filename
2070 (or (file-directory-p file)
2071 (string-match ".*\\.info\\'" file))))))
2075 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2078 (defun ourcomments-which (prog)
2079 "Look for first program PROG in `exec-path' using `exec-suffixes'.
2080 Return full path if found."
2081 (interactive "sProgram: ")
2082 (let ((path (executable-find prog)))
2083 (when (with-no-warnings (called-interactively-p))
2084 (message "%s found in %s" prog path))
2087 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2088 ;;;; Custom faces and keys
2091 (defun use-custom-style ()
2092 "Setup like in `Custom-mode', but without things specific to Custom."
2093 (make-local-variable 'widget-documentation-face)
2094 (setq widget-documentation-face 'custom-documentation)
2095 (make-local-variable 'widget-button-face)
2096 (setq widget-button-face custom-button)
2097 (setq show-trailing-whitespace nil)
2099 ;; We need this because of the "More" button on docstrings.
2100 ;; Otherwise clicking on "More" can push point offscreen, which
2101 ;; causes the window to recenter on point, which pushes the
2102 ;; newly-revealed docstring offscreen; which is annoying. -- cyd.
2103 (set (make-local-variable 'widget-button-click-moves-point) t)
2105 (set (make-local-variable 'widget-button-pressed-face) custom-button-pressed)
2106 (set (make-local-variable 'widget-mouse-face) custom-button-mouse)
2108 ;; When possible, use relief for buttons, not bracketing. This test
2109 ;; may not be optimal.
2110 (when custom-raised-buttons
2111 (set (make-local-variable 'widget-push-button-prefix) "")
2112 (set (make-local-variable 'widget-push-button-suffix) "")
2113 (set (make-local-variable 'widget-link-prefix) "")
2114 (set (make-local-variable 'widget-link-suffix) ""))
2116 ;; From widget-keymap
2117 (local-set-key "\t" 'widget-forward)
2118 (local-set-key "\e\t" 'widget-backward)
2119 (local-set-key [(shift tab)] 'advertised-widget-backward)
2120 (local-set-key [backtab] 'widget-backward)
2121 (local-set-key [down-mouse-2] 'widget-button-click)
2122 (local-set-key [down-mouse-1] 'widget-button-click)
2123 (local-set-key [(control ?m)] 'widget-button-press)
2124 ;; From custom-mode-map
2125 (local-set-key " " 'scroll-up)
2126 (local-set-key "\177" 'scroll-down)
2127 (local-set-key "n" 'widget-forward)
2128 (local-set-key "p" 'widget-backward))
2130 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2133 (defun bookmark-next-marked ()
2135 (let ((bb (get-buffer "*Bookmark List*"))
2138 (with-current-buffer bb
2139 (setq pos (re-search-forward "^>" nil t))
2141 (goto-char (point-min))
2142 (setq pos (re-search-forward "^>" nil t)))))
2144 (with-current-buffer bb
2145 ;; Defined in bookmark.el, should be loaded now.
2146 (bookmark-bmenu-this-window))
2147 (call-interactively 'bookmark-bmenu-list)
2148 (message "Please select bookmark for bookmark next command, then press n"))))
2150 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2153 (defun ourcomments-org-complete-and-replace-file-link ()
2154 "If on a org file link complete file name and replace it."
2157 (let* ((here (point-marker))
2158 (on-link (eq 'org-link (get-text-property (point) 'face)))
2159 (link-beg (when on-link
2160 (previous-single-property-change (1+ here) 'face)))
2161 (link-end (when on-link
2162 (next-single-property-change here 'face)))
2163 (link (when on-link (buffer-substring-no-properties link-beg link-end)))
2172 (string-match (rx string-start "[["
2173 (group (0+ (not (any "]"))))) link))
2174 (setq type+link (match-string 1 link))
2175 (when (string-match "^file:\\(.*\\)" type+link)
2176 (setq link-link (match-string 1 type+link))
2177 (setq link-link-beg (+ 2 link-beg (match-beginning 1)))
2178 (setq link-link-end (+ 2 link-beg (match-end 1)))
2181 (setq ovl (make-overlay link-link-beg link-link-end))
2182 (overlay-put ovl 'face 'highlight)
2184 (setq link-link (org-link-unescape link-link))
2185 (setq dir (when (and link-link (> (length link-link) 0))
2186 (file-name-directory link-link)))
2187 (setq new-link (read-file-name "Org file:" dir nil nil (file-name-nondirectory link-link)))
2188 (delete-overlay ovl)
2189 (setq new-link (expand-file-name new-link))
2190 (setq new-link (file-relative-name new-link))
2191 (delete-region link-link-beg link-link-end)
2192 (goto-char link-link-beg)
2193 (insert (org-link-escape new-link))
2195 (delete-overlay ovl)
2196 (goto-char here))))))
2198 ;; (defun ourcomments-org-paste-html-link (html-link)
2199 ;; "If there is an html link on clipboard paste it as an org link.
2200 ;; If you have this on the clipboard
2201 ;; <a href=\"http://my.site.org/\">My Site</a>
2202 ;; It will paste this
2203 ;; [[http://my.site.org/][My Site]]
2204 ;; If the URL is to a local file it will create an org link to the
2206 ;; Tip: You can use the Firefox plugin Copy as HTML Link, see URL
2207 ;; `https://addons.mozilla.org/en-US/firefox/addon/2617'.
2209 ;; (interactive (list (current-kill 0)))
2210 ;; (let ((conv-link (ourcomments-org-convert-html-link html-link)))
2211 ;; (if (not conv-link)
2212 ;; (message (propertize "No html link on clipboard" 'face 'font-lock-warning-face))
2213 ;; (insert conv-link))))
2215 ;; (defun ourcomments-org-convert-html-link (html-link)
2216 ;; (let (converted url str)
2218 ;; (while (string-match ourcomments-org-paste-html-link-regexp html-link)
2219 ;; (setq converted t)
2220 ;; (setq url (match-string 1 html-link))
2221 ;; (setq str (match-string 2 html-link))
2222 ;; ;;(setq str (concat str (format "%s" (setq temp-n (1+ temp-n)))))
2223 ;; (setq html-link (replace-match (concat "[[" url "][" str "]]") nil nil html-link 0))))
2227 (defconst ourcomments-org-paste-html-link-regexp
2228 "\\`\\(?:<a [^>]*?href=\"\\(.*?\\)\"[^>]*?>\\([^<]*\\)</a>\\)\\'")
2230 ;;(string-match-p ourcomments-org-paste-html-link-regexp "<a href=\"link\">text</a>")
2233 (defun ourcomments-org-convert-html-links-in-buffer (beg end)
2234 "Convert html link between BEG and END to org mode links.
2235 If there is an html link in the buffer
2237 <a href=\"http://my.site.org/\">My Site</a>
2239 that starts at BEG and ends at END then convert it to this
2241 [[http://my.site.org/][My Site]]
2243 If the URL is to a local file and the buffer is visiting a file
2244 make the link relative.
2246 However, if the html link is inside an #+BEGIN - #+END block or a
2247 variant of such blocks then leave the link as it is."
2248 (when (derived-mode-p 'org-mode)
2250 (let ((here (copy-marker (point)))
2256 (setq lit-beg (search-backward "#+BEGIN" nil t))
2259 (setq lit-end (or (search-forward "#+END" nil t)
2261 (when (or (not lit-beg)
2264 (when (save-restriction
2265 (narrow-to-region beg end)
2266 (looking-at ourcomments-org-paste-html-link-regexp))
2268 (setq url (match-string-no-properties 1))
2269 (setq str (match-string-no-properties 2))
2270 ;; Check if the URL is to a local file and absolute. And we
2272 (when (and (buffer-file-name)
2274 (string= (substring url 0 6) "file:/"))
2276 (if (not (memq system-type '(windows-nt ms-dos)))
2278 (if (string= (substring url 0 8) "file:///")
2280 ;; file://c:/some/where.txt
2281 (substring url 7)))))
2282 (setq url (concat "file:"
2283 (file-relative-name abs-file-url
2284 (file-name-directory
2285 (buffer-file-name)))))))
2286 (replace-match (concat "[[" url "][" str "]]") nil nil nil 0)))
2290 (defvar ourcomments-paste-with-convert-hook nil
2291 "Normal hook run after certain paste commands.
2292 These paste commands are in the list
2293 `ourcomments-paste-with-convert-commands'.
2295 Each function in this hook is called with two parameters, the
2296 start and end of the pasted text, until a function returns
2298 (add-hook 'ourcomments-paste-with-convert-hook 'ourcomments-org-convert-html-links-in-buffer)
2300 (defvar ourcomments-paste-beg) ;; dyn var
2301 (defvar ourcomments-paste-end) ;; dyn var
2302 (defun ourcomments-grab-paste-bounds (beg end len)
2303 (setq ourcomments-paste-beg (min beg ourcomments-paste-beg))
2304 (setq ourcomments-paste-end (max end ourcomments-paste-end)))
2306 (defmacro ourcomments-advice-paste-command (paste-command)
2307 (let ((adv-name (make-symbol (concat "ourcomments-org-ad-"
2308 (symbol-name paste-command)))))
2309 `(defadvice ,paste-command (around
2311 (let ((ourcomments-paste-beg (point-max)) ;; dyn var
2312 (ourcomments-paste-end (point-min))) ;; dyn var
2313 (add-hook 'after-change-functions `ourcomments-grab-paste-bounds nil t)
2314 ad-do-it ;;;;;;;;;;;;;;;;;;;;;;;;;;
2315 (remove-hook 'after-change-functions `ourcomments-grab-paste-bounds t)
2316 (run-hook-with-args-until-success 'ourcomments-paste-with-convert-hook
2317 ourcomments-paste-beg
2318 ourcomments-paste-end)))))
2320 (defcustom ourcomments-paste-with-convert-commands '(yank cua-paste viper-put-back viper-Put-back)
2321 "Commands for which past converting is done.
2322 See `ourcomments-paste-with-convert-mode' for more information."
2323 :type '(repeat function)
2324 :group 'ourcomments-util)
2327 (define-minor-mode ourcomments-paste-with-convert-mode
2328 "Pasted text may be automatically converted in this mode.
2329 The functions in `ourcomments-paste-with-convert-hook' are run
2330 after commands in `ourcomments-paste-with-convert-commands' if any
2331 of the functions returns non-nil that text is inserted instead of
2334 For exampel when this mode is on and you paste an html link in an
2335 `org-mode' buffer it will be directly converted to an org style
2336 link. \(This is the default behaviour.)
2338 Tip: The Firefox plugin Copy as HTML Link is handy, see URL
2339 `https://addons.mozilla.org/en-US/firefox/addon/2617'.
2341 Note: This minor mode will defadvice the paste commands."
2345 :group 'ourcomments-util
2346 (if ourcomments-paste-with-convert-mode
2348 (dolist (command ourcomments-paste-with-convert-commands)
2349 (eval `(ourcomments-advice-paste-command ,command))
2350 (ad-activate command)))
2351 (dolist (command ourcomments-paste-with-convert-commands)
2352 (ad-unadvise command))))
2354 ;; (ourcomments-advice-paste-command cua-paste)
2355 ;; (ad-activate 'cua-paste)
2356 ;; (ad-deactivate 'cua-paste)
2357 ;; (ad-update 'cua-paste)
2358 ;; (ad-unadvise 'cua-paste)
2362 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2363 ;;;; Menu commands to M-x history
2365 ;; (where-is-internal 'mumamo-mark-chunk nil nil)
2366 ;; (where-is-internal 'mark-whole-buffer nil nil)
2367 ;; (where-is-internal 'save-buffer nil nil)
2368 ;; (where-is-internal 'revert-buffer nil nil)
2369 ;; (setq extended-command-history nil)
2370 (defun ourcomments-M-x-menu-pre ()
2371 "Add menu command to M-x history."
2372 (let ((is-menu-command (equal '(menu-bar)
2373 (when (< 0 (length (this-command-keys-vector)))
2374 (elt (this-command-keys-vector) 0))))
2375 (pre-len (length extended-command-history)))
2376 (when (and is-menu-command
2377 (not (memq this-command '(ourcomments-M-x-menu-mode))))
2378 (pushnew (symbol-name this-command) extended-command-history)
2379 (when (< pre-len (length extended-command-history))
2380 ;; This message is given pre-command and is therefore likely
2381 ;; to be overwritten, but that is ok in this case. If the user
2382 ;; has seen one of these messages s?he knows.
2383 (message (propertize "(Added %s to M-x history so you can run it from there)"
2384 'face 'file-name-shadow)
2388 (define-minor-mode ourcomments-M-x-menu-mode
2389 "Add commands started from Emacs menus to M-x history.
2390 The purpose of this is to make it easier to redo them and easier
2391 to learn how to do them from the command line \(which is often
2392 faster if you know how to do it).
2394 Only commands that are not already in M-x history are added."
2396 (if ourcomments-M-x-menu-mode
2397 (add-hook 'pre-command-hook 'ourcomments-M-x-menu-pre)
2398 (remove-hook 'pre-command-hook 'ourcomments-M-x-menu-pre)))
2400 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2403 (defvar ourcomments-warnings nil)
2405 (defun ourcomments-display-warnings ()
2407 (let ((msg (mapconcat 'identity (reverse ourcomments-warnings) "\n")))
2408 (setq ourcomments-warnings nil)
2409 (message "%s" (propertize msg 'face 'secondary-selection)))
2410 (error (message "ourcomments-display-warnings: %s" err))))
2412 (defun ourcomments-warning-post ()
2414 (run-with-idle-timer 0.5 nil 'ourcomments-display-warnings)
2415 (error (message "ourcomments-warning-post: %s" err))))
2418 (defun ourcomments-warning (format-string &rest args)
2419 (setq ourcomments-warnings (cons (apply 'format format-string args)
2420 ourcomments-warnings))
2421 (add-hook 'post-command-hook 'ourcomments-warning-post))
2425 (provide 'ourcomments-util)
2426 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2427 ;;; ourcomments-util.el ends here