;;; patches.el --- various patches for emacs ;; Copyright (C) 2004 Free Software Foundation, Inc. ;; Author: Yann Hodique ;; Keywords: lisp, extensions ;; This file is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; This file is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;; Boston, MA 02111-1307, USA. ;;; Commentary: ;; Some patches I cannot live without. Fix bad default behaviors, and provide ;; missing basic features. Some code is by me, some is hacked by me, and some ;; has nothing to do with me :-) ;;; Code: ;; Use this one instead of require to ignore errors (defun request (pack) "Fail to require silently" (condition-case nil (require pack) (error nil))) ;; Map a condition/action on a list (defun mapcond (test result list &optional default) (or (let ((ex t)) (while (and ex list) (if (funcall test (car list)) (progn (setq ex nil) (funcall result (car list))) (setq list (cdr list))))) default)) (defmacro make-double-command (name args doc-string interactive first-form second-form) "define a new command from 2 behaviors" (declare (indent 2)) (let ((int-form (if (not interactive) '(interactive) (list 'interactive interactive)))) `(progn (defun ,name ,args ,doc-string ,int-form (if (eq last-command this-command) ,(if (and (listp second-form) (> (length second-form) 1)) (cons 'progn second-form) second-form) ,first-form))))) ;; Many thanks to utis (Oliver Scholz) (defmacro defmadvice (flist spec &rest body) (let ((defs (mapcar (lambda (f) `(defadvice ,f ,(append (list (car spec) (intern (format "ad-%s-%s-%s" (symbol-name f) (symbol-name (cadr spec)) (car spec)))) (cddr spec)) ,@body)) flist))) `(progn ,@defs))) ;; add the same function to multiple hooks (defun add-mhook (mlist func) (dolist (m mlist) (add-hook m func))) ;; clear a hook (defun clear-hook (hook) (set hook nil)) ;; suppress annoying messages from speedbar package (defmadvice (dframe-handle-make-frame-visible dframe-handle-iconify-frame dframe-handle-delete-frame) (around dframe act) "Inhibit message function" (flet ((message (&rest args) nil)) ad-do-it)) ;; fix split-window behavior (defmadvice (split-window-vertically split-window-horizontally) (after split act) "Open another buffer in the new window" (set-window-buffer (next-window) (other-buffer))) ;; make the y or n suffice for a yes or no question (fset 'yes-or-no-p 'y-or-n-p) ;; Goto matching parenthesis (defun match-paren () "Will bounce between matching parens just like % in vi" (interactive) (let ((prev-char (char-to-string (preceding-char))) (next-char (char-to-string (following-char)))) (cond ((string-match "[[{(<]" next-char) (forward-sexp 1)) ((string-match "[\]})>]" prev-char) (backward-sexp 1)) (t (error "%s" "Not on a paren, brace, or bracket"))))) (global-set-key [(control =)] 'match-paren) ;; ...never switch to overwrite mode, not even accidentally (global-set-key [insert] (function (lambda () (interactive) (message "Sorry, overwrite mode has been disabled forever.")))) ;; disable backups for files in /tmp or in my Mail or News directories. (defun ecm-backup-enable-predicate (filename) (and (not (string= "/tmp/" (substring filename 0 5))) (not (string-match "/mail/" filename)) (not (string-match "/News/" filename)))) (setq backup-enable-predicate 'ecm-backup-enable-predicate) (setq backup-directory-alist '(("." . "~/.backups"))) ;; Put autosaves files in a single directory too (when (request 'auto-save) (setq auto-save-directory (expand-file-name "~/.autosaves/"))) ;; Why the hell should some commands be disabled? (setq disabled-command-hook nil) ;; scroll-margin does not work with hl-line :-( (defvar top-margin) (defvar bottom-margin) (defvar buffer-no-margin-alist) (defun check-margin () (let ((window (selected-window))) (if (not (or (window-minibuffer-p window) (member (buffer-name (window-buffer)) buffer-no-margin-alist))) (let* ((position (progn (set-buffer (window-buffer)) (point))) (wstart (window-start)) (wbottl (- (window-height) 2)) (topshift (- (max 0 (min top-margin (- wbottl 1))))) (diff (- (min topshift (- bottom-margin wbottl)) topshift))) (vertical-motion topshift) (if (cond ((> wstart (point))) ((= wstart (point)) nil) ((or (= diff 0) (save-restriction (narrow-to-region wstart (point-max)) (vertical-motion diff) (< wstart (point)))))) (set-window-start window (point))) (goto-char position))))) (defun set-scroll-margin (up down except) "Enable hacked scroll margin" (setq top-margin up bottom-margin down buffer-no-margin-alist except) (add-hook 'post-command-hook 'check-margin)) ;; Color prefix in minibuffer (unless (facep 'minibuffer-prompt) (let ((face (cdr (memq 'face minibuffer-prompt-properties)))) (if face (setcar face minibuffer-face) (setq minibuffer-prompt-properties (append minibuffer-prompt-properties (list 'face 'minibuffer-face)))))) ;; Adapt open-line behavior when arg <= 0 (defadvice open-line( around open-line-around (arg) act ) "Open new line(s) at end of line if arg is <= 0." (if (<= arg 0) (let ((var (if (equal arg 0) -1 arg))) (save-excursion (end-of-line) (open-line (- var)))) ad-do-it)) ;; BUFFER SWITCHING FIX ;; ;; This changes the behaviour of the switch-to-buffer completion functions so ;; that the current buffer is NOT in the completion list. ;; ;; i.e. say you're working in "temp.c", and you want to visit "temp.h"; so you ;; type "C-xb", then "t" which then presents you with a completion list of ;; temp.c and temp.h, so you then must type "h". This is annoying since ;; why would you want to switch back to the buffer you're in?!? ;; Using this fix would remove "temp.c" from the completion lits so that when ;; you had typed "t" the name would be completed as "temp.h" as desired. ;; ;; Steve Dodd ;; March 1998 ;; Re-hacked and dramatically packed by Yann Hodique (2004) (defvar yh/remove-first-completion nil) (defun yh/clean-minibuffer-completion-table () "Suppress current buffer from completion list if needed" (when yh/remove-first-completion (progn (setq yh/remove-first-completion nil) (when (consp minibuffer-completion-table) (setq minibuffer-completion-table (cdr minibuffer-completion-table)))))) (defmadvice (minibuffer-complete minibuffer-complete-word minibuffer-complete-and-exit) (before complete act) "Suppress current buffer from completion list if needed" (yh/clean-minibuffer-completion-table)) (defadvice switch-to-buffer (before ad-switch-to-buffer-before act) "Activate first entry removal, in order to avoid completing the current buffer name" (setq yh/remove-first-completion t)) (defun yank-rpop (arg) (interactive "*p") (yank-pop (- arg))) (global-set-key "\M-Y" 'yank-rpop) (defun yh/completion-setup-function () (if minibuffer-completing-file-name (file-completion-setup-function) (completion-setup-function))) ;; The default completion-setup-function conflicts with my dircolors settings (defun file-completion-setup-function () (let ((mainbuf (current-buffer)) (mbuf-contents (minibuffer-contents))) (with-current-buffer mainbuf (setq default-directory (file-name-directory mbuf-contents))) (when (and partial-completion-mode (not (eobp))) (setq mbuf-contents (substring mbuf-contents 0 (- (point) (point-max))))) (with-current-buffer standard-output (completion-list-mode) (make-local-variable 'completion-reference-buffer) (setq completion-reference-buffer mainbuf) ;; Insert help string. (goto-char (point-min)) (if (display-mouse-p) (insert (substitute-command-keys "Click \\[mouse-choose-completion] on a completion to select it.\n"))) (insert (substitute-command-keys "In this buffer, type \\[choose-completion] to \ select the completion near point.\n\n"))))) (remove-hook 'completion-setup-hook 'completion-setup-function) (add-hook 'completion-setup-hook 'yh/completion-setup-function) ;; Suppress annoying messages. Needs some work ;; (defadvice message (around message-around act) ;; "Don't let annoying messages popup while using the minibuffer" ;; (unless (minibuffer-window-active-p (minibuffer-window)) ;; ad-do-it)) (provide 'patches) ;;; patches.el ends here