emacs_el/tiny-tools/tiny/tinyadvice.el

   1 ;;; tinyadvice.el --- Collection of adviced functions
   2
   3 ;; This file is not part of Emacs
   4
   5 ;;{{{ Id
   6
   7 ;; Copyright (C)    1996-2007 Jari Aalto
   8 ;; Keywords:        extensions
   9 ;; Author:          Jari Aalto
  10 ;; Maintainer:      Jari aalto
  11 ;;
  12 ;; To get information on this program, call M-x tinyadvice-version.
  13 ;; Look at the code with folding.el.
  14
  15 ;; COPYRIGHT NOTICE
  16 ;;
  17 ;; This program is free software; you can redistribute it and/or modify it
  18 ;; under the terms of the GNU General Public License as published by the Free
  19 ;; Software Foundation; either version 2 of the License, or (at your option)
  20 ;; any later version.
  21 ;;
  22 ;; This program is distributed in the hope that it will be useful, but
  23 ;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
  24 ;; or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  25 ;; for more details.
  26 ;;
  27 ;; You should have received a copy of the GNU General Public License
  28 ;; along with program; see the file COPYING. If not, write to the
  29 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  30 ;; Boston, MA 02110-1301, USA.
  31 ;;
  32 ;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
  33
  34 ;;}}}
  35 ;;{{{ Install
  36
  37 ;;; Install:
  38
  39 ;; ....................................................... &t-install ...
  40 ;; Put this file on your Emacs-Lisp load path, add following into your
  41 ;; ~/.emacs startup file.
  42 ;;
  43 ;;     (require 'tinyadvice)
  44 ;;
  45 ;; Loading this package takes lot of time. You might gain more comfortable
  46 ;; Emacs startup "feel" using the following autoload suggestion:
  47 ;;
  48 ;;     (require 'tinylib)
  49 ;;     (when (ti::emacs-p)                           ;Do not load in XEmacs
  50 ;;       (if (fboundp 'run-with-idle-timer)      ;Emacs
  51 ;;           (run-with-idle-time (* 4 60) nil '(lambda () (require 'tinyadvice)))
  52 ;;         (run-at-time "4 min" nil '(lambda () (require 'tinyadvice)))))
  53 ;;
  54 ;; But before you leap into this, make sure you want to do it.
  55 ;;
  56 ;;      CHECK IF YOUR EMACS IS SUPPORTED
  57 ;;      THESE ADVICES ARE FOR Emacs, expect trouble in XEmacs.
  58 ;;
  59 ;;      Change `tinyadvice-:re' to try advices in non-supported Emacs versions
  60 ;;
  61 ;; This file modifies original Emacs functions, so read the document
  62 ;; carefully to tailor this package for you (enabling/disabling advices)
  63 ;; The best up to date documentation can be generated from this file:
  64 ;;
  65 ;;      M-x eval-current-buffer
  66 ;;      M-x load-library tinyliby.el
  67 ;;      M-x ti::system-get-file-documentation RET tinyadvice.el RET
  68 ;;
  69 ;; If you have any questions, use this function
  70 ;;
  71 ;;      M-x tinyadvice-submit-bug-report      send bug report or feedback
  72 ;;
  73
  74 ;;}}}
  75
  76 ;;{{{ Documentation
  77
  78 ;; ..................................................... &t-commentary ...
  79
  80 ;;; Commentary:
  81
  82 ;;  Preface, Apr 1996
  83 ;;
  84 ;;      What you see here is a selection of adviced functions that have
  85 ;;      proven to be extremely useful. Some of them have been written by
  86 ;;      the author (if there is no author mentioned) and some of them have
  87 ;;      been collected form the emacs newsgroups.
  88 ;;
  89 ;;      Here is one example how to to fontify automatically, whenever
  90 ;;      compilation buffer runs:
  91 ;;
  92 ;;          (add-hook 'tinyadvice-:compile-internal-hook 'my-compile-font-lock)
  93 ;;
  94 ;;          (defun my-compile-font-lock  ()
  95 ;;            "Compile buffer fontifying immediately."
  96 ;;            (interactive)
  97 ;;            (let* ((buffer tinyadvice-:compile-internal-buffer))
  98 ;;              ;; According to buffer you could set up different font
  99 ;;              ;; keyword parameters, say for
 100 ;;              ;; *compilation*
 101 ;;              ;; *grep*
 102 ;;              ;; *igrep*
 103 ;;              ;; ...
 104 ;;              ;;  My setup automatically turn on the lazy-lock too, see
 105 ;;              ;;  font-lock-mode-hook
 106 ;;              (with-current-buffer
 107 ;;               buffer
 108 ;;                (turn-on-font-lock-mode))))
 109 ;;
 110 ;;  Note: XEmacs
 111 ;;
 112 ;;      These advices are for Emacs and it would be a surprise if they
 113 ;;      worked in XEmacs. Use at your own risk. Send fixed XEmacs
 114 ;;      compatible advices to maintained if you try them.
 115 ;;
 116 ;;  These advises and Emacs releases
 117 ;;
 118 ;;      Many of these enhancements could have shipped with the Emacs
 119 ;;      itself. And there was a time when these were suggested to be added
 120 ;;      to the next Emacs release. For some reason the developers
 121 ;;      were not interested in the features at that time.
 122 ;;
 123 ;;  How to use this package
 124 ;;
 125 ;;      The best way is to load this package, print the whole file and read
 126 ;;      the comments about individual functions and how they change things.
 127 ;;
 128 ;;  Overview of features
 129 ;;
 130 ;;      In general, advices are activated only if Emacs release doesn't have
 131 ;;      similar kind of support.
 132 ;;
 133 ;;      o   `gud' highlights full line
 134 ;;      o   no dialogs in X for `y-or-n-p' styled questions. You shouldn't
 135 ;;          need to lift your hands from keyboard and grab mouse for these
 136 ;;          dialog questions.
 137 ;;      o   Mouse-3 cinfirms window delete (pointing at the mode line)
 138 ;;      o   `call-last-kbd-macro' ends the current macro
 139 ;;          before trying to execute it.
 140 ;;      o   `debugger-eval-expression',  Backtrace buffer's
 141 ;;           "e" offers current word for prompt
 142 ;;      o   `dired-man'       , make sure variables are initialized.
 143 ;;      o   `dired-do-rename' , you can edit the old filename
 144 ;;      o   `goto-line' and `imenu' now widens automatically before executing
 145 ;;      o   `rename-buffer'   , offers old buffer name for editing
 146 ;;      o   `recover-file'    , offers buffer filename by default
 147 ;;      o   `switch-to-buffer-other-frame' , selects some non existing frame
 148 ;;      o   `setenv'          , offer completion
 149 ;;      o   `write-file'      , confirm overwrite
 150 ;;      o   `write-region'    , confirm overwrite
 151 ;;
 152 ;;      o   `C-x' `;'   , `indent-for-comment' negative arg deletes comment.
 153 ;;      o   `C-x' `='   , `what-cursor-position' shows the line number too
 154 ;;      o   `C-x' `i'   , insert buffer offers other window
 155 ;;      o   `C-x' `C-c' , `save-buffers-kill-emacs' asks confirmation
 156 ;;                        to prevent accidents (Emacs 21 has this)
 157 ;;      o   `C-x' `b'   , `swich-to-buffer' ask confirmation
 158 ;;                        for non-existing buffers.
 159 ;;      o   `C-x' `C-b' , list-buffers puts cursor to "*Buffer List*"
 160 ;;
 161 ;;      o   compilation: buffer auto scroll (disabled, see 'handling advices')
 162 ;;          Smart save feature (only .cc .h files, not
 163 ;;          all emacs files). Find-file is done in non dedicated frame.
 164 ;;          TAB completes filenames.
 165 ;;
 166 ;;      o   completion:  case sensitive filename completion
 167 ;;
 168 ;;      o   grep: filename and directory completion with TAB key
 169 ;;
 170 ;;      o   `vc-print-log', put cursor on the buffer's revision number.
 171 ;;          Smarter `vc-mode-line' , shows "b" if version is in the middle.
 172 ;;          `vc-register' creates RCS directory if does not exist and
 173 ;;          offers checking as "original" file with existing version
 174 ;;          numbers (tracking 3rd party sources).
 175 ;;          User to set the initial comment when doing 1st CI.
 176 ;;          If `tinyadvice-:cvs-buffer-read-only' is nil, then keep.
 177 ;;          CVS files in writable mode (the default CVS behavior)
 178 ;;
 179 ;;  Handling advices
 180 ;;
 181 ;;      If you have some other emacs version that is not supported in
 182 ;;      the `tinyadvice-:advice-table' you can modify the regexps in
 183 ;;      the list and try if the advice works in your emacs. If it
 184 ;;      does, please drop me a mail immediately and I update the
 185 ;;      regexp. If some advice annoys you, there is simple method how
 186 ;;      you disable advice(s).
 187 ;;
 188 ;;          (setq tinyadvice-load-hook
 189 ;;                '(tinyadvice-install my-tinyadvice-load-hook))
 190 ;;
 191 ;;          (defun my-tinyadvice-load-hook ()
 192 ;;            "Configure 'tiny tool's advices' to my taste."
 193 ;;            (interactive)
 194 ;;            ;; This diables two advices
 195 ;;            (tinyadvice-advice 'disable
 196 ;;               '(switch-to-buffer mouse-delete-other-windows)))
 197 ;;          (require 'tinyadvice)
 198 ;;
 199 ;;  Disabling disturbing advice by hand
 200 ;;
 201 ;;      If some piece of advice disturbs or causes trouble in your
 202 ;;      current emacs session, you can deactivate it
 203 ;;      immediately. First you have to know the function name that
 204 ;;      generates problems. Say you used `C-x' `C-b'
 205 ;;      `switch-to-buffer' and you don't like the confirmation for
 206 ;;      non-existent buffers. You can disable this behavior by
 207 ;;      calling:
 208 ;;
 209 ;;          C-u M-x tinyadvice-advice
 210 ;;
 211 ;;      and giving the function name `switch-to-buffer' to it. To
 212 ;;      permanently turn it off in your emacs sessions, see previous
 213 ;;      lisp code.
 214 ;;
 215 ;;  Code note
 216 ;;
 217 ;;      You see this in the code:
 218 ;;
 219 ;;          (when (tinyadvice-activate-p)
 220 ;;              (defadvice ..
 221 ;;
 222 ;;      If emacs version is wrong, the advice is _never_ actually
 223 ;;      assembled.  You can't activate or deactivate this function
 224 ;;      with `tinyadvice-advice'.
 225 ;;
 226 ;;  Many thanks to, in no particular order:
 227 ;;
 228 ;;      Vladimir Alexiev        <vladimir@cs.ualberta.ca>
 229 ;;      Kevin    Rodgers        <kevinr@ihs.com>
 230 ;;      Ilya     Zakharevich    <ilya@math.ohio-state.edu>
 231 ;;      Peter    Breton         <pbreton@i-kinetics.com>
 232 ;;      T. V.    Raman          <raman@adobe.com>
 233
 234 ;;}}}
 235
 236 ;;; Change Log:
 237
 238 ;;; Code:
 239
 240 ;;{{{ setup: require
 241
 242 ;;; ......................................................... &require ...
 243
 244 (require 'advice)
 245 (require 'tinylibm)
 246
 247 (eval-and-compile
 248   (defvar vc-parent-buffer)             ;Emacs vc.el
 249   (defvar grep-command)
 250   (defvar grep-default)
 251   (defvar grep-history)
 252   (autoload 'grep-compute-defaults "compile")
 253   (when (ti::xemacs-p)
 254     (message "\
 255 ** TinyAdvice: You must configure this package manually to XEmacs
 256                In general, do not use this packaage on XEmacs.")
 257     (load "overlay" 'noerr)))           ;19.15+
 258
 259 ;;}}}
 260 ;;{{{ setup: public
 261
 262 ;;; ......................................................... &v-hooks ...
 263
 264 (defvar tinyadvice-load-hook '(tinyadvice-install)
 265   "Hook that is run when package is loaded.")
 266
 267 ;;; ........................................................ &v-public ...
 268
 269 (defvar tinyadvice-:cvs-buffer-read-only t
 270   "*nil makes CVS buffers writable.  Value t preserves vc.el's decision.
 271 Many times vc.el sets read-only status to CVS buffers when there is no need.
 272 In default case, CVS itself does not mark files read-only, unlike RCS.
 273 But if you do \"cvs watch on\" on a tree then when you do \"cvs co tree\" it
 274 will check files out read-only. You have to do \"cvs edit\" to make them
 275 writable.
 276
 277 Setting this variable to nil, will override vc.el and
 278 keep CVS buffers always writable. The t value preserves what vc.el does.")
 279
 280 (defvar tinyadvice-:compile-internal-hook nil
 281   "*Hook run after `compile-internal' funtion.
 282 You can peek variable `tinyadvice-:compile-internal-buffer' too.")
 283
 284 (defvar tinyadvice-:compile-save-re
 285   "\\(\\.hh?\\|\\.cc?\\|\\.C?\\|\\.java\\)$"
 286   "*Regexp. Case sensitive. Which buffers to save when compiling.")
 287
 288 (defvar tinyadvice-:gud-overlay
 289   (when (and (ti::emacs-p)
 290              (not (fboundp 'make-extent)))
 291     (let* ((ov (make-overlay (point-min) (point-min))))
 292       (overlay-put ov 'face 'highlight)
 293       ov))
 294   "*Gud. Current line overlay.")
 295
 296 (defvar tinyadvice-:find-alternate-file-flag  t
 297   "*Non-nil means : `buffer-name' in \\[find-file] if no `buffer-file-name'.")
 298
 299 ;;  Ignore tmp/ dir files
 300 ;;  like ~/T  ~/TT ~/T1 ~/T2 ~/T.test ~/T1.xx ...
 301
 302 (defconst tinyadvice-:write-file-no-confirm
 303   "^/tmp\\|/[Tt][Tt0-9]?\\.?\\|/[Tt]$"
 304   "*Do not verify overwriting these files. See advice `write-file'.")
 305
 306 (defvar tinyadvice-:switch-to-buffer-find-file  t
 307   "*Suggest `find-file' for non-existing buffers in `switch-to-buffer'.")
 308
 309 (defvar tinyadvice-:vc-main-rcs-dir  "~/RCS"
 310   "Main RCS repository. See advice of function `vc-register'.")
 311
 312 ;;; ........................................................ &v-advice ...
 313
 314 (defvar tinyadvice-:re "19\\.2[7-9]\\|19\\.3[0-5]\\|2[01]\\."
 315   "General regexp for advices that work in variety of (X)Emacs versions.")
 316
 317 ;; - Change the REGEXP is you know the advice works in your emacs ver.
 318 ;;   Drop me mail if you change any of these, so that I can update list
 319 ;;
 320 ;; - Functions that have ".", almost always get advice, see the code.
 321 ;;   In those rows the regexp value is almost always ignored.
 322 ;;
 323 ;; - If it says ";; always on", then the regexp has no effect,
 324 ;;   you have to disable feature by hand, if you don't want it.
 325
 326 (defconst tinyadvice-:advice-table      ;alphabetically ordered
 327   (list
 328    (list 'after-find-file               ".")    ;;always on
 329    (list 'ange-ftp-dired-run-shell-command ".") ;;always on
 330
 331    (list 'call-last-kbd-macro
 332          ".")
 333    (list 'compile                       ".")
 334    (list 'compile-internal              "2[7-9]") ;;fixed 19.30+
 335    (list 'compilation-find-file         ".")
 336    (list 'shell                         ".")
 337
 338    (list 'debugger-eval-expression      ".")
 339
 340    (list 'dired-do-rename               ".")
 341    (list 'dired-man                     ".") ;;always
 342    (list 'display-time-process-this-message "19" 'xe)
 343
 344    (list 'exchange-point-and-mark       ".")
 345    (list 'find-file                     ".")
 346
 347    (list 'grep                          ".")
 348    (list 'igrep-read-expression         ".")
 349    (list 'igrep-read-options            ".")
 350
 351    (list 'find-alternate-file           ".")
 352    (list 'find-file-literally           ".")
 353    (list 'find-tag                      ".")
 354    (list 'fill-paragraph                "19\.2[0-8]")
 355
 356    (list 'getenv                        ".") ;;always on
 357    (list 'goto-line                     ".")
 358    (list 'grep                          ".")
 359    (list 'gud-display-line              ".") ;;always
 360
 361    (list 'hkey-help-show                ".") ;;hyberbole
 362
 363    (list 'imenu                         ".") ;; always
 364    (list 'indent-for-comment            ".")
 365    (list 'insert-buffer                 tinyadvice-:re)
 366    (list 'Info-build-node-completions   "19\\.\\|20\\.")
 367    (list 'list-buffers                  ".")
 368    (list 'line-move                     ".")
 369
 370    (list 'map-y-or-n-p                  tinyadvice-:re)
 371    (list 'mouse-delete-other-windows    tinyadvice-:re)
 372    (list 'mouse-delete-window           tinyadvice-:re)
 373    (list 'mouse-wheel-scroll-screen     tinyadvice-:re)
 374
 375    (list 'occur                         ".")
 376    (list 'PC-complete                   ".") ;;always on
 377
 378    (list 'recompile                     ".")
 379    (list 'recover-file                  ".")
 380    (list 'rename-buffer                 tinyadvice-:re)
 381
 382    (list 'save-buffers-kill-emacs       (if (boundp 'confirm-kill-emacs)
 383                                             ;; Do not install in Eamcs 21.x
 384                                             nil
 385                                           "19\\."))
 386    (list 'save-some-buffers             ".")
 387    (list 'sendmail-pre-abbrev-expand-hook tinyadvice-:re)
 388    (list 'setenv                        ".") ;;always on
 389    (list 'set-mark-command              ".") ;;always on
 390    (list 'switch-to-buffer              tinyadvice-:re)
 391    (list 'switch-to-buffer-other-frame  ".")
 392
 393    (list 'vc-do-command                 tinyadvice-:re)
 394    (list 'vc-mode-line                  tinyadvice-:re)
 395    (list 'vc-print-log                  "2[89]\\|3[01]") ;;fixed in 19.32
 396    (list 'vc-register                   "19\\.\\|20\\.") ;;fixed in 21.x
 397
 398    (list 'what-cursor-position          tinyadvice-:re)
 399    (list 'write-file                    ".")
 400    (list 'write-region                  ".")
 401
 402    (list 'y-or-n-p                      tinyadvice-:re))
 403   "*Flag table of enabled advices.
 404 It is consulted if particular advice can be used in current emacs. Format is
 405
 406   ((FUNCTION ALLOW-ADVICE-REGEXP [FLAG])
 407    (FUNCTION ALLOW-ADVICE-REGEXP)
 408    ..)
 409
 410 The FLAG is optional and values can be:
 411
 412   nil   or missing: Only works in Emacs
 413   'xe   only works in Xemacs
 414   t     works both Emacs and XEmacs")
 415
 416 ;;}}}
 417 ;;{{{ setup: private
 418
 419 ;;; ....................................................... &v-private ...
 420
 421 (defconst tinyadvice-:advice-re  "^tinyadvice"
 422   "Prefix name used in advices for TinyAdvice package.")
 423
 424 (defconst tinyadvice-:tmp-buffer  "*tinyadvice*"
 425   "Temporary working buffer.")
 426
 427 (defvar tinyadvice-:compile-internal-buffer  nil
 428   "The compilation buffer created by `compile-internal'.")
 429
 430 (defvar tinyadvice-:vc-p nil
 431   "Variable indicating if file in `vc-do-command' is version controlled.")
 432
 433 ;;}}}
 434 ;;{{{ version
 435
 436 ;;; ....................................................... &v-version ...
 437
 438 ;;;###autoload (autoload 'tinyadvice-version "tinyadvice" "Display commentary." t)
 439 (eval-and-compile
 440   (ti::macrof-version-bug-report
 441    "tinyadvice.el"
 442    "tinyadvice"
 443    tinyadvice-:version-id
 444    "$Id: tinyadvice.el,v 2.71 2007/05/07 10:50:07 jaalto Exp $"
 445    '(tinyadvice-version-id
 446      tinyadvice-:compile-save-re
 447      tinyadvice-:write-file-no-confirm
 448      tinyadvice-:re)))
 449
 450 ;;}}}
 451
 452 ;;; ########################################################### &Funcs ###
 453
 454 ;;{{{ tinyadvice: misc
 455
 456 ;;; ----------------------------------------------------------------------
 457 ;;;
 458 (defmacro tinyadvice-elts (elt func re type)
 459   "Decode ELT to variables FUNC RE TYPE."
 460   (`
 461    (setq (, func) (nth 0 (, elt))
 462          (, re)   (nth 1 (, elt))
 463          (, type) (if (eq 3 (length (, elt)))
 464                       (nth 0 (, elt))
 465                     nil))))
 466
 467 ;;; ----------------------------------------------------------------------
 468 ;;;
 469 (defun tinyadvice-match (re &optional type)
 470   "Check if RE match emacs version according to TYPE.
 471 TYPE :
 472   nil = Emacs
 473   t   = XEmacs and Emacs
 474   'xe = XEmacs"
 475   (let* ((ver   (emacs-version))
 476          ret)
 477     (when (stringp re)
 478       (cond
 479        ((and (eq type 'xe)
 480              (ti::xemacs-p)
 481              (string-match re ver))
 482         (setq ret 1))
 483        ((and (eq type nil)
 484              (ti::emacs-p)
 485              (string-match re ver))
 486         (setq ret 2))
 487        ((and (eq type t)
 488              (string-match re ver))
 489         (setq ret 3)))
 490       ret)))
 491
 492 ;;; ----------------------------------------------------------------------
 493 ;;; Testing... (tinyadvice-activate-p 'compile-internal)
 494 ;;;
 495 (defun tinyadvice-activate-p (func-sym)
 496   "Determine if we can advice FUNC-SYM."
 497   (let* ((elt   (assoc func-sym tinyadvice-:advice-table))
 498          func
 499          re
 500          type)
 501     (when elt
 502       (tinyadvice-elts elt func re type)
 503       ;;  XEmacs 19.14 ByteComp, Shut up "bound but not referenced"
 504       ;;  the `func' is set above.
 505       (if func
 506           (setq func 'ignore))
 507       (tinyadvice-match re type))))
 508
 509 ;;; ----------------------------------------------------------------------
 510 ;;;
 511 (defun tinyadvice-ad-function-list  (&optional string-format)
 512   "Return list of tinyadvice ad-functions for current emacs.
 513 Notice: all functions may not be adviced; this merely
 514 return entries in the table. See source file's \"Code note\"
 515
 516 If STRING-FORMAT is non nil, then return string list.
 517
 518 Return:
 519
 520   '(func    func ..)
 521   '(\"func\" \"func\" ..)"
 522   (let* (func
 523          re
 524          type
 525          list)
 526     (dolist (member tinyadvice-:advice-table)
 527       (tinyadvice-elts member func re type)
 528       (when (tinyadvice-match re type)
 529         (if  string-format
 530             (push (symbol-name func) list)
 531           (push func list))))
 532     list))
 533
 534 ;;; ----------------------------------------------------------------------
 535 ;;;
 536 (defun tinyadvice-install  ()
 537   "Activates advices that are listed in `tinyadvice-:advice-table'."
 538   (interactive)
 539   (tinyadvice-advice nil (tinyadvice-ad-function-list)))
 540
 541 ;;; ----------------------------------------------------------------------
 542 ;;;
 543 ;;; This is slow, but returns only tinyadvice adviced functions...
 544 ;;;
 545 ;;; (ad-do-advised-functions (func)
 546 ;;;  (if (ad-find-some-advice func 'any tinyadvice-:advice-re)
 547 ;;;      (push func list)))
 548 ;;;
 549 ;;;
 550 (defun tinyadvice-advice (&optional disable func-or-list)
 551   "Activate or optionally DISABLE tinyadvice advice for FUNC-OR-LIST."
 552   (interactive
 553    (list
 554     current-prefix-arg
 555
 556     (let* (var)
 557       (setq var (completing-read
 558                  (concat
 559                   (if current-prefix-arg "un"  "")
 560                   "advice function: ")
 561                  (ti::list-to-assoc-menu (tinyadvice-ad-function-list 'strings))
 562                  nil t))
 563       (intern-soft var))))
 564   ;; This is in fact cheating a little; we check against full advice list,
 565   ;; not just "tinyadvice" owned functions.
 566   (when (and (symbolp func-or-list)
 567              (not (member (list (symbol-name func-or-list))
 568                           ad-advised-functions )))
 569     ;; This makes the call to 'ti::' after this if, unefective
 570     (setq func-or-list nil)
 571     (if (interactive-p)
 572         ;; more accurate: "No advice found..." but since we deal with
 573         ;; tinyadvice ones only the following is better.
 574         (message "\
 575 TinyAdvice: Sorry, the function is not advice controlled by TinyAdvice.")))
 576   (ti::advice-control
 577    func-or-list tinyadvice-:advice-re disable (interactive-p)))
 578
 579 ;;; ----------------------------------------------------------------------
 580 ;;;
 581 (defun tinyadvice-advice-control  (&optional disable verb)
 582   "Acivate all TinyAdvice advices. Use extra argument to DISABLE all. VERB."
 583   (interactive "P")
 584   (or verb
 585       (setq verb (interactive-p)))
 586   (let* (
 587          (re    tinyadvice-:advice-re)
 588          (doit  t)
 589          msg)
 590     (if verb ;;  This is rough! Be sure...
 591         (setq
 592          doit
 593          (y-or-n-p (format
 594                     "Advices will be turned %s. Are you sure? "
 595                     (if disable "OFF" "ON")))))
 596     (when doit
 597       (cond
 598        (disable
 599         (ad-disable-regexp re)          ;only sets flag
 600         (setq msg "Tinyadvice: All advices deactivated"))
 601        (t
 602         (ad-enable-regexp re)           ;only sets flag
 603         (setq msg "Tinyadvice: All TinyAdvice advices activated")))
 604       (ad-update-regexp re)
 605       (if verb
 606           (message msg)))))
 607
 608 ;;; ----------------------------------------------------------------------
 609 ;;;
 610 (defun tinyadvice-convert-filename  (file &optional cautious)
 611   "Return normal or compressed filename.
 612
 613 Input:
 614
 615  FILE       full filename
 616  CAUTIOUS   if non-nil then when in doubt do not change the filename.
 617             (e.g. in clash situation, where there is bot un/compressed  file)
 618
 619 Return:
 620
 621  string     possibly modified."
 622   (interactive)
 623   (unless (string-match "\\.Z$\\|\\.gz$"  file)
 624     (when (and (file-exists-p file)
 625                (or (file-exists-p (concat file ".gz"))
 626                    (file-exists-p (concat file ".Z"))))
 627       (message "TinyAdvice: clash, both un/compressed file found. %s " file)
 628       (sleep-for 1)
 629       (if (and
 630            (null cautious)              ;only if no cautious mode
 631            (setq
 632             file
 633             (or (ti::file-newer-exist file (concat file ".gz"))
 634                 (ti::file-newer-exist file (concat file ".Z")))))
 635           ;;  We must load this package too to enable compress support.
 636           (require 'jka-compr))))
 637   file)
 638
 639 ;;}}}
 640
 641 ;;{{{ ange-ftp
 642
 643 ;;; ----------------------------------------------------------------------
 644 ;;; log into the remote host as a different user (including root).
 645 ;;;
 646 (defadvice ange-ftp-dired-run-shell-command (before tinyadvice-rsh-cmd dis)
 647   "Launch rsh -l if needed."
 648   (setq ange-ftp-remote-shell-file-name
 649         (format "rsh -l %s" (nth 1 (ange-ftp-ftp-path default-directory)))))
 650
 651 ;;}}}
 652 ;;{{{ built-ins
 653
 654 ;;; ........................................................ &built-in ...
 655
 656 ;;; ----------------------------------------------------------------------
 657 ;;;
 658 (when (tinyadvice-activate-p 'rename-buffer)
 659   (defadvice rename-buffer (around tinyadvice dis)
 660     "Gives old buffer name for editing."
 661     (interactive
 662      (list
 663       (read-from-minibuffer
 664        "Rename buffer (to new name): "
 665        (buffer-name))))
 666     ad-do-it))
 667
 668 ;;}}}
 669 ;;{{{ compile
 670
 671 ;;; ......................................................... &compile ...
 672
 673 ;;; ----------------------------------------------------------------------
 674 ;;; (ad-disable-advice 'compilation-find-file 'before 'tinyadvice)
 675 ;;; (ad-activate       'compilation-find-file)
 676 ;;;
 677 (defadvice compilation-find-file  (before tinyadvice act)
 678   "Move to some non dedicated frame."
 679   (ti::select-frame-non-dedicated))
 680
 681 ;;; ----------------------------------------------------------------------
 682 ;;;
 683 (defadvice shell (around tinyadvice dis)
 684   "If there is *shell* buffer, ask user to give new name for new shell.
 685 If new buffer name is given, a new shell is created. pressing RET
 686 doe snot create new buffer, but jumps to existing *shell* buffer."
 687   (let* (name
 688          prev-name)
 689     (when (and
 690            (interactive-p)
 691            (comint-check-proc "*shell*")
 692            (setq
 693             name
 694             (read-string
 695              "Create new shell by typing a buffer name for it [RET = cancel]? "))
 696            (not (ti::nil-p name)))
 697       (with-current-buffer "*shell*"
 698         (rename-uniquely)
 699         (setq prev-name (buffer-name))))
 700     ad-do-it
 701     (when (and (stringp name)
 702                (not (string= name "")))
 703       (with-current-buffer "*shell*"
 704         (rename-buffer name))
 705       (with-current-buffer prev-name
 706         (rename-buffer "*shell*")))))
 707
 708 ;;; ----------------------------------------------------------------------
 709 ;;; See variable `compilation-last-buffer'
 710 ;;; - This has been reported to be corrected in 19.30
 711 ;;;
 712 (when (and (not (boundp 'compilation-scroll-output))
 713            (tinyadvice-activate-p 'compile-internal))
 714
 715   (defadvice compile-internal (after tinyadvice-scroll dis comp)
 716     "Force compile buffer to scroll."
 717     (let* ((ob (current-buffer))
 718            (obw  (get-buffer-window ob t))
 719            win)
 720       (save-excursion
 721         (unless (or (null (setq win (get-buffer-window ad-return-value t)))
 722                     (null obw))
 723           (select-window win)
 724           (goto-char (point-max))
 725           (select-window obw))))))
 726
 727 ;;; ----------------------------------------------------------------------
 728 ;;; "tap" -- listen secretly :-)
 729 ;;;
 730 (defadvice compile-internal (around tinyadvice-tap-buffer dis comp)
 731   "Save compile buffer name to 'tinyadvice-:compile-internal-buffer'.
 732 See `tinyadvice-:compile-internal-hook'."
 733   (prog1
 734       ad-do-it
 735     (setq tinyadvice-:compile-internal-buffer ad-return-value)))
 736
 737 ;;; ----------------------------------------------------------------------
 738 ;;;
 739 (defadvice compile-internal (after tinyadvice-run-hook last act comp)
 740   "Run hook 'tinyadvice-:compile-internal-hook'.
 741 E.g. you can add lazy-lock.el fontifying to that hook."
 742   (run-hooks 'tinyadvice-:compile-internal-hook))
 743
 744 ;;; ----------------------------------------------------------------------
 745 ;;;
 746 (defun tinyadvice-compile-save-buffers ()
 747   "Check what buffers for current compilation target should be saved."
 748   (interactive)
 749   (let* ((case-fold-search      nil)    ;case sensitive
 750          (re-file               tinyadvice-:compile-save-re))
 751
 752     ;; Save only interesting buffers, don't care about others.
 753     (ti::dolist-buffer-list
 754      (string-match re-file  (buffer-name))
 755      nil
 756      nil
 757      (and (buffer-modified-p)
 758           (y-or-n-p (format "Buffer %s modified. Save it? "
 759                             (buffer-name)))
 760           (save-buffer)))))
 761
 762 ;;; ----------------------------------------------------------------------
 763 ;;;
 764 (defadvice igrep-read-expression (around tinyadvice dis)
 765   "Replace function: TAB key completes file names."
 766   (setq
 767    ad-return-value
 768    (let ((default-expression (igrep-default-arg igrep-expression-default)))
 769      (if (string= default-expression "")
 770          (setq default-expression nil))
 771      (ti::file-complete-filename-minibuffer-macro
 772        (read-from-minibuffer (igrep-prefix prompt-prefix "Expression: ")
 773                              default-expression map nil
 774                              'igrep-expression-history)))))
 775
 776 ;;; ----------------------------------------------------------------------
 777 ;;;
 778 (defadvice igrep-read-options (around tinyadvice act)
 779   "Replace function: TAB key completes file names."
 780   (setq
 781    ad-return-value
 782    (if (or igrep-read-options
 783            (and (consp current-prefix-arg)
 784                 (memq (prefix-numeric-value current-prefix-arg)
 785                       '(4 64))))
 786        (let ((prompt "Options: "))
 787          (ti::file-complete-filename-minibuffer-macro
 788            (read-from-minibuffer
 789             (igrep-prefix prompt-prefix prompt)
 790             (or igrep-options "-")
 791             map)))
 792      igrep-options)))
 793
 794 ;;; ----------------------------------------------------------------------
 795 ;;;
 796 (defun tinyadvice-grep-default (arg)
 797   "Set default value. This function use dynamically bound variables.
 798 See `grep' advice."
 799   (unless grep-command
 800     (grep-compute-defaults))
 801   ;; `arg' is bound during M-x grep
 802   (when arg
 803     (let* ((tag-default
 804             (funcall (or find-tag-default-function
 805                          (get major-mode 'find-tag-default-function)
 806                          ;; We use grep-tag-default instead of
 807                          ;; find-tag-default, to avoid loading etags.
 808                          'grep-tag-default))))
 809       (setq grep-default (or (car grep-history) grep-command))
 810       ;; Replace the thing matching for with that around cursor
 811       (when (string-match "[^ ]+\\s +\\(-[^ ]+\\s +\\)*\\(\"[^\"]+\"\\|[^ ]+\\)\\(\\s-+\\S-+\\)?" grep-default)
 812         (unless (or (match-beginning 3) (not (stringp buffer-file-name)))
 813           (setq grep-default (concat grep-default "*."
 814                                      (file-name-extension buffer-file-name))))
 815         (setq grep-default (replace-match (or tag-default "")
 816                                           t t grep-default 2))))))
 817
 818 ;;; ----------------------------------------------------------------------
 819 ;;;
 820 (defadvice grep (around tinyadvice act)
 821   "Modify interactive spec: TAB key completes file names."
 822   (interactive
 823    (let (grep-default (arg current-prefix-arg))
 824      (tinyadvice-grep-default arg)
 825      (list (ti::file-complete-filename-minibuffer-macro
 826              (read-from-minibuffer "Run grep (like this): "
 827                                    (or grep-default
 828                                        grep-command)
 829                                    map nil 'grep-history)))))
 830   ad-do-it)
 831
 832 ;;; ----------------------------------------------------------------------
 833 ;;; - More smarter buffer saving.
 834 ;;;
 835 (defadvice compile (around tinyadvice dis)
 836   "Replace original function. More smarter buffer saving.
 837 See function `tinyadvice-compile-save-buffers'.
 838 In addition, TAB key completes file names."
 839   (interactive
 840    (if compilation-read-command
 841        (list (ti::file-complete-filename-minibuffer-macro
 842                (read-from-minibuffer "Compile command: "
 843                                      compile-command map nil
 844                                      '(compile-history . 1))))
 845      (list compile-command)))
 846   (setq compile-command command)
 847
 848   (if (null compilation-ask-about-save)
 849       (save-some-buffers (not compilation-ask-about-save) nil)
 850     (tinyadvice-compile-save-buffers))
 851
 852   (compile-internal compile-command "No more errors"))
 853
 854 ;;; ----------------------------------------------------------------------
 855 ;;; Run compile with the default command line
 856 ;;;
 857 (defadvice recompile (around tinyadvice dis)
 858   "Replace original function.
 859 More smarter buffer saving, seefunction `tinyadvice-compile-save-buffers'."
 860   (interactive)
 861   (if (null compilation-ask-about-save)
 862       (save-some-buffers (not compilation-ask-about-save) nil)
 863     (tinyadvice-compile-save-buffers))
 864   (compile-internal compile-command "No more errors"))
 865
 866 ;;}}}
 867 ;;{{{ completion and macros
 868
 869 ;;; ...................................................... &completion ...
 870
 871 ;;; ----------------------------------------------------------------------
 872 ;;;
 873 (defadvice call-last-kbd-macro (before tinyadvice dis)
 874   "If still defining a macro, end it before attempting to call-last.
 875   This prevents whacking the current definition."
 876   (if defining-kbd-macro
 877       (end-kbd-macro)))
 878
 879 ;;; ----------------------------------------------------------------------
 880 ;;;
 881 (defadvice PC-complete  (around tinyadvice dis)
 882   "In file name prompt, use case sensitive completion.
 883 Set `completion-ignore-case' locally to nil."
 884   (let* ((completion-ignore-case  completion-ignore-case)
 885          word)
 886     (setq word (or (save-excursion (ti::buffer-read-space-word)) ""))
 887
 888     (if (string-match "^[/~]" word)
 889         (setq completion-ignore-case nil))
 890     ad-do-it))
 891
 892 ;;}}}
 893
 894 ;;{{{ debugger
 895
 896 ;;; -------------------------------------------------------- &debugger ---
 897 ;;;
 898 (defadvice debugger-eval-expression (around tinyadvice dis)
 899   "Chnage interactive so that it offer word from buffer."
 900   (interactive
 901    (list
 902     (read-from-minibuffer
 903      "(tinyadvice) Eval: "
 904      (or (ti::buffer-read-space-word) "")
 905      read-expression-map t
 906      'read-expression-history)))
 907   ad-do-it)
 908
 909 ;;}}}
 910 ;;{{{ dired
 911
 912 ;;; ........................................................... &dired ...
 913
 914 ;;; ----------------------------------------------------------------------
 915 ;;;
 916 (defadvice dired-mark-read-file-name (around tinyadvice dis)
 917   "Instead of asking directory, offer full filename for editing."
 918   (if (and dir (string-match "/" dir))
 919       (setq dir (dired-get-filename)))
 920   ad-do-it)
 921
 922 ;;; ----------------------------------------------------------------------
 923 ;;;
 924 (defadvice dired-do-rename  (around tinyadvice act)
 925   "Offer editing the current filename.
 926 Without this advice you don't get the old filename for editing.
 927 Activates advice 'dired-mark-read-file-name during call."
 928   (let* ((ADVICE 'dired-mark-read-file-name))
 929     (ad-enable-advice ADVICE 'around 'tinyadvice)
 930     (ad-activate ADVICE)
 931     ad-do-it
 932     (ad-disable-advice ADVICE 'around 'tinyadvice)
 933     (ad-activate ADVICE)))
 934
 935 ;;; ----------------------------------------------------------------------
 936 ;;;
 937 (defadvice dired-man (before tinyadvice dis)
 938   "Make sure man variables are initialized."
 939   (require 'man)
 940   (Man-init-defvars))
 941
 942 ;;}}}
 943
 944 ;;{{{ env
 945
 946 ;;; ............................................................. &env ...
 947
 948 ;;; ----------------------------------------------------------------------
 949 ;;;
 950 (defun tinyadvice-read-envvar (prompt &optional require-match)
 951   "Read an environment variable name from the minibuffer.
 952 Prompt with PROMPT and complete from `process-environment'.
 953 If optional arg REQUIRE-MATCH is non-nil, only defined variable
 954 names are allowed."
 955   (completing-read
 956    prompt
 957    (mapcar (function
 958             (lambda (var=value)
 959               (list (substring var=value 0
 960                                (string-match "=" var=value)))))
 961            process-environment)
 962    nil
 963    require-match))
 964
 965 ;;; ----------------------------------------------------------------------
 966 ;;;
 967 ;;; Hangs sometimes, don't know why..
 968 ;;; Currently owned by "my" and disabled. Enable this manyally in load-hook
 969 ;;; if you want to try it.
 970 ;;;
 971 (defadvice getenv (around my dis)
 972   "Offer completion."
 973   (interactive (list (tinyadvice-read-envvar "Get environment variable: " t)))
 974   ad-do-it
 975   (if (and (interactive-p)
 976            ad-return-value)
 977       (message "%s" ad-return-value)
 978     ad-return-value))
 979
 980 ;;; ----------------------------------------------------------------------
 981 ;;;
 982 (defadvice setenv (around tinyadvice dis)
 983   "Add interactive completion."
 984   (interactive
 985    (if current-prefix-arg
 986        (list (tinyadvice-read-envvar "Clear environment variable: " t) nil t)
 987      (let ((var (tinyadvice-read-envvar "Set environment variable: ")))
 988        (list var
 989              (read-from-minibuffer
 990               (format "Set %s to value: " var)
 991               (or (getenv var) ""))))))
 992   ad-do-it
 993   (if (and (interactive-p) value)
 994       (message "%s" value)
 995     value))
 996
 997 ;;}}}
 998 ;;{{{ grep, tag
 999
1000 ;;; ------------------------------------------------------------ &grep ---
1001 ;;;
1002 (defadvice grep  (around tinyadvice  dis)
1003   "Complete filenames with TAB.
1004 Read word from the current pointand put it into grep prompt."
1005   (interactive
1006    (ti::file-complete-filename-minibuffer-macro
1007      (list
1008       (read-from-minibuffer
1009        "(tinyadvice) Run grep: "
1010        (concat grep-command  (or (ti::buffer-read-space-word) ""))
1011        map
1012        nil
1013        'grep-history))))
1014   ad-do-it)
1015
1016 ;;; ----------------------------------------------------------------------
1017 ;;;
1018 (defadvice find-tag (after tinyadvice-reposition-window act)
1019   "Call reposition-window after finding a tag."
1020   (reposition-window))
1021
1022 ;;}}}
1023
1024 ;;{{{ files.el
1025
1026 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1027 ;;;
1028 ;;;                         files.el
1029 ;;;
1030 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1031
1032 ;;; ----------------------------------------------------------------------
1033 ;;; ANGE things...
1034 ;;; - Ange ftp gets "listing" when it tries to guess if the file
1035 ;;;   exists or if it's new file. The listing is produced with the call
1036 ;;;   `insert-file-contents'
1037 ;;;
1038 ;;; find-file-noselect (filename &optional nowarn)
1039 ;;;  ...
1040 ;;;  ange-ftp-insert-file-contents
1041 ;;;    ..file-exists-p
1042 ;;;
1043 (defadvice after-find-file (around tinyadvice-file dis)
1044   "Suppress call if no `buffer-file-name'. This may happen with ange-ftp."
1045   (if buffer-file-name
1046       ad-do-it))
1047
1048 ;;; ----------------------------------------------------------------------
1049 ;;;
1050 (defadvice find-file-literally
1051   (around  tinyadvice-disable-write-file-hooks dis)
1052   "Disable `write-file-hooks' so that file can edited and saved in pure manner."
1053   ad-do-it
1054   (make-local-hook 'write-file-hooks)
1055   (setq write-file-hooks nil)
1056   ;; (setq indent-tabs-mode t)
1057   (message "TinyAdvice: write-file-hooks is now nil in %s" (buffer-name)))
1058
1059 ;;; ----------------------------------------------------------------------
1060 ;;; 19.30 doesn't offer the filename, so enable this in all emacs versions
1061 ;;;
1062 (defadvice find-alternate-file  (around tinyadvice dis)
1063   "Interactive change: offer buffer filename as default.
1064 Reference:
1065   `tinyadvice-:find-alternate-file-flag'"
1066   (interactive
1067    (list
1068     (read-file-name
1069      "find alternate file: "
1070      (file-name-directory (or (buffer-file-name)
1071                               default-directory))
1072      nil
1073      t
1074      (if (buffer-file-name)
1075          (file-name-nondirectory (buffer-file-name))
1076        (if tinyadvice-:find-alternate-file-flag
1077            (buffer-name) "")))))
1078   ad-do-it)
1079
1080 ;;; ----------------------------------------------------------------------
1081 ;;;
1082 (defadvice recover-file  (around tinyadvice dis)
1083   "Offer current buffer's filename in prompt."
1084   (interactive
1085    (list
1086     (read-file-name
1087      "(TinyAdvice) Recocer file: "
1088      (file-name-directory (or (buffer-file-name)
1089                               default-directory))
1090      nil
1091      t
1092      (if (buffer-file-name)
1093          (file-name-nondirectory (buffer-file-name))
1094        (if tinyadvice-:find-alternate-file-flag
1095            (buffer-name) "")))))
1096   ad-do-it)
1097
1098 ;;; ----------------------------------------------------------------------
1099 ;;;
1100 (defadvice write-file (around tinyadvice-file dis)
1101   "File handling additions.
1102
1103 Interactive change:
1104
1105     Changes the interactive prompt so, that full `buffer-file-name' is given
1106     for editing.
1107
1108 Confirm overwrite:
1109
1110     When called interactively, require confirmation if FILENAME already exists.
1111     If FILENAME matches `tinyadvice-:write-file-no-confirm', no confirmation
1112     is asked."
1113   (interactive
1114    ;; Change    "Fwrite to file: "
1115    (list
1116     (read-file-name
1117      "write to file: "
1118      (or (buffer-file-name)
1119          "~/"))))
1120
1121   (let* ((fn           (ad-get-arg 0))
1122          ;;  Tmp buffers do not have filename
1123          (buffer-file  (or fn (buffer-file-name) ""))
1124          (pass         t))
1125
1126     (if (stringp fn)
1127         (setq pass
1128               (ti::string-match-case tinyadvice-:write-file-no-confirm fn)))
1129
1130     (if (or (not (interactive-p))   ;only when user call it, do checks
1131             (not (file-exists-p fn))
1132             pass
1133             (y-or-n-p (format "%s already exists; overwrite it? " fn)))
1134         ad-do-it
1135       (message "Aborted"))))
1136
1137 ;;; ----------------------------------------------------------------------
1138 ;;;
1139 (defadvice write-region (around tinyadvice-file dis)
1140   "See `write-file' which explains the advice behavior."
1141   (interactive "r\nFwrite region: ")
1142   (let* ((fn           (ad-get-arg 2))
1143          (buffer-file  fn)
1144          (pass         t))
1145     (if (stringp fn)
1146         (setq pass
1147               (ti::string-match-case tinyadvice-:write-file-no-confirm fn)))
1148     (if (or (not (interactive-p))
1149             (not (file-exists-p fn))
1150             pass
1151             (y-or-n-p (format "%s already exists; overwrite it? " fn)))
1152         ad-do-it
1153       (message "Aborted"))))
1154
1155 ;;; ----------------------------------------------------------------------
1156 ;;;
1157 (defadvice save-some-buffers (before tinyadvice dis)
1158   "Always save changed abbrevs without questions if `save-abbrevs' is set."
1159   (when (and save-abbrevs abbrevs-changed)
1160     (write-abbrev-file nil)
1161     (setq abbrevs-changed nil)))
1162
1163 ;;}}}
1164 ;;{{{ fill
1165
1166 ;;; ............................................................ &fill ...
1167
1168 ;;; ----------------------------------------------------------------------
1169 ;;; In new cc-mode there variable `c-hanging-comment-ender-p'
1170 ;;; which does exactly same than this advice.
1171 ;;;
1172 ;;; We install this advice for older emacs only.
1173 ;;;
1174 (when (tinyadvice-activate-p 'fill-paragraph)
1175
1176   (defadvice fill-paragraph (after tinyadvice dis)
1177     "Touch C comment filling, otherwise do nothing.
1178 If the fill was done to C comment. It usually levaes it like this,
1179 while this advice corrects it a bit and moves the last asterisk to
1180 the next line.
1181
1182 /* comment ...         /* comment ...
1183  * ends here. */        * ends here.
1184                         */
1185
1186 This function does not affect C comments that occupy only one line."
1187     (let* (col
1188            line)
1189       (when (and (save-excursion
1190                    (beginning-of-line)
1191                    (and
1192                     ;;  If this is continuing line "*", then search back
1193                     ;;  otw we're at "/*" already
1194                     ;;
1195                     (if (looking-at "^[ \t]*[*]")
1196                         (re-search-backward "^[ \t]*/[*]" nil t)
1197                       (looking-at "^[ \t]*/[*]"))
1198                     (re-search-forward  "^[ \t]*/[*]" nil t)
1199                     (setq col (current-column)  line (ti::current-line-number))))
1200                  (re-search-forward "[*]/" nil t)
1201                  ;;  - The "/*" and "*/" must be at different lines,
1202                  ;;    because only then we want to adjust the last "*/"
1203                  ;;  - Skip one line comments.
1204                  (not (eq (ti::current-line-number) line)))
1205         (delete-backward-char 2) (insert "\n")
1206         (move-to-column (1- col) t)
1207         (insert "*/")))))
1208
1209 ;;}}}
1210 ;;{{{ gud
1211
1212 ;;; ............................................................. &gud ...
1213
1214 ;;; ----------------------------------------------------------------------
1215 ;;; See gud.el
1216 ;;;
1217 (defadvice gud-display-line (after tinyadvice dis)
1218   "Highlight current line."
1219   (when (and tinyadvice-:gud-overlay
1220              (fboundp 'move-overlay))
1221     (let* ((ov tinyadvice-:gud-overlay)
1222            (bf (gud-find-file true-file)))
1223       (save-excursion
1224         (set-buffer bf)
1225         (move-overlay
1226          ov
1227          (line-beginning-position)
1228          (line-end-position)
1229          (current-buffer))))))
1230
1231 ;;}}}
1232
1233 ;;{{{ imenu
1234
1235 ;;; ........................................................... &imenu ...
1236
1237 ;;; ----------------------------------------------------------------------
1238 ;;;
1239 (defadvice imenu (before tinyadvice dis)
1240   "Widen the buffer before activating imenu."
1241   (widen))
1242
1243 ;;}}}
1244 ;;{{{ mail
1245
1246 ;;; ............................................................ &mail ...
1247
1248 ;;; ----------------------------------------------------------------------
1249 ;;; See mailabbrev.el
1250 ;;;
1251 (defadvice sendmail-pre-abbrev-expand-hook
1252   (around tinyadvice-no-abbrevs-in-body dis)
1253   "Do not expand any abbrevs in the message body through `self-insert-command'."
1254   (if (or (mail-abbrev-in-expansion-header-p)
1255           ;; (not (eq last-command 'self-insert-command)) ; can't be used
1256           ;; since last-command is the previous, not the current command
1257           (not (integerp last-command-char))
1258           (eq (char-syntax last-command-char) ?w)) ; this uses that
1259       ;; the last char in {C-x '} {C-x a '} {C-x a e} is `w' syntax
1260       ad-do-it
1261     (setq abbrev-start-location (point) ; this hack stops expand-abbrev
1262           abbrev-start-location-buffer (current-buffer))))
1263
1264 ;;}}}
1265 ;;{{{ map-ynp
1266
1267 ;;; ......................................................... &map-ynp ...
1268
1269 ;; 19.28
1270 ;; - map-ynp.el::map-y-or-n-p  Get's loaded in loadup.el, it pops up
1271 ;;   an dialog Box of questions if the input is event type and it is
1272 ;;   annoying to answer yes/no dialog boxes. It is much quicker to
1273 ;;   hit SPACE/DEL for yes/no.
1274 ;; - Hmm actually it looks back what the command was by looking at
1275 ;;   `last-nonmenu-event' variable, so I should reset it instead.
1276 ;; - *argh* I was wrong, it is the `y-or-n-p' (built-in) command that pops up
1277 ;;   the dialog, anyway the advice works for it too: built-in or not
1278 ;;   doesn't matter
1279 ;;
1280 ;; The way to do this in XEmacs is:
1281 ;;
1282 ;;    (setq use-dialog-box nil)
1283
1284 (when (and (ti::compat-window-system)
1285            (ti::emacs-p))
1286   (defadvice map-y-or-n-p (before tinyadvice dis)
1287     "Reset any mouse event to key event so that no dialogs are displayed."
1288     (if (listp last-nonmenu-event)
1289         ;; replace with some harmless value
1290         (setq last-nonmenu-event ?\n)))
1291   (defadvice y-or-n-p (before tinyadvice dis)
1292     "Reset any mouse event to key event so that no dialogs are displayed."
1293     (if (listp last-nonmenu-event)
1294         ;; replace with some harmless value
1295         (setq last-nonmenu-event ?\n))))
1296
1297 ;;}}}
1298 ;;{{{ mouse
1299
1300 ;;; ........................................................... &mouse ...
1301
1302 ;;; ----------------------------------------------------------------------
1303 ;;;
1304 (defadvice mouse-wheel-scroll-screen (around tinyadvice act)
1305   "Use tinymy.el scrolling if possible."
1306   (if (and (fboundp 'tinymy-scroll-down)
1307            (fboundp 'tinymy-scroll-up))
1308       (let ((event (ad-get-arg 0)))
1309         (ignore-errors
1310           (if (< (car (cdr (cdr event))) 0)
1311               (tinymy-scroll-down)
1312             (tinymy-scroll-up))))
1313     ad-do-it))
1314
1315 ;;; ----------------------------------------------------------------------
1316 ;;;
1317 (defadvice mouse-delete-other-windows  (around tinyadvice dis)
1318   "Confirm window delete."
1319   (if (y-or-n-p "Really delete _all_ windows ")
1320       ad-do-it
1321     (message "")))
1322
1323 ;;; ----------------------------------------------------------------------
1324 ;;;
1325 (defadvice mouse-delete-window  (around tinyadvice dis)
1326   "Confirms window delete."
1327   (if (y-or-n-p "Really delete _this_ window ")
1328       ad-do-it
1329     (message "")))
1330
1331 ;;}}}
1332 ;;{{{ replace.el
1333
1334 (defadvice occur  (before tinyadvice act)
1335   "Iinteractive change: ask if user want the occur to start from `point-min'.
1336 also Possibly unfold/un-outline the code."
1337   (when (and (interactive-p)
1338              (not (eq (point) (point-min)))
1339              (y-or-n-p "TinyAdvice: Start occur from point-min? "))
1340     (if (and (or (and (featurep 'folding)
1341                       (symbol-value 'folding-mode))
1342                  (and (and (featurep 'outline)
1343                            (boundp  'outline-mode))
1344                       (symbol-value 'outline-mode)))
1345              (save-excursion
1346                (ti::pmin)
1347                (re-search-forward "\r" nil t))
1348              (y-or-n-p "TinyAdvice: Open buffer's selective display too? "))
1349         (ti::buffer-outline-widen))))
1350
1351 ;;}}}
1352 ;;{{{ simple.el
1353
1354 ;;; .......................................................... &simple ...
1355
1356 ;;; ----------------------------------------------------------------------
1357 ;;; See simple.el
1358 ;;;
1359 (defadvice exchange-point-and-mark (around tinyadvice-pop-if-prefix dis)
1360   "If given prefix, call `set-mark-command' to pop previous mark positions."
1361   (if (and current-prefix-arg
1362            (interactive-p))
1363       (call-interactively 'set-mark-command))
1364   ad-do-it)
1365
1366 ;;; ----------------------------------------------------------------------
1367 ;;;
1368 (defadvice goto-line (around tinyadvice dis)
1369   "Widen the buffer before and after `goto-line' command."
1370   (widen)
1371   ad-do-it
1372   ;;  We do this because, the folding.el sets narrowing in effect,
1373   ;;  when the goto-line has finished.
1374   ;;  #todo: should we check featurep 'folding?
1375   (widen))
1376
1377 ;;; ----------------------------------------------------------------------
1378 ;;;
1379 (defadvice indent-for-comment (around tinyadvice dis)
1380   "Kill the comment with negative prefix."
1381   (if (eq current-prefix-arg '-)
1382       (kill-comment nil)
1383     ad-do-it))
1384
1385 ;;; ----------------------------------------------------------------------
1386 ;;; Redefine insert-buffer to insert a visible buffer, if there's one.
1387 ;;;
1388 (defadvice insert-buffer (before tinyadvice dis)
1389   "Use a more reasonable default, the other window's content."
1390   (interactive
1391    (list
1392     (progn
1393       (barf-if-buffer-read-only)
1394       (read-buffer "Insert buffer: "
1395                    (if (eq (selected-window)
1396                            (next-window (selected-window)))
1397                        (other-buffer (current-buffer))
1398                      (window-buffer (next-window (selected-window))))
1399                    t)))))
1400
1401 ;;; ----------------------------------------------------------------------
1402 ;;; avoid deactivation of region when buffer end or beginning is reached
1403 ;;;
1404 (defadvice line-move (around tinyadvice dis)
1405   "Avoid deactivation of region. in `beginning-of-buffer' or `end-of-buffer'."
1406   (condition-case ()
1407       ad-do-it
1408     ((beginning-of-buffer end-of-buffer)
1409      (if (bobp)
1410          (message "Beginning of buffer.")
1411        (message "End of buffer.")))))
1412
1413 ;;; ----------------------------------------------------------------------
1414 ;;;
1415 (defadvice set-mark-command (around tinyadvice-global-if-negative dis)
1416   "If the argument is negative, call `pop-global-mark'."
1417   (if (< (prefix-numeric-value current-prefix-arg) 0)
1418       (pop-global-mark)
1419     ad-do-it))
1420
1421 ;;; ----------------------------------------------------------------------
1422 ;;;
1423 (defadvice what-cursor-position (around tinyadvice dis)
1424   "Displays line number info too."
1425   ad-do-it
1426   ;;  we have to use 'princ' because there is percentage mark
1427   ;;  in returned string and that would run 'message' beserk,
1428   ;;  since it thinks it's formatting code
1429   (princ (concat
1430           ad-return-value
1431           (int-to-string (ti::widen-safe (ti::current-line-number))))))
1432
1433 ;;; ----------------------------------------------------------------------
1434 ;;;
1435 (defadvice switch-to-buffer (around tinyadvice dis)
1436   "When called interactively: Confirm switch to non-existing buffer.
1437
1438 References:
1439
1440   `tinyadvice-:switch-to-buffer-find-file'
1441    if non-nil, suggest `find-file' for non-existing buffers"
1442   (interactive "Bbuffer name: ")
1443   (let ((buffer-name (ad-get-arg 0)))
1444     (if (or (not (interactive-p))       ;user didn't call us
1445             (get-buffer buffer-name))   ;it exists
1446         ad-do-it
1447       (cond
1448        ((y-or-n-p (format "`%s' does not exist, create? " buffer-name))
1449         ad-do-it)                       ;ceate new buffer
1450
1451        (tinyadvice-:switch-to-buffer-find-file ;is this enabled ?
1452         (find-file (read-file-name "(tinyadvice) Find-file: "
1453                                    nil
1454                                    nil
1455                                    nil
1456                                    buffer-name)))))
1457     (message "")))                      ;clear the echo area
1458
1459 ;;; ----------------------------------------------------------------------
1460 ;;;
1461 (defadvice switch-to-buffer-other-frame  (around tinyadvice dis)
1462   "Replace function. Don't ever create new frame; reuse some existing frame."
1463   (let ((free-frames (ti::window-frame-list nil 'exclude-current))
1464         stat)
1465     (if (null free-frames)
1466         (pop-to-buffer buffer)
1467       (cond
1468        ((setq stat (ti::window-get-buffer-window-other-frame buffer))
1469         ;;  buffer is displayed already in some OTHER frame; go to it.
1470         (raise-frame (car stat))
1471         (select-frame (car stat))
1472         (select-window (cdr stat)))
1473        (t
1474         ;;  Go to some free frame and pop up there
1475         (raise-frame  (car free-frames))
1476         (select-frame (car free-frames))
1477         (switch-to-buffer buffer))))))
1478
1479 ;;}}}
1480 ;;{{{ subr.el
1481
1482 ;;; ----------------------------------------------------------------------
1483 ;;;
1484 (defadvice save-buffers-kill-emacs (around tinyadvice dis)
1485   "Redefine `save-buffers-kill-emacs' to prevent accidental logouts."
1486   (cond
1487    ((and (interactive-p)
1488          (y-or-n-p "TinyAdvice: Really quit emacs? "))
1489     (message "")
1490     ad-do-it)
1491    ((not (interactive-p))
1492     ad-do-it)))
1493
1494 ;;; ----------------------------------------------------------------------
1495 ;;; - This puts cursor to generated list. Propably what we
1496 ;;;   want 99% of the time.
1497 ;;;
1498 (defadvice list-buffers  (after tinyadvice dis)
1499   "Select buffer list after displaying."
1500   (if (interactive-p)
1501       (select-window (get-buffer-window "*Buffer List*"))))
1502
1503 ;;}}}
1504 ;;{{{ time
1505
1506 ;;; ............................................................ &time ...
1507
1508 ;;; ----------------------------------------------------------------------
1509 ;;; This is for reporter.el by Barry A. Warsaw in the xemacs distribution
1510 ;;;
1511 (defadvice display-time-process-this-message (around tinyadvice-no-junk-mail dis)
1512   "Suppress message in modeline.
1513 If display-time-announce-junk-mail-too is nil, suppress the [Junk mail]
1514 message on the modeline."
1515   ((let ((modeline display-time-mail-modeline))
1516      ad-do-it
1517      (if (and ad-return-value           ; junk-p
1518               (not display-time-announce-junk-mail-too))
1519          ;; restore non-junk modeline
1520          (setq display-time-mail-modeline modeline))
1521      ad-return-value)))
1522
1523 ;;}}}
1524 ;;{{{ vc
1525
1526 ;;; .............................................................. &vc ...
1527
1528 ;;; ----------------------------------------------------------------------
1529 ;;;
1530 (defun tinyadvice-rcs-initial-comment (file)
1531   "Add initial comment leader to RCS FILE."
1532   (let* (buffer
1533          file-type
1534          str)
1535     (when (and (stringp file)                   ;if not nil
1536                (ti::vc-rcs-file-exists-p file)) ;RCS controlled file
1537
1538       ;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ type of file ^^^
1539
1540       (with-current-buffer (get-file-buffer file)
1541         (setq file-type (or (ti::id-info nil 'variable)
1542                             (symbol-name major-mode)))
1543         (setq str comment-start))
1544
1545       ;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ default comment ^^^
1546
1547       (cond
1548        ((string-match "lisp" file-type)
1549         (setq str ";; "))
1550        ((string-match "c[+]+" file-type)
1551         (setq str "// "))
1552        ((stringp str)                ;original comment, leave it as is
1553         nil)
1554        (t
1555         (setq str "# ")))              ;Not set? Suggest shell comment
1556
1557       ;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ setting comment ^^^
1558
1559       (unless (ti::nil-p                ;only if given something
1560                (setq str
1561                      (read-from-minibuffer
1562                       "Set RCS comment leader to:" str)))
1563         (setq str (format "rcs -c\"%s\" %s" str file)) ;Shell command
1564
1565         (message "TinyAdvice: setting rcs comment...")
1566         (shell-command str "*vc*" )
1567
1568         ;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ fixing emacs buffer ^^^
1569
1570         ;;  - Now, the rcs -u only modified the delta file in RCS tree,
1571         ;;    we must take the version out of the tree, so that the new
1572         ;;    comment setting takes place: Do "co" and reread the file
1573         ;;    into emacs.
1574         ;;
1575
1576         (message "TinyAdvice: refreshing the file comment...")
1577
1578         (setq str (format "co %s" file)) ;Easier to debug and print variable
1579         (shell-command str)
1580
1581         (when (setq buffer (get-file-buffer file))
1582           (let* (find-file-hooks        ;prevent VC this time
1583                  buffer-read-only
1584                  enable-local-eval)
1585             (set-buffer buffer)
1586             (find-alternate-file file)
1587             (pop-to-buffer (current-buffer))))
1588
1589         (when (setq buffer (get-buffer "*VC-log*"))
1590           (with-current-buffer buffer
1591             ;;  Fix this variable, because we reread the file
1592             ;;  see vc-finish-logentry
1593             (setq vc-parent-buffer buffer)))
1594         (message "TinyAdvice: refreshing the file comment ...done")))))
1595
1596 ;;; ----------------------------------------------------------------------
1597 ;;; AROUND advice has been left to user, therefor the
1598 ;;; combination of BEFORE and AFTER advices.
1599 ;;;
1600 (defadvice vc-do-command  (before tinyadvice-vc  dis)
1601   "Set flag `tinyadvice-:vc-p' if file is version controlled.
1602 Used by TinyAdvice after advice to determine if initial
1603 comment leader needs to be set."
1604   ;;  - The arg 'file' is nil when vc calls this command with
1605   ;;    "rcs" nil nil "-V". We are not interested in those cases.
1606   (if (stringp file)
1607       (setq tinyadvice-:vc-p (or (vc-registered file)
1608                                  (string-match ",v" file)))))
1609
1610 ;;; ----------------------------------------------------------------------
1611 ;;;
1612 (defadvice vc-do-command (after tinyadvice-vc dis)
1613   "Set initial RCS comment leader.
1614 According to flag `tinyadvice-:vc-p', if file was not version controlled,
1615 ie. the CheckIn was done first time, ask from user about the initial
1616 comment leader and set it."
1617   (if (and (stringp file)
1618            (null tinyadvice-:vc-p))     ;Initial CheckIn
1619       (tinyadvice-rcs-initial-comment file)))
1620
1621 ;;; ----------------------------------------------------------------------
1622 ;;;
1623 (defun tinymy-rcs-p (file)
1624   "Check if is registered or can be put to RCS."
1625   (or (and (stringp file)
1626            (eq 'RCS (vc-file-getprop
1627                      file
1628                      'vc-backend)))
1629       (null (ti::vc-dir-p file))))
1630
1631 ;;; ----------------------------------------------------------------------
1632 ;;;
1633 (defadvice vc-do-command (around tinyadvice-vc dis)
1634   "TinyAdvice Changes.
1635 Set initial RCS comment leader.
1636 According to flag `tinyadvice-:vc-p', if file was not version controlled,
1637 ie. the CheckIn was done first time, ask from user about the initial
1638 comment leader and set it.
1639
1640 Add flags that user gave in `vc-register' (like -k) for initial login
1641 which preserver keyword values if needed. User must register file with
1642 C-x v i for this to take in effect."
1643   (let* ((tinyadvice-args   (ad-get-args 6))
1644          (tinyadvice-flags  (get 'vc-register 'tinyadvice-vc-register))
1645          (rcs               (tinymy-rcs-p file)))
1646     (when (and rcs
1647                (stringp tinyadvice-flags))
1648       ;;  Add initial RCS flags that were set in vc-register
1649       (setq tinyadvice-args
1650             (append tinyadvice-args (split-string tinyadvice-flags)))
1651       (put 'vc-register 'tinyadvice-vc-register nil)
1652       (when (and (stringp tinyadvice-flags)
1653                  (string-match "-k" tinyadvice-flags))
1654         ;;  vc add option -u1.1 for initial version, get rid of version number
1655         (setq tinyadvice-args
1656               (remove-if
1657                (function
1658                 (lambda (x)
1659                   (and (stringp x)
1660                        (string-match "^-u" x))))
1661                tinyadvice-args))
1662         (push "-u" tinyadvice-args))
1663       (ad-set-args 6 tinyadvice-args)))
1664   ad-do-it)
1665
1666 ;;; ----------------------------------------------------------------------
1667 ;;;
1668 (defadvice vc-register (before tinyadvice-vc dis)
1669   "Ask if check in as \"original\" file if there is already version number.
1670 If the current file already includes version control information,
1671 ask from user if the check in should happen using -k which preserves
1672 the original keyword attributes."
1673   (put 'vc-register 'tinyadvice-vc-register nil)
1674   (let* ((file     (buffer-file-name))
1675          (version  (and file
1676                         ;;  No previous file
1677                         (not (ti::vc-rcs-file-exists-p file))
1678                         (not (ti::vc-cvs-file-exists-p file))
1679                         (ti::vc-rcs-buffer-version)))
1680          ans)
1681     (when (and version
1682                (eq 'RCS (vc-file-getprop file 'vc-backend))
1683                (ti::vc-version-simple-p version)
1684                ;; if there
1685                (not
1686                 (ti::nil-p
1687                  (setq ans
1688                        (read-string
1689                         (format "(TinyAdvice: found v%s) ci rcs flags:"
1690                                 version)
1691                         "-k")))))
1692       (put 'vc-register 'tinyadvice-vc-register ans))))
1693
1694 ;;; ----------------------------------------------------------------------
1695 ;;; vc-hooks.el , vc-mode-line (file &optional label)
1696 ;;;
1697 ;;; - The string displayed is included in the `vc-mode' variable
1698 ;;; - This function is called by `vc-rcs-status'
1699 ;;;
1700 (defadvice vc-mode-line (around tinyadvice-vc dis)
1701   "Add word 'b' if RCS revision is in the middle of the
1702 \(b)ranch and not the last one.
1703
1704 Change to CVS: never make buffer read-only if
1705 `tinyadvice-:cvs-buffer-read-only' is nil."
1706   (let* ((vc      (and file
1707                        (vc-registered file)
1708                        (vc-file-getprop file 'vc-workfile-version)))
1709          (file    buffer-file-name)
1710          (backend (and vc
1711                        buffer-file-name
1712                        (vc-file-getprop file 'vc-backend)))
1713          ver)
1714     (when (and vc
1715                ;; #todo: CVS is missing
1716                (eq backend 'RCS)
1717                (setq ver (ti::vc-rcs-head-version file))
1718                (stringp ver)
1719                (not (string= vc ver)))  ;it's not the same as highest
1720       (ad-set-arg 0
1721                   (format "%s%s"
1722                           (or (ad-get-arg 0)
1723                               (and backend
1724                                    (symbol-name backend))
1725                               "")
1726                           "b")))
1727
1728     ad-do-it
1729     (when (and vc
1730                (null tinyadvice-:cvs-buffer-read-only)
1731                (eq 'CVS backend))
1732       (setq buffer-read-only nil))))
1733
1734 ;;; ----------------------------------------------------------------------
1735 ;;;
1736 (defadvice vc-print-log (around tinyadvice-vc dis)
1737   "Position cursor to current revision."
1738   (let* (ver)
1739     (setq ver (ti::string-match  "[.0-9]+" 0 (or vc-mode "")))
1740     ad-do-it
1741     (when ver
1742       ;;  the version must end directly,
1743       ;;  "1.4" must not match "1.4.1.1"
1744       ;;
1745       ;;  Watch out for this statement too, thats why we start
1746       ;;  searching from the end of buffer.
1747       ;;  revision 3.4.1.2      locked by: foo;
1748       ;;
1749       (ti::pmax)
1750       (re-search-backward (concat "revision +" ver "[^.]") nil t))))
1751
1752 ;;; ----------------------------------------------------------------------
1753 ;;;
1754 ;;; - Normally each dir have an RCS dir.
1755 ;;; - But sometimes user want to keep all RCS files in one RCS dir,
1756 ;;;   so he just creates symlinks to that main RCS dir.
1757 ;;;
1758 ;;;           /dir/RCS      main RCS dir
1759 ;;;                | |
1760 ;;;   dir1/RCS ----| |      Symlink 1 points there
1761 ;;;   dir2/RCS ------|      Symlink 2 points there
1762 ;;;
1763 ;;;
1764 (defun tinyadvice-vc-register ()
1765   "Check if RCS directory is needed before registering a file."
1766   (when (and buffer-file-name           ;let's not take a risk
1767              (null (tinymy-rcs-p buffer-file-name)))
1768     (let* ( ;;  - Make sure we're looking under right directory:
1769            ;;  - It is possible that user has given the `cd' command
1770            ;;    in this buffer e.g. due to compilation.
1771            (default-directory (file-name-directory buffer-file-name))
1772            ;;  Strange things may happen. If there is no RCS directory
1773            ;;  and you use `ci' then the file appear in _current_
1774            ;;  directory with name file.txt,v
1775            (false (concat buffer-file-name ",v"))
1776            rcs
1777            cmd)
1778       (when (file-exists-p false)
1779         (message "TinyAdvice: ** Warning Suspicious rcs file %s" false)
1780         (sit-for 5))
1781       (when (not (and (file-exists-p "RCS")
1782                       (file-directory-p "RCS")))
1783         (setq rcs (ti::file-make-path default-directory "RCS"))
1784         (message "[press esc] No RCS tree in %s" default-directory)
1785         (sit-for 7) ;; Make sure user sees the directory name
1786         (discard-input)
1787         (if (y-or-n-p
1788              (concat
1789               "Y = Create new RCS dir"
1790               (if (not (ti::win32-p))
1791                   ", N = create symlink to main depository (unix only)? "
1792                 "")))
1793             (make-directory rcs)
1794           ;; -- ELSE --
1795           (if (ti::win32-p)
1796               (error "TinyAdvice: `vc-register' needs a RCS dir.")
1797             (if (not (file-exists-p tinyadvice-:vc-main-rcs-dir))
1798                 (error
1799                  (format
1800                   "TinyAdvice: `vc-register' No main RCS dirextory exist: %s"
1801                   tinyadvice-:vc-main-rcs-dir)))
1802             (setq cmd (format "ln -s %s %s"
1803                               (expand-file-name tinyadvice-:vc-main-rcs-dir)
1804                               rcs)))
1805           (ti::temp-buffer tinyadvice-:tmp-buffer 'clear)
1806           (shell-command cmd tinyadvice-:tmp-buffer)
1807           (unless (ti::buffer-empty-p tinyadvice-:tmp-buffer)
1808             (pop-to-buffer tinyadvice-:tmp-buffer))
1809           (message "TinyAdvice: (vc-register) %s"  cmd))))))
1810
1811 ;;; ----------------------------------------------------------------------
1812 ;;;
1813 (defadvice vc-register (before tinyadvice-create-rcs-dir dis)
1814   "RCS directory must exist. Ask to create one if it does not exist."
1815   (if (not (boundp 'vc-handled-backends)) ;; skip if latest emacs
1816       (tinyadvice-vc-register)))
1817
1818 ;;}}}
1819
1820 ;;{{{ Other
1821
1822 ;;; ........................................................... &other ...
1823
1824 ;;; ----------------------------------------------------------------------
1825 ;;;
1826 (mapc
1827  (function
1828   (lambda (x)
1829     (eval
1830      (`
1831       (defadvice (, x) (around tinyadvice-kill-buffer act)
1832         "Kill the buffer if there is no process."
1833         (condition-case error
1834             ad-do-it
1835           (error
1836            (if (equal error '(error "Current buffer has no process"))
1837                (kill-buffer (current-buffer))))))))))
1838  '(term-copy-old-input term-send-input term-send-raw-string))
1839
1840 ;;; ----------------------------------------------------------------------
1841 ;;; hyberbole package
1842 ;;;
1843 (defadvice hkey-help-show (around tinyadvice-shrink-window act)
1844   "Shrink auxiliary windows to buffer size.
1845 For `help-mode',switch `view-mode' off."
1846   ;;
1847   ;; hkey-help-show is part of Bob Wiener's Hyperbole. In pure emacs
1848   ;; a hook is more appropriate: with-output-to-temp-buffer asks the
1849   ;; function in the variable temp-buffer-show-function (if non-nil)
1850   ;; to take care of the showing. That function also must call
1851   ;; temp-buffer-show-hook. Take your pick.
1852   ;;
1853   (if (and (not current-window)         ; second arg
1854            (get-buffer-window buffer))
1855       (delete-window (get-buffer-window buffer))) ; force recreation
1856   ad-do-it
1857   (if (and (not current-window)         ; second arg
1858            (not (one-window-p t)))      ; not counting the minibuffer
1859       (shrink-window-if-larger-than-buffer (get-buffer-window buffer)))
1860   (if (and (eq major-mode 'help-mode)
1861            (boundp view-mode) view-mode)
1862       (view-exit)))
1863
1864 ;;}}}
1865
1866 (provide   'tinyadvice)
1867 (run-hooks 'tinyadvice-load-hook)
1868
1869 ;;; tinyadvice.el ends here