nxhtml/util/ourcomments-util.el

   1 ;;; ourcomments-util.el --- Utility routines
   2 ;;
   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
   7 ;; Keywords:
   8 ;; Compatibility: Emacs 22
   9 ;;
  10 ;; Features that might be required by this library:
  11 ;;
  12 ;;   None
  13 ;;
  14 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  15 ;;
  16 ;;; Commentary:
  17 ;;
  18 ;; The functionality given by these small routines should in my
  19 ;; opinion be part of Emacs (but they are not that currently).
  20 ;;
  21 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  22 ;;
  23 ;;; Change log:
  24 ;;
  25 ;;
  26 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  27 ;;
  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)
  31 ;; any later version.
  32 ;;
  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.
  37 ;;
  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.
  42 ;;
  43 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  44 ;;
  45 ;;; Code:
  46
  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))
  55
  56 (require 'cus-edit)
  57
  58 ;; (ourcomments-indirect-fun 'html-mumamo)
  59 ;; (ourcomments-indirect-fun 'html-mumamo-mode)
  60 ;;;###autoload
  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)
  65              (functionp fun))
  66     (let ((def (symbol-function fun)))
  67       (when (symbolp def)
  68         (while (and (fboundp def)
  69                     (symbolp (symbol-function def)))
  70           (setq def (symbol-function def)))
  71         def))))
  72
  73 (defun ourcomments-goto-line (line)
  74   "A version of `goto-line' for use in elisp code."
  75   (save-restriction
  76     (widen)
  77     (goto-char (point-min))
  78     (forward-line (1- line))))
  79
  80 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  81 ;;;; Popups etc.
  82
  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))
  90          (x-y (posn-x-y pn))
  91          (x (car x-y))
  92          (y (cdr x-y))
  93          (pos (list (list x (+ y 20)) (selected-window))))
  94     pos))
  95
  96 ;;;###autoload
  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)))
 104
 105
 106
 107
 108 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 109 ;;;; Toggles in menus
 110
 111 ;;;###autoload
 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.
 116
 117 The arguments have the same meaning as for `defcustom' with these
 118 restrictions:
 119
 120 - The :type keyword cannot be used.  Type is always 'boolean.
 121 - VALUE must be t or nil.
 122
 123 DOC and ARGS are just passed to `defcustom'.
 124
 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.
 128
 129 To create a menu item something similar to this can be used:
 130
 131     \(define-key map [SYMBOL]
 132       \(list 'menu-item \"Toggle nice SYMBOL\"
 133             'SYMBOL-toggle
 134             :button '(:toggle . SYMBOL)))"
 135   (declare
 136    (doc-string 3)
 137    (debug t))
 138   (let* ((SYMBOL-toggle (intern (concat (symbol-name symbol) "-toggle")))
 139          (SYMBOL-name (symbol-name symbol))
 140          (var-doc doc)
 141          (fun-doc (concat "Toggles the \(boolean) value of `"
 142                           SYMBOL-name
 143                           "'.\n"
 144                           "For how to set it permanently see this variable.\n"
 145                           )))
 146     (let ((var (append `(defcustom ,symbol ,value ,var-doc)
 147                 args
 148                 nil))
 149           (fun `(defun ,SYMBOL-toggle ()
 150                   ,fun-doc
 151                   (interactive)
 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
 156       `(progn ,var ,fun)
 157     )))
 158
 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))
 161
 162 ;;;###autoload
 163 (defmacro define-toggle-old (symbol value doc &rest args)
 164   (declare (doc-string 3))
 165   (list
 166    'progn
 167    (let ((var-decl (list 'custom-declare-variable
 168                          (list 'quote symbol)
 169                          (list 'quote value)
 170                          doc)))
 171      (while args
 172        (let ((arg (car args)))
 173          (setq args (cdr args))
 174          (unless (symbolp arg)
 175            (error "Junk in args %S" args))
 176          (let ((keyword arg)
 177                (value (car args)))
 178            (unless args
 179              (error "Keyword %s is missing an argument" keyword))
 180            (setq args (cdr args))
 181            (cond
 182             ((not (memq keyword '(:type)))
 183              (setq var-decl (append var-decl (list keyword value))))
 184             (t
 185              (lwarn '(define-toggle) :error "Keyword %s can't be used here"
 186                     keyword))))))
 187      (when (assoc :type var-decl) (error ":type is set.  Should not happen!"))
 188      (setq var-decl (append var-decl (list :type '(quote boolean))))
 189      var-decl)
 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 `"
 193                            SYMBOL-name
 194                            "'.\n"
 195                            "For how to set it permanently see this variable.\n"
 196                            ;;"\nDescription of `" SYMBOL-name "':\n" doc
 197                            )))
 198      `(defun ,SYMBOL-toggle ()
 199         ,fun-doc
 200         (interactive)
 201         (customize-set-variable (quote ,symbol) (not ,symbol)))
 202      )))
 203
 204
 205
 206 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 207 ;;;; Indentation of regions
 208
 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.
 213
 214 ;; Call `indent-region' if region is active, otherwise
 215 ;; `indent-according-to-mode'."
 216 ;;   (interactive)
 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])))
 221 ;;     (if (not
 222 ;;          (save-match-data
 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
 229
 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
 233 ;; on."
 234 ;;   :global t
 235 ;;   :keymap '(([?\t] . indent-line-or-region)))
 236 ;; (when indent-region-mode (indent-region-mode 1))
 237
 238
 239 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 240 ;;;; Minor modes
 241
 242 ;; (defmacro define-globalized-minor-mode-with-on-off (global-mode mode
 243 ;;                                                     turn-on turn-off
 244 ;;                                                     &rest keys)
 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.
 249
 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.
 261
 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."
 267
 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))
 271 ;;          (group nil)
 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)
 280 ;;                                           "-major-mode")))
 281 ;;          (MODE-checking (intern (concat global-mode-name "-checking")))
 282 ;;          keyw)
 283
 284 ;;     ;; Check keys.
 285 ;;     (while (keywordp (setq keyw (car keys)))
 286 ;;       (setq keys (cdr keys))
 287 ;;       (case keyw
 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))))
 291
 292 ;;     (unless group
 293 ;;       ;; We might as well provide a best-guess default group.
 294 ;;       (setq group
 295 ;;             `(:group ',(intern (replace-regexp-in-string
 296 ;;                                 "-mode\\'" "" (symbol-name mode))))))
 297
 298 ;;     `(progn
 299
 300 ;;        ;; Define functions for the global mode first so that it can be
 301 ;;        ;; turned on during load:
 302
 303 ;;        ;; List of buffers left to process.
 304 ;;        (defvar ,MODE-buffers nil)
 305
 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
 312 ;;                  (if ,mode
 313 ;;                      (unless (eq ,MODE-major-mode major-mode)
 314 ;;                        (setq ,MODE-checking t)
 315 ;;                        (,mode -1)
 316 ;;                        (,turn-on)
 317 ;;                        (setq ,MODE-checking nil)
 318 ;;                        (setq ,MODE-major-mode major-mode))
 319 ;;                    (setq ,MODE-checking t)
 320 ;;                    (,turn-on)
 321 ;;                    (setq ,MODE-checking nil)
 322 ;;                    (setq ,MODE-major-mode major-mode)))))))
 323 ;;        (put ',MODE-enable-in-buffers 'definition-name ',global-mode)
 324
 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)
 330
 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)
 336
 337
 338 ;;        (defvar ,MODE-major-mode nil)
 339 ;;        (make-variable-buffer-local ',MODE-major-mode)
 340
 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
 348 ;;                   mode pretty-name)
 349 ;;          :global t ,@group ,@(nreverse extra-keywords)
 350
 351 ;;          ;; Setup hook to handle future mode changes and new buffers.
 352 ;;          (if ,global-mode
 353 ;;              (progn
 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))
 363
 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))
 370 ;;                ))))
 371
 372 ;;        )))
 373
 374
 375 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 376 ;;;; Unfilling
 377 ;;
 378 ;; The idea is from
 379 ;;   http://interglacial.com/~sburke/pub/emacs/sburke_dot_emacs.config
 380
 381 ;;;###autoload
 382 (defun unfill-paragraph ()
 383   "Unfill the current paragraph."
 384   (interactive) (with-unfilling 'fill-paragraph))
 385 ;;(defalias 'unwrap-paragraph 'unfill-paragraph)
 386
 387 ;;;###autoload
 388 (defun unfill-region ()
 389   "Unfill the current region."
 390   (interactive) (with-unfilling 'fill-region))
 391 ;;(defalias 'unwrap-region 'unfill-region)
 392
 393 ;;;###autoload
 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)
 398
 399 (defun with-unfilling (fn)
 400   "Unfill using the fill function FN."
 401   (let ((fill-column (1+ (point-max)))) (call-interactively fn)))
 402
 403 (defvar fill-dwim-state nil)
 404 (defvar fill-dwim-mark nil)
 405
 406 ;;;###autoload
 407 (defun fill-dwim (arg)
 408   "Fill or unfill paragraph or region.
 409 With prefix ARG fill only current line."
 410   (interactive "P")
 411   (or arg
 412       (not fill-dwim-mark)
 413       (equal (point-marker) fill-dwim-mark)
 414       (setq fill-dwim-state nil))
 415   (if mark-active
 416       ;; This avoids deactivating the mark
 417       (progn
 418         (if fill-dwim-state
 419             (call-interactively 'unfill-region)
 420           (call-interactively 'fill-region))
 421         (setq deactivate-mark nil))
 422     (if arg
 423         (fill-region (line-beginning-position) (line-end-position))
 424       (if fill-dwim-state
 425           (call-interactively 'unfill-paragraph)
 426         (call-interactively 'fill-paragraph))))
 427   (setq fill-dwim-mark (copy-marker (point)))
 428   (unless arg
 429     (setq fill-dwim-state (not fill-dwim-state))))
 430
 431 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 432 ;;;; Widgets
 433
 434 ;;;###autoload
 435 (defun ourcomments-mark-whole-buffer-or-field ()
 436   "Mark whole buffer or editable field at point."
 437   (interactive)
 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))))
 442     (if (not field)
 443         (mark-whole-buffer)
 444       (while (and size
 445                   (not (zerop size))
 446                   (> to from)
 447                   (eq (char-after (1- to)) ?\s))
 448         (setq to (1- to)))
 449       (push-mark (point))
 450       (push-mark from nil t)
 451       (goto-char to))))
 452
 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)
 470
 471
 472 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 473 ;;;; Lines
 474
 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.
 478 ;;;###autoload
 479 (defun ourcomments-move-beginning-of-line(arg)
 480   "Move point to beginning of line or indentation.
 481 See `beginning-of-line' for ARG.
 482
 483 If `line-move-visual' is non-nil then the visual line beginning
 484 is first tried.
 485
 486 If in a widget field stay in that."
 487   (interactive "p")
 488   (let ((pos (point))
 489         vis-pos
 490         (field (widget-field-at (point))))
 491     (when line-move-visual
 492       (line-move-visual -1 t)
 493       (beginning-of-line)
 494       (setq vis-pos (point))
 495       (goto-char pos))
 496     (call-interactively 'beginning-of-line arg)
 497     (when (and vis-pos
 498                (= vis-pos (point)))
 499       (while (and (> pos (point))
 500                   (not (eobp)))
 501         (let (last-command)
 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")
 507         (backward-char)
 508         (beginning-of-line)))
 509     (when (and field
 510                (< (point) (widget-field-start field)))
 511       (goto-char (widget-field-start field)))))
 512 (put 'ourcomments-move-beginning-of-line 'CUA 'move)
 513
 514 ;;;###autoload
 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.
 518
 519 Similar to `ourcomments-move-beginning-of-line' but for end of
 520 line."
 521   (interactive "p")
 522   (or arg (setq arg 1))
 523   (let ((pos (point))
 524         vis-pos
 525         eol-pos)
 526     (when line-move-visual
 527       (let (last-command) (line-move-visual 1 t))
 528       (end-of-line)
 529       (setq vis-pos (point))
 530       (goto-char pos))
 531     (call-interactively 'end-of-line arg)
 532     (when (and vis-pos
 533                (= vis-pos (point)))
 534       (setq eol-pos (point))
 535       (beginning-of-line)
 536       (let (last-command) (line-move-visual 1 t))
 537       ;; move backwards if we moved to a new line
 538       (unless (= (point) eol-pos)
 539         (backward-char)))
 540     (when (= pos (point))
 541       (if (= (line-end-position) (point))
 542           (skip-chars-backward " \t")
 543         (forward-char)
 544         (end-of-line)))))
 545 (put 'ourcomments-move-end-of-line 'CUA 'move)
 546
 547 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 548 ;;;; Keymaps
 549
 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
 553 KEYMAP---.
 554
 555 Ignore `special-event-map', `global-map', `overriding-local-map'
 556 and `overriding-terminal-local-map'."
 557   (let ((vars--- nil)
 558         (ancestors--- nil))
 559     (let ((parent (keymap-parent keymap---)))
 560       (while parent
 561         (setq ancestors--- (cons parent ancestors---))
 562         (setq parent (keymap-parent parent))))
 563     (mapatoms (lambda (symbol)
 564                 (unless (memq symbol '(keymap---
 565                                        ancestors---
 566                                        vars---
 567                                        special-event-map
 568                                        global-map
 569                                        overriding-local-map
 570                                        overriding-terminal-local-map
 571                                        ))
 572                   (let (val)
 573                     (if (boundp symbol)
 574                         (setq val (symbol-value symbol))
 575                       (when (keymapp symbol)
 576                         (setq val (symbol-function symbol))))
 577                     (when (and val
 578                                (keymapp val)
 579                                (eq binding--- (lookup-key val key--- t)))
 580                       (if (equal val keymap---)
 581                           (push symbol vars---)
 582                         (when ancestors---
 583                           (catch 'found
 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)
 592 ;;;                      (
 593     vars---))
 594
 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').
 601
 602 The entries in the list have the form
 603
 604   \(BINDING (MAPS) MORE-INFO)
 605
 606 where BINDING is the command bound to and MAPS are matching maps
 607 \(according to `ourcomments-find-keymap-variables').
 608
 609 MORE-INFO is a list with more information
 610
 611   \(PRIORITY-LEVEL \[ACTIVE-WHEN])
 612
 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))
 619         map
 620         map-sym
 621         map-rec
 622         binding
 623         keymaps
 624         minor-maps
 625         where
 626         map-where
 627         where-map
 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))
 632         )
 633     (setq keymaps
 634           (cons (list global-map 'global-map)
 635                 keymaps))
 636     (when overriding-terminal-local-map
 637       (setq keymaps
 638             (cons (list overriding-terminal-local-map 'overriding-terminal-local-map)
 639                   keymaps)))
 640     (when overriding-local-map
 641       (setq keymaps
 642             (cons (list overriding-local-map 'overriding-local-map)
 643                   keymaps)))
 644     (unless (cdr keymaps)
 645       (when point-local-map
 646         (setq keymaps
 647               (cons (list point-local-map 'point-local-map)
 648                     keymaps)))
 649       ;; Fix-me:
 650       ;;/* If on a mode line string with a local keymap,
 651
 652       (when local-map
 653         (setq keymaps
 654               (cons (list local-map 'local-map)
 655                     keymaps)))
 656
 657       ;; Minor-modes
 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)
 664                           (symbol-value list)
 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)
 674                                      (boundp var))
 675                             (symbol-value var))))
 676                 ;;(message "var= %s, val= %s" var val)
 677                 (when (and
 678                        val
 679                        (or (not (eq list 'minor-mode-map-alist))
 680                            (not (assq var minor-mode-overriding-map-alist))))
 681                   ;;(message "** Adding this")
 682                   (setq minor-maps
 683                         (cons (list (cdr assoc) list var)
 684                               minor-maps)))
 685                 )))))
 686       (dolist (map minor-maps)
 687         ;;(message "cdr map= %s" (cdr map))
 688         (setq keymaps
 689               (cons map
 690                     keymaps)))
 691       (when point-keymap
 692         (setq keymaps
 693               (cons (list point-keymap 'point-keymap)
 694                     keymaps))))
 695
 696     ;; Fix-me: compare with current-active-maps
 697     (let ((ca-maps (current-active-maps))
 698           (wh-maps keymaps)
 699           ca
 700           wh)
 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)))))
 710
 711     (while keymaps
 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)))
 722
 723     (nreverse bindings)))
 724
 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"
 730                                               (lambda (sym)
 731                                                 (and (boundp sym)
 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)
 742                           'action
 743                           (lambda (btn)
 744                             (describe-variable keymap-sym)))
 745       (insert "'\nin minor modes activation maps:\n")
 746       (let (found)
 747         (dolist (map-root '(emulation-mode-map-alists
 748                             minor-mode-overriding-map-alist
 749                             minor-mode-map-alist
 750                             ))
 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)
 756                        (list emul-alist)))
 757               (let* ((map (cdr keymap-alist))
 758                      (first (catch 'first
 759                               (map-keymap (lambda (key def)
 760                                             (throw 'first (cons key def)))
 761                                           map)))
 762                      (key (car first))
 763                      (def (cdr first))
 764                      (keymap-variables (when (and key def)
 765                                          (ourcomments-find-keymap-variables
 766                                           (vector key) def map)))
 767                      (active-var (car keymap-alist))
 768                      )
 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)
 773                   (setq found t)
 774                   (insert (format "\n`%s' " map-root))
 775                   (insert (propertize "<= Minor mode keymap list holding this map"
 776                                       'face 'font-lock-doc-face))
 777                   (insert "\n")
 778                   (when (symbolp emul-alist)
 779                     (insert (format "  `%s' " emul-alist))
 780                     (insert (propertize "<= Keymap alist variable" 'face 'font-lock-doc-face))
 781                     (insert "\n"))
 782                   ;;(insert (format "    `%s'\n" keymap-alist))
 783                   (insert (format "      `%s' " active-var))
 784                   (insert (propertize "<= Activation variable" 'face 'font-lock-doc-face))
 785                   (insert "\n")
 786                   )))))
 787         (unless found
 788           (insert (propertize "Not found." 'face 'font-lock-warning-face)))
 789         ))))
 790
 791 ;; This is a replacement for describe-key-briefly.
 792 ;;(global-set-key [f1 ?c] 'describe-key-and-map-briefly)
 793 ;;;###autoload
 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
 799 variable symbols.
 800
 801 When called interactively prompt for KEY.
 802
 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.
 807   (interactive
 808    (let ((enable-disabled-menus-and-buttons t)
 809          (cursor-in-echo-area t)
 810          saved-yank-menu)
 811      (unwind-protect
 812          (let (key)
 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.
 823            (and (vectorp key)
 824                 (let ((last-idx (1- (length key))))
 825                   (and (eventp (aref key last-idx))
 826                        (memq 'down (event-modifiers (aref key last-idx)))))
 827                 (read-event))
 828            (list
 829             key
 830             (if current-prefix-arg (prefix-numeric-value current-prefix-arg))
 831             1
 832             ))
 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))
 840                          (> (length key) 1)
 841                          (consp (aref key 1)))
 842                     (aref key 1)
 843                   (aref key 0)))
 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))
 849          key-desc)
 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))
 863     ;;
 864     ;; End of part from describe-key-briefly.
 865     ;; <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
 866
 867     ;;(message "bindings=%s" (key-bindings key)) (sit-for 2)
 868     ;; Find the keymap:
 869     (let* ((maps (current-active-maps))
 870            ret
 871            lk)
 872       (if (or (null defn) (integerp defn) (equal defn 'undefined))
 873           (setq ret 'not-defined)
 874         (catch 'mapped
 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)))
 879               (when ret
 880                 (throw 'mapped (car maps))))
 881             (setq maps (cdr maps))))
 882         (unless ret
 883           (setq lk (lookup-key global-map key t))
 884           (when (and lk (not (numberp lk)))
 885             (setq ret '(global-map)))))
 886       (cond
 887        ((eq ret 'not-defined)
 888         (message "%s%s not defined in any keymap" key-desc mouse-msg))
 889        ((listp ret)
 890         (if (not ret)
 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))))
 898        (t
 899         (error "ret=%s" ret)))
 900       ret)))
 901
 902 ;; (ourcomments-find-keymap-variables (current-local-map))
 903 ;; (keymapp 'ctl-x-4-prefix)
 904 ;; (equal 'ctl-x-4-prefix (current-local-map))
 905 ;;
 906
 907 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 908 ;;;; Fringes.
 909
 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)
 913   (if (not on)
 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))
 918     (let ((better
 919            '(bottom
 920              bottom-right-angle bottom-right-angle
 921              bottom-left-angle bottom-left-angle
 922              ))
 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)))))
 927
 928 (defun better-fringes-faces (face face-important)
 929   (dolist (bitmap '(bottom-left-angle
 930                     bottom-right-angle
 931                     top-left-angle
 932                     top-right-angle
 933
 934                     right-curly-arrow
 935                     left-arrow right-arrow
 936                     left-curly-arrow right-curly-arrow
 937                     up-arrow
 938                     down-arrow
 939                     left-bracket right-bracket
 940                     empty-line))
 941     (set-fringe-bitmap-face bitmap face))
 942   (dolist (bitmap '(right-triangle
 943                     question-mark))
 944     (set-fringe-bitmap-face bitmap face-important)))
 945
 946 (defface better-fringes-bitmap
 947   '((t (:foreground "dark khaki")))
 948   "Face for bitmap fringes."
 949   :group 'better-fringes
 950   :group 'nxhtml)
 951
 952 (defface better-fringes-important-bitmap
 953   '((t (:foreground "red")))
 954   "Face for bitmap fringes."
 955   :group 'better-fringes
 956   :group 'nxhtml)
 957
 958 ;;;###autoload
 959 (define-minor-mode better-fringes-mode
 960   "Choose another fringe bitmap color and bottom angle."
 961   :global t
 962   :group 'better-fringes
 963   (if better-fringes-mode
 964       (progn
 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)))
 970
 971
 972 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 973 ;;;; Copy+paste
 974
 975 ;; After an idea from andrea on help-gnu-emacs
 976
 977 (defvar ourcomments-copy+paste-point nil)
 978
 979 ;;(global-set-key [(control ?c) ?y] 'ourcomments-copy+paste-set-point)
 980 ;;;###autoload
 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.
 986
 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'."
 991   (interactive)
 992   (if ourcomments-copy+paste-point
 993       (ourcomments-copy+paste-mode -1)
 994     (setq ourcomments-copy+paste-point (list (copy-marker (point))
 995                                              (selected-window)
 996                                              (current-frame-configuration)
 997                                              ))
 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))))
1006
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)
1012     map))
1013
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'.
1017
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]
1022
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
1025 that command."
1026   :lighter " COPY+PASTE"
1027   :global t
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"))))
1036
1037 (defvar ourcomments-copy+paste-ovl nil)
1038
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))
1043
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
1050 display it."
1051   (interactive "P")
1052   (cond
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)))
1058    ((not mark-active)
1059     (message "Please select a region to copy+paste first"))
1060    (t
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))
1074             (t
1075              (switch-to-buffer-other-window buf)))
1076       (goto-char marker))
1077     (let ((here (point))
1078           ovl)
1079       (yank)
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))))
1086
1087
1088 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1089 ;;;; Misc.
1090
1091 ;;(describe-timers)
1092 ;;;###autoload
1093 (defun describe-timers ()
1094   "Show timers with readable time format."
1095   (interactive)
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)
1101           (insert "  None\n")
1102         (insert (propertize
1103                  "  When                    Rpt  What\n"
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))
1114                                  (substring
1115                                   (format "%.1f" (/ mi-sec 1000000.0))
1116                                   1))))
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)
1121           (insert "  None\n")
1122         (insert (propertize
1123                  "  After    Rpt  What\n"
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)))
1134                  )
1135             (assert (not (not idle-d)) t)
1136             (insert (format "  %.2f sec %3s  (`%s' %S)\n" time rpt-d fun args))))))))
1137
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'."
1141   :type 'string
1142   :group 'ourcomments-util)
1143
1144 ;;;###autoload
1145 (defun ourcomments-insert-date-and-time ()
1146   "Insert date and time.
1147 See option `ourcomments-insert-date-and-time' for how to
1148 customize it."
1149   (interactive)
1150   (insert (format-time-string ourcomments-insert-date-and-time)))
1151
1152 ;;;###autoload
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.
1160
1161 Rename current buffer using your `uniquify-buffer-name-style' if
1162 it is set.
1163
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)))
1178          source-file
1179          installed-file
1180          other-file
1181          (line-num (save-restriction
1182                      (widen)
1183                      (line-number-at-pos))))
1184     (cond
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))
1196     (unless other-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))
1200     (when display-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))
1205     other-file))
1206
1207 ;;;###autoload
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.
1212
1213 This is used in EmacsW32 in the file ediff.cmd where Emacs Client
1214 is called like this:
1215
1216   @%emacs_client% -e \"(setq default-directory \\\"%emacs_cd%\\\")\"
1217   @%emacs_client% -n  -e \"(ediff-files \\\"%f1%\\\" \\\"%f2%\\\")\"
1218
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)))
1222
1223
1224 (defun ourcomments-latest-changelog ()
1225   "not ready"
1226   (let ((changelogs
1227          '("ChangeLog"
1228            "admin/ChangeLog"
1229            "doc/emacs/ChangeLog"
1230            "doc/lispintro/ChangeLog"
1231            "doc/lispref/ChangeLog"
1232            "doc/man/ChangeLog"
1233            "doc/misc/ChangeLog"
1234            "etc/ChangeLog"
1235            "leim/ChangeLog"
1236            "lib-src/ChangeLog"
1237            "lisp/ChangeLog"
1238            "lisp/erc/ChangeLog"
1239            "lisp/gnus/ChangeLog"
1240            "lisp/mh-e/ChangeLog"
1241            "lisp/org/ChangeLog"
1242            "lisp/url/ChangeLog"
1243            "lwlib/ChangeLog"
1244            "msdos/ChangeLog"
1245            "nextstep/ChangeLog"
1246            "nt/ChangeLog"
1247            "oldXMenu/ChangeLog"
1248            "src/ChangeLog"
1249            "test/ChangeLog"))
1250         (emacs-root (expand-file-name ".." exec-directory)
1251         ))))
1252
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)
1259          val)
1260     (when predicate
1261       (unless (and symbol
1262                    (symbolp symbol)
1263                    (funcall predicate symbol))
1264         (setq symbol nil)))
1265     (setq val (completing-read (if symbol
1266                                    (format
1267                                     "%s (default %s): " prompt symbol)
1268                                  (format "%s: " prompt))
1269                                obarray
1270                                predicate
1271                                t nil nil
1272                                (if symbol (symbol-name symbol))))
1273     (if (equal val "") symbol (intern val))))
1274
1275 (defun ourcomments-command-at-point ()
1276   (let ((fun (function-called-at-point)))
1277     (when (commandp fun)
1278       fun)))
1279
1280 ;;;###autoload
1281 (defun describe-command (command)
1282   "Like `describe-function', but prompts only for interactive commands."
1283   (interactive
1284    (let* ((fn (ourcomments-command-at-point))
1285           (prompt (if fn
1286                       (format "Describe command (default %s): " fn)
1287                     "Describe command: "))
1288           (enable-recursive-minibuffers t)
1289           val)
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))
1295
1296
1297 ;;;###autoload
1298 (defun buffer-narrowed-p ()
1299   "Return non-nil if the current buffer is narrowed."
1300   (/= (buffer-size)
1301       (- (point-max)
1302          (point-min))))
1303
1304 ;;;###autoload
1305 (defun narrow-to-comment ()
1306   (interactive)
1307   (let* ((here (point-marker))
1308          (size 1000)
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"))
1314                      (point)))
1315          (end (progn (forward-comment size)
1316                      ;;(message "skipped %s " (skip-chars-backward "[:space:]"))
1317                      (message "skipped %s " (skip-chars-backward " \t\r\n"))
1318                      (point))))
1319     (goto-char here)
1320     (if (not (and (>= here beg)
1321                   (<= here end)))
1322         (error "Not in a comment")
1323       (narrow-to-region beg end))))
1324
1325 (defvar describe-symbol-alist nil)
1326
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)))
1333
1334 ;;(describe-symbol-add-known 'variable-documentation "Doc for variable")
1335 ;;(describe-symbol-add-known 'cl-struct-slots "defstruct slots")
1336
1337 (defun property-list-keys (plist)
1338   "Return list of key names in property list PLIST."
1339   (let ((keys))
1340     (while plist
1341       (setq keys (cons (car plist) keys))
1342       (setq plist (cddr plist)))
1343     keys))
1344
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)
1349   )
1350
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))))
1358
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)))
1363     (delq 'cl-tag-slot
1364           (loop for rec in cl-struct-slots
1365                 collect (nth 0 rec)))))
1366
1367 ;; (ourcomments-defstruct-slots 'ert-test)
1368
1369 (defun ourcomments-defstruct-file (symbol)
1370   (unless (ourcomments-defstruct-p symbol)
1371     (error "Not a CL defstruct symbol: %s" symbol))
1372   )
1373
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))
1378     (let* (in-defstruct
1379            (symbol-file (symbol-file symbol))
1380            buf
1381            was-here)
1382       (unless symbol-file
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)))
1386       (unless buf
1387         (setq buf (find-file-noselect symbol-file)))
1388       (with-current-buffer buf
1389         (save-restriction
1390           (widen)
1391           (let* ((buf-point (find-definition-noselect symbol nil)))
1392             (goto-char (cdr buf-point))
1393             (save-match-data
1394               (when (looking-at "(defstruct (?\\(\\(?:\\sw\\|\\s_\\)+\\)")
1395                 (setq in-defstruct (match-string-no-properties 1))))))
1396         (if was-here
1397             (goto-char was-here)
1398           (kill-buffer (current-buffer))))
1399       in-defstruct)))
1400 ;; (ourcomments-member-defstruct 'ert-test-name)
1401 ;; (ourcomments-member-defstruct 'ert-test-error-condition)
1402
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))))
1408
1409 ;;;###autoload
1410 (defun describe-custom-group (symbol)
1411   "Describe customization group SYMBOL."
1412   (interactive
1413    (list
1414     (ourcomments-read-symbol "Customization group"
1415                              'ourcomments-custom-group-p)))
1416   ;; Fix-me:
1417   (message "g=%s" symbol))
1418 ;; nxhtml
1419
1420 ;; Added this to current-load-list in cl-macs.el
1421 ;; (describe-defstruct 'ert-stats)
1422 ;;;###autoload
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.")
1432       (insert "\n\n")
1433       (insert (format "%s is a CL `defstruct'" symbol))
1434       (let ((file (symbol-file symbol)))
1435         (if file
1436             ;; Fix-me: .elc => .el
1437             (let ((name (file-name-nondirectory file)))
1438               (insert "defined in file %s.\n" (file-name-nondirectory file)))
1439           (insert ".\n")))
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")))))))
1450
1451 ;;(defun describe-deftype (type)
1452 ;;;###autoload
1453 (defun describe-symbol(symbol)
1454   "Show information about SYMBOL.
1455 Show SYMBOL plist and whether is is a variable or/and a
1456 function."
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)))
1461 ;;;                                     (format
1462 ;;;                                      "Describe symbol (default %s): " s)
1463 ;;;                                   "Describe symbol: ")
1464 ;;;                                 obarray
1465 ;;;                                 nil
1466 ;;;                                 t nil nil
1467 ;;;                                 (if (symbolp s) (symbol-name s)))))
1468 ;;;      (list (if (equal val "") s (intern val)))))
1469   (require 'apropos)
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"))
1476       (if (boundp symbol)
1477           (insert (format "- There is a variable `%s'.\n" symbol))
1478         (insert "- This symbol is not a variable.\n"))
1479       (if (fboundp symbol)
1480           (progn
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)
1488                                               (describe-symbol
1489                                                (button-get button 'symbol))))))
1490             (insert ".\n"))
1491         (insert "- This symbol is not a function.\n"))
1492       (if (facep symbol)
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)
1496           (progn
1497             (insert "- There is a customization group ")
1498             (insert-text-button (format "%s" symbol)
1499                                 'symbol symbol
1500                                 'action (lambda (button)
1501                                           (describe-custom-group
1502                                            (button-get button 'symbol))))
1503             (insert ".\n"))
1504         (insert "- This symbol is not a customization group.\n"))
1505       (if (ourcomments-defstruct-p symbol)
1506           (progn
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"))
1518       (insert "\n")
1519       (let* ((pl (symbol-plist symbol))
1520              (pl-not-known (property-list-keys pl))
1521              any-known)
1522         (if (not pl)
1523             (insert (format "Symbol %s has no property list\n\n" symbol))
1524           ;; Known properties
1525           (dolist (rec describe-symbol-alist)
1526             (let ((prop (nth 0 rec))
1527                   (desc (nth 1 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))
1531                 (insert
1532                  "The following keys in the property list are known:\n\n")
1533                 (insert (format "* %s: %s\n" prop desc))
1534                 )))
1535           (unless any-known
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")))))))
1543
1544 (defun ourcomments-format-plist (pl sep &optional compare)
1545   (when (symbolp pl)
1546     (setq pl (symbol-plist pl)))
1547   (let (p desc p-out)
1548     (while 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))
1554         (setq p nil))
1555       (if p
1556           (progn
1557             (and compare apropos-match-face
1558                  (put-text-property (match-beginning 0) (match-end 0)
1559                                     'face apropos-match-face
1560                                     p))
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)))
1565               (let* ((indent "    ")
1566                      (ind-nl (concat "\n" indent)))
1567                 (setq desc
1568                       (concat
1569                        ind-nl
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)))
1573     p-out))
1574
1575 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1576 ;;;; ido
1577
1578 (defvar ourcomments-ido-visit-method nil)
1579
1580 ;;;###autoload
1581 (defun ourcomments-ido-buffer-other-window ()
1582   "Show buffer in other window."
1583   (interactive)
1584   (setq ourcomments-ido-visit-method 'other-window)
1585   (call-interactively 'ido-exit-minibuffer))
1586
1587 ;;;###autoload
1588 (defun ourcomments-ido-buffer-other-frame ()
1589   "Show buffer in other frame."
1590   (interactive)
1591   (setq ourcomments-ido-visit-method 'other-frame)
1592   (call-interactively 'ido-exit-minibuffer))
1593
1594 ;;;###autoload
1595 (defun ourcomments-ido-buffer-raise-frame ()
1596   "Raise frame showing buffer."
1597   (interactive)
1598   (setq ourcomments-ido-visit-method 'raise-frame)
1599   (call-interactively 'ido-exit-minibuffer))
1600
1601 (defun ourcomments-ido-switch-buffer-or-next-entry ()
1602   (interactive)
1603   (if (active-minibuffer-window)
1604       (ido-next-match)
1605     (ido-switch-buffer)))
1606
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))
1613       (when the-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))))))
1621
1622 ;; (defun ourcomments-ido-setup-completion-map ()
1623 ;;   "Set up the keymap for `ido'."
1624
1625 ;;   (ourcomments-ido-mode-advice)
1626
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)))
1630
1631 ;;     (when viper-p
1632 ;;       (define-key map [remap viper-intercept-ESC-key] 'ignore))
1633
1634 ;;     (cond
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))
1639 ;;       (when viper-p
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)))
1647
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))
1652
1653 ;;      (t
1654 ;;       (set-keymap-parent map ido-common-completion-map)))
1655
1656 ;;     ;; ctrl-tab etc
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)
1663
1664 ;;     (setq ido-completion-map map)))
1665
1666 ;; (defadvice ido-setup-completion-map (around
1667 ;;                                      ourcomments-advice-ido-setup-completion-map
1668 ;;                                      disable)
1669 ;;   (setq ad-return-value (ourcomments-ido-setup-completion-map))
1670 ;;   )
1671
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
1678                      ;;activate
1679                      ;;compile
1680                      disable)
1681   "Add C-tab to ido buffer completion."
1682   (ourcomments-ido-mode-advice)
1683   ;;ad-return-value
1684   )
1685 ;; (ad-activate 'ido-mode)
1686 ;; (ad-deactivate 'ido-mode)
1687
1688 (defadvice ido-visit-buffer (before
1689                              ourcomments-advice-ido-visit-buffer
1690                              ;;activate
1691                              ;;compile
1692                              disable)
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)
1697     ))
1698 (setq ourcomments-ido-adviced t)
1699 )
1700
1701 ;;(message "after advising ido")
1702 ;;(ad-deactivate 'ido-visit-buffer)
1703 ;;(ad-activate 'ido-visit-buffer)
1704
1705 (defvar ourcomments-ido-old-state ido-mode)
1706
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)))
1724
1725 ;;;###autoload
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
1729 following way:
1730
1731 - You can use C-Tab.
1732
1733 - You can show the selected buffer in three ways independent of
1734   how you entered function `ido-mode' buffer switching:
1735
1736   * S-return: other window
1737   * C-return: other frame
1738   * M-return: raise frame
1739
1740 Those keys are selected to at least be a little bit reminiscent
1741 of those in for example common web browsers."
1742   :global t
1743   :group 'emacsw32
1744   :group 'convenience
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
1753     ;; disappears. Huh.
1754     ;;(if ourcomments-ido-old-state
1755     ;;    (ido-mode ourcomments-ido-old-state)
1756     ;;  (when ido-mode (ido-mode -1)))
1757     ))
1758
1759 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1760 ;;;; New Emacs instance
1761
1762 (defun ourcomments-find-emacs ()
1763   (locate-file invocation-name
1764                (list invocation-directory)
1765                exec-suffixes
1766                ;; 1 ;; Fix-me: This parameter is depreceated, but used
1767                ;; in executable-find, why?
1768                ))
1769
1770 (defvar ourcomments-restart-server-mode nil)
1771
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:
1791     (sleep-for 3)))
1792
1793 ;;;###autoload
1794 (defun emacs-restart ()
1795   "Restart Emacs and start `server-mode' if on before."
1796   (interactive)
1797   (if (not window-system)
1798       (message "Can't restart emacs if window-system is nil")
1799     (let ((wait 4))
1800       (while (> (setq wait (1- wait)) 0)
1801         (message (propertize (format "Will restart Emacs in %d seconds..." wait)
1802                              'face 'secondary-selection))
1803         (sit-for 1)))
1804     (setq ourcomments-restart-server-mode server-mode)
1805     (add-hook 'kill-emacs-hook 'emacs-restart-in-kill t)
1806     (save-buffers-kill-emacs)))
1807
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.
1811
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"))
1817
1818 ;;;###autoload
1819 (defun emacs (&rest args)
1820   "Start a new Emacs with default parameters.
1821 Additional ARGS are passed to the new Emacs.
1822
1823 See also `ourcomments-started-emacs-use-output-buffer'."
1824   (interactive)
1825   (recentf-save-list)
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) " "))
1830          ret
1831          (fin-msg ""))
1832     (when out-buf
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)
1836       (redisplay))
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)
1839     ret))
1840
1841 ;;;###autoload
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'.
1846
1847 This calls the function `emacs' with argument --no-desktop and
1848 the file or a call to dired."
1849   (interactive)
1850   (recentf-save-list)
1851   (let ((file (buffer-file-name))
1852         (lin (line-number-at-pos))
1853         (col (current-column)))
1854     (if file
1855         (apply 'emacs "--no-desktop" (format "+%d:%d" lin col) file nil)
1856       (applay 'emacs "--no-desktop" "--eval" (format "(dired \"%s\")" default-directory nil)))))
1857
1858 ;;;###autoload
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."
1862   (interactive)
1863   (apply 'emacs "--debug-init" args))
1864
1865 ;;;###autoload
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."
1869   (interactive)
1870   (apply 'emacs "--no-desktop" args))
1871
1872 ;;;###autoload
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."
1877   (interactive)
1878   (apply 'emacs "-Q" args))
1879
1880 ;;;###autoload
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."
1884   (interactive)
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"
1888                                        exec-directory))))
1889     (apply 'emacs-Q "--debug-init" "--load" autostart args)))
1890
1891
1892 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1893 ;;;; Searching
1894
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))
1901         files
1902         loc)
1903     (font-lock-fontify-buffer)
1904     (goto-char (point-min))
1905     (while (setq loc
1906                  (condition-case err
1907                      (compilation-next-error 1)
1908                    (error
1909                     ;; This should be the end, but give a message for
1910                     ;; easier debugging.
1911                     (message "%s" err)
1912                          nil)))
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)))
1917     (goto-char here)
1918     ;;(message "files=%s" files)
1919     files))
1920
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
1924 no default value.")
1925
1926 ;; Mostly copied from `dired-do-query-replace-regexp'. Fix-me: finish, test
1927 ;;;###autoload
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]."
1933   (interactive
1934    (let ((common
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)
1942                                              (nth 1 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
1947                         buffer-read-only))
1948           (error "File `%s' is visited read-only" file))))
1949   (tags-query-replace from to delimited
1950                       '(grep-get-buffer-files)))
1951
1952 ;;;###autoload
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
1956 directory DIR.
1957
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)))
1964
1965 ;;;###autoload
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.
1970
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)))
1977
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))))
1987     files))
1988
1989 (defun dir-replace-read-parameters (has-dir recursive)
1990   (let* ((common
1991           (let (;;(query-replace-from-history-variable 'grep-regexp-history)
1992                 ;;(query-replace-defaults (or grep-query-replace-defaults
1993                 ;;                            query-replace-defaults))
1994                 )
1995             (query-replace-read-args
1996              "Query replace regexp in files" t t)))
1997          (from (nth 0 common))
1998          (to   (nth 1 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)))
2004
2005 ;; Mostly copied from `grep-read-files'. Could possible be merged with
2006 ;; that.
2007 (defvar replace-read-files-history nil)
2008 ;;;###autoload
2009 (defun replace-read-files (regexp &optional replace)
2010   "Read files arg for replace."
2011   (let* ((bn (or (buffer-file-name) (buffer-name)))
2012          (fn (and bn
2013                   (stringp bn)
2014                   (file-name-nondirectory bn)))
2015          (default
2016            (let ((pre-default
2017                   (or (and fn
2018                            (let ((aliases grep-files-aliases)
2019                                  alias)
2020                              (while aliases
2021                                (setq alias (car aliases)
2022                                      aliases (cdr aliases))
2023                                (if (string-match (wildcard-to-regexp
2024                                                   (cdr alias)) fn)
2025                                    (setq aliases nil)
2026                           (setq alias nil)))
2027                              (cdr alias)))
2028                       (and fn
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) "$")
2035                pre-default)))
2036          (files (read-string
2037                  (if replace
2038                      (concat "Replace \"" regexp
2039                              "\" with \"" replace "\" in files"
2040                              (if default (concat " (default " default
2041                                                  ", regexp or *.EXT)"))
2042                              ": ")
2043                    (concat "Search for \"" regexp
2044                            "\" in files"
2045                            (if default (concat " (default " default ")"))
2046                            ": "))
2047                  nil 'replace-read-files-history default)))
2048     (let ((pattern (and files
2049                         (or (cdr (assoc files grep-files-aliases))
2050                             files))))
2051       (if (and pattern
2052                (string-match-p "^\\*\\.[a-zA-Z0-9]*$" pattern))
2053           (concat "\\." (substring pattern 2) "$")
2054         pattern))))
2055
2056 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2057 ;;;; Info
2058
2059 ;;;###autoload
2060 (defun info-open-file (info-file)
2061   "Open an info file in `Info-mode'."
2062   (interactive
2063    (let ((name (read-file-name "Info file: "
2064                                nil ;; dir
2065                                nil ;; default-filename
2066                                t   ;; mustmatch
2067                                nil ;; initial
2068                                ;; predicate:
2069                                (lambda (file)
2070                                  (or (file-directory-p file)
2071                                      (string-match ".*\\.info\\'" file))))))
2072      (list name)))
2073   (info info-file))
2074
2075 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2076 ;;;; Exec path etc
2077
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))
2085     path))
2086
2087 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2088 ;;;; Custom faces and keys
2089
2090 ;;;###autoload
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)
2098
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)
2104
2105   (set (make-local-variable 'widget-button-pressed-face) custom-button-pressed)
2106   (set (make-local-variable 'widget-mouse-face) custom-button-mouse)
2107
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) ""))
2115
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))
2129
2130 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2131 ;;;; Bookmarks
2132
2133 (defun bookmark-next-marked ()
2134   (interactive)
2135   (let ((bb (get-buffer "*Bookmark List*"))
2136         pos)
2137     (when bb
2138       (with-current-buffer bb
2139         (setq pos (re-search-forward "^>" nil t))
2140         (unless pos
2141           (goto-char (point-min))
2142           (setq pos (re-search-forward "^>" nil t)))))
2143     (if pos
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"))))
2149
2150 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2151 ;;;; Org Mode
2152
2153 (defun ourcomments-org-complete-and-replace-file-link ()
2154   "If on a org file link complete file name and replace it."
2155   (interactive)
2156   (require 'org)
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)))
2164          type+link
2165          link-link
2166          link-link-beg
2167          link-link-end
2168          new-link
2169          dir
2170          ovl)
2171     (when (and on-link
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)))
2179         (unwind-protect
2180             (progn
2181               (setq ovl (make-overlay link-link-beg link-link-end))
2182               (overlay-put ovl 'face 'highlight)
2183               (when link-link
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))
2194                 t))
2195           (delete-overlay ovl)
2196           (goto-char here))))))
2197
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
2205 ;; file.
2206 ;; Tip: You can use the Firefox plugin Copy as HTML Link, see URL
2207 ;;      `https://addons.mozilla.org/en-US/firefox/addon/2617'.
2208 ;; "
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))))
2214
2215 ;; (defun ourcomments-org-convert-html-link (html-link)
2216 ;;   (let (converted url str)
2217 ;;     (save-match-data
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))))
2224 ;;     (when converted
2225 ;;       html-link)))
2226
2227 (defconst ourcomments-org-paste-html-link-regexp
2228   "\\`\\(?:<a [^>]*?href=\"\\(.*?\\)\"[^>]*?>\\([^<]*\\)</a>\\)\\'")
2229
2230 ;;(string-match-p ourcomments-org-paste-html-link-regexp "<a href=\"link\">text</a>")
2231
2232 ;;(defvar temp-n 0)
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
2236
2237    <a href=\"http://my.site.org/\">My Site</a>
2238
2239 that starts at BEG and ends at END then convert it to this
2240
2241    [[http://my.site.org/][My Site]]
2242
2243 If the URL is to a local file and the buffer is visiting a file
2244 make the link relative.
2245
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)
2249     (save-match-data
2250       (let ((here (copy-marker (point)))
2251             url str converted
2252             lit-beg lit-end)
2253         (goto-char beg)
2254         (save-restriction
2255           (widen)
2256           (setq lit-beg (search-backward "#+BEGIN" nil t))
2257           (when lit-beg
2258             (goto-char lit-beg)
2259             (setq lit-end (or (search-forward "#+END" nil t)
2260                               (point-max)))))
2261         (when (or (not lit-beg)
2262                   (> beg lit-end))
2263           (goto-char beg)
2264           (when (save-restriction
2265                   (narrow-to-region beg end)
2266                   (looking-at ourcomments-org-paste-html-link-regexp))
2267             (setq converted t)
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
2271             ;; have a buffer.
2272             (when (and (buffer-file-name)
2273                        (> (length url) 5)
2274                        (string= (substring url 0 6) "file:/"))
2275               (let ((abs-file-url
2276                      (if (not (memq system-type '(windows-nt ms-dos)))
2277                          (substring url 8)
2278                        (if (string= (substring url 0 8) "file:///")
2279                            (substring url 8)
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)))
2287         (goto-char here)
2288         nil))))
2289
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'.
2294
2295 Each function in this hook is called with two parameters, the
2296 start and end of the pasted text, until a function returns
2297 non-nil.")
2298 (add-hook 'ourcomments-paste-with-convert-hook 'ourcomments-org-convert-html-links-in-buffer)
2299
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)))
2305
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
2310                                 ,adv-name)
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)))))
2319
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)
2325
2326 ;;;###autoload
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
2332 the original text.
2333
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.)
2337
2338 Tip: The Firefox plugin Copy as HTML Link is handy, see URL
2339      `https://addons.mozilla.org/en-US/firefox/addon/2617'.
2340
2341 Note: This minor mode will defadvice the paste commands."
2342   :global t
2343   :group 'cua
2344   :group 'viper
2345   :group 'ourcomments-util
2346   (if ourcomments-paste-with-convert-mode
2347       (progn
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))))
2353
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)
2359
2360
2361
2362 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2363 ;;;; Menu commands to M-x history
2364
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)
2385                  this-command)))))
2386
2387 ;;;###autoload
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).
2393
2394 Only commands that are not already in M-x history are added."
2395   :global t
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)))
2399
2400 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2401 ;;;; Warnings etc
2402
2403 (defvar ourcomments-warnings nil)
2404
2405 (defun ourcomments-display-warnings ()
2406   (condition-case err
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))))
2411
2412 (defun ourcomments-warning-post ()
2413   (condition-case err
2414       (run-with-idle-timer 0.5 nil 'ourcomments-display-warnings)
2415     (error (message "ourcomments-warning-post: %s" err))))
2416
2417 ;;;###autoload
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))
2422
2423
2424
2425 (provide 'ourcomments-util)
2426 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2427 ;;; ourcomments-util.el ends here