diff options
Diffstat (limited to 'emacs.d/nxhtml/util/ourcomments-util.el')
| -rw-r--r-- | emacs.d/nxhtml/util/ourcomments-util.el | 2427 |
1 files changed, 0 insertions, 2427 deletions
diff --git a/emacs.d/nxhtml/util/ourcomments-util.el b/emacs.d/nxhtml/util/ourcomments-util.el deleted file mode 100644 index 5e9c2e6..0000000 --- a/emacs.d/nxhtml/util/ourcomments-util.el +++ /dev/null @@ -1,2427 +0,0 @@ -;;; 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 |