;; -*- emacs-lisp -*- ;;; emacs-homebrew.el --- small custom emacs functions. ;; Author: Mark Triggs ;; Keywords: lisp ;; $Id: emacs-homebrew.el,v 1.296 2007/03/04 11:06:41 mst Exp $ ;; 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. ;;; Code: (require 'cl) (defun mail-use-gnus (&optional address &rest args) "Write a mail to `address' using gnus" (interactive) (gnus-no-server) (gnus-msg-mail) (when address (insert address))) (defun fill-this-line () "Fill the current line only" (interactive) (save-excursion (beginning-of-line) (set-mark-command nil) (end-of-line) (fill-region (region-beginning) (region-end)))) ;; (global-set-key (kbd "C-x k") 'de-context-kill) ;; (defun de-context-kill (arg) ;; "Kill buffer, taking gnuclient into account." ;; (interactive "p") ;; (when (and (buffer-modified-p) ;; (eq last-command 'de-context-kill) ;; (not (string-match "\\*.*\\*" (buffer-name))) ;; (= 1 arg)) ;; (diff-buffer-with-associated-file) ;; (error "Buffer has unsaved changes")) ;; (if (and (boundp 'gnuserv-minor-mode) ;; gnuserv-minor-mode) ;; (gnuserv-edit) ;; (set-buffer-modified-p nil) ;; (kill-buffer (current-buffer)))) (defun iswitchb-mst-files-to-start () (let* ((file-buffers (mapcan (lambda (buffer) (if (buffer-file-name buffer) (list buffer) nil)) (buffer-list))) (nonfile-buffers (remove-if-not (lambda (b) (member b file-buffers)) (buffer-list)))) ;; Move buffers who don't have files associated with them to the end. (iswitchb-to-end (mapcar 'buffer-name nonfile-buffers)))) (defvar iswitchb-mst-to-end-regexp nil "Regular expression matching buffers to be moved to the end of the iswitchb list") (defun iswitchb-mst-summaries-to-end () "Move the summaries to the end of the list. Ripped and modified from the iswitchb docs" (let* ((case-fold-search t) (summaries (delq nil (mapcar (lambda (x) (if (and x (string-match iswitchb-mst-to-end-regexp x)) x nil)) iswitchb-temp-buflist)))) (iswitchb-to-end summaries))) ;; ;; open a file as root ;; (defun find-file-root (file) ;; (interactive "fOpen file (as root): ") ;; (require 'tramp) ;; (find-file (concat "/[multi/sudo:root@localhost]" file))) ;; (global-set-key [(control x) (control r)] 'find-file-root) (defun weigh-in () (interactive) (let ((weight (read-string "Weight: "))) (with-current-buffer (find-file-noselect "~/.weight_log") (goto-char (point-max)) (insert (format "%s\t%s" (format-time-string "%m-%d-%y") (car (read-from-string weight)))) (save-buffer) (kill-buffer nil))) (when (y-or-n-p "Run weightcheck? ") (with-frame-display (start-process "weightcheck" nil "~/.bin/weightcheck")))) (defun erc-mst-get-network (host) (some (lambda (n) (and (member* host (erc-mst-network-addresses n) :test #'string=) n)) erc-mst-networks)) (defvar gnus-mst-frame nil "The frame gnus is running in") (defun mst-start-gnus () (interactive) (shell-command "sawfish-client -e '(select-workspace 2)'") (gnus-other-frame 2)) (defun average (&rest numbers) (string-to-number (format "%.4f" (typecase (car numbers) (cons (/ (reduce '+ (car numbers)) (float (length (car numbers))))) (t (/ (reduce '+ numbers) (float (length numbers)))))))) (defun mst-wrap-string (s &optional fill prefix) (with-temp-buffer (insert s) (let ((fill-column (or fill fill-column)) (fill-prefix prefix) (filladapt-mode nil)) (fill-region (point-min) (point-max))) (buffer-string))) (defun mst-add-template (regex &optional front end) "Add a template for the file extension matching 'regex', and include an front line at the top of the file and an end line at the bottom" (setq auto-insert-alist (cons `((,regex) . (lambda () ,(when front `(insert (format "%s\n" ,(eval front)))) (narrow-to-region (point) (point)) (insert "\n") (unwind-protect (let ((short-description (read-string "One-line description: ")) (long-description (read-string "Long Description: "))) (when (and short-description (not (string= short-description ""))) (insert (format "%s\n\n" short-description))) (when (and long-description (not (string= long-description ""))) (insert (mst-wrap-string (format "Description: %s" long-description) (- fill-column (length comment-start) 2 ; for spaces (length comment-end)) " ")) (newline 2)) (insert (format "Author: %s <%s>\n\n" (user-full-name) user-mail-address)) (let ((comment-empty-lines t)) (comment-region (point-min) (point-max)) (when (string= comment-end "") (replace-regexp "^$" comment-start nil (point-min) (point-max) ))) (newline 3) (save-excursion (replace-regexp " +$" "" nil (point-min) (point-max)))) (widen)) ,(when end `(insert (format "%s\n\n" ,(eval end)))))) auto-insert-alist))) (defun prompt-for (type prompt) (let ((input (read-from-minibuffer (format "%s: " prompt)))) (cond ((typep input type) input) ((typep (car (ignore-errors (read-from-string input))) type) (car (read-from-string input))) (t nil)))) (defun mst-set-buffer-indentation () (interactive) (let ((use-tabs (y-or-n-p "Use hard tabs? "))) (cond (use-tabs (setq indent-tabs-mode t) (set (tab-controller major-mode) 8)) (t (setq indent-tabs-mode nil) (set (tab-controller major-mode) (or (prompt-for 'integer "Indentation width? ") 4))))) (set (make-local-variable 'parens-require-spaces) (y-or-n-p "Spaces before parens? "))) (defun mst-invent-word () "Add the word at the point to the personal dictionary" (interactive) (let ((word (word-at-point))) (with-current-buffer (find-file-noselect "~/.aspell.english.pws") (end-of-buffer) (insert (concat word "\n")) (save-buffer) (kill-buffer nil)) (ispell-pdict-save t t) (flyspell-unhighlight-at (point)))) (defun tab-controller (mode) "Return the variable that sets the indentation width for MODE. This allows (mst-code-settings) to provide a consistent way of specifying the width of indentation that should be used" (case mode ((python-mode) 'py-indent-offset) ((c-mode c++-mode java-mode php-mode) 'c-basic-offset) ((sh-mode) 'sh-basic-offset) ((cperl-mode) (make-local-variable 'cperl-indent-level)) ((ruby-mode) 'ruby-indent-level) (t (make-local-variable 'dummy)))) (defun show-code-settings-in-modeline () (interactive) (let ((map (make-sparse-keymap))) (define-key map [mode-line mouse-1] (lambda () (interactive) (let ((use-dialog-box nil)) (mst-set-buffer-indentation)))) (list ':propertize (format " (%s)" (reduce (lambda (s1 s2) (if s1 (concat s1 s2) s2)) (list (if (my-code-p) "m" nil) (if indent-tabs-mode "tabs" (format "i%d" (symbol-value (tab-controller major-mode))))))) 'keymap map 'help-echo "Mouse-1: Set indentation mode for this buffer"))) (defvar mst-code-settings-map (make-sparse-keymap)) (define-key mst-code-settings-map (kbd "C-C C-t C-t") 'run-unit-tests) (define-key mst-code-settings-map (kbd "C-C e t") 'run-unit-tests) (define-key mst-code-settings-map (kbd "C-C e s") 'set-unit-test-command) (define-key mst-code-settings-map (kbd "C-c e e") 'open-unit-test-file) (define-key mst-code-settings-map (kbd "C-c s") 'ispell-comments-and-strings) (define-key mst-code-settings-map (kbd "C-c S") 'toggle-flyspell-code) ;; (define-key mst-code-settings-map (kbd "(") 'insert-parentheses) ;; (define-key mst-code-settings-map (kbd ")") 'move-past-close-and-reindent) (defun toggle-flyspell-code () (interactive) (when (not (boundp 'flyspell-status)) (make-variable-buffer-local 'flyspell-status)) (cond (flyspell-status (setq flyspell-status nil) (flyspell-mode-off)) (t (setq flyspell-status (not flyspell-status)) (flyspell-prog-mode)))) (defvar mst-tabs-here nil) (define-key mst-code-settings-map (kbd "RET") 'newline-and-indent) (define-minor-mode mst-code-settings-mode "Settings I use when coding" nil " mst" mst-code-settings-map (make-variable-buffer-local 'mst-tabs-here) ;; default settings ;; ;; (glasses-mode) (highlight-fixmes-mode 1) (condition-case err (hs-minor-mode 1) (error () (message "Note: %s" (error-message-string err)))) (filladapt-mode -1) (setq parens-require-spaces t) (setq show-trailing-whitespace t) (setq tab-width 8) (labels ((fix-tabs () (cond ((equal mst-tabs-here 'fix) (untabify (point-min) (point-max))) ((equal mst-tabs-here 'leave) nil) ((buffer-has-tabs-p) (cond ((y-or-n-p "Tabs found. Untabify buffer? ") (untabify (point-min) (point-max)) (when (y-or-n-p "Always untabify this buffer? ") (setq mst-tabs-here 'fix))) ((y-or-n-p "Leave tabs alone in future? ") (setq mst-tabs-here 'leave) ;; use tabs to remain consistent with stupidity. (setq tab-width 8) (setq indent-tabs-mode t))))))) (cond ((my-code-p) ;; fiddle with the code to make it more consistent (fix-tabs)) (t ;; try to adjust settings to match the style of the buffer (when (grok-buffer-settings) (multiple-value-bind (use-tabs width) (grok-buffer-settings) (setq indent-tabs-mode use-tabs) (set (tab-controller major-mode) width)))))) (unless (member '(:eval (show-code-settings-in-modeline)) mode-line-format) (setq mode-line-format (append (butlast mode-line-format) '((:eval (show-code-settings-in-modeline))) (last mode-line-format)))) (setq fill-column 79) (highlight-long-lines-mode 1)) (defun mst-code-settings (&optional indent-width tabs) "Set default settings that I use for most programming modes" (setq indent-tabs-mode tabs) (set (tab-controller major-mode) (or indent-width 4)) (mst-code-settings-mode 1)) (defun Footnote-reset () "Reset footnotes by brute force" (interactive) (setq footnote-text-marker-alist nil)) ;; The following defun is taken almost directly from erc.el. It's a great idea, ;; and I like to have it available elsewhere. (defun popup-input-buffer () "Provide a input buffer." (interactive) (let ((buffer-name (generate-new-buffer-name "*input*")) (mode (intern (completing-read "Mode: " (mapcar (lambda (e) (list (symbol-name e))) (apropos-internal "-mode$" 'commandp)) nil t)))) (pop-to-buffer (make-indirect-buffer (current-buffer) buffer-name)) (narrow-to-region (point) (point)) (funcall mode) (let ((map (copy-keymap (current-local-map)))) (define-key map (kbd "C-c C-c") (lambda () (interactive) (kill-buffer nil) (delete-window))) (use-local-map map)) (shrink-window-if-larger-than-buffer))) (defun group-list (lst num) "Group 'lst' into sublists of length 'num'" (cond ((null lst) nil) ((null (nthcdr num lst)) (list lst)) (t (cons (subseq lst 0 num) (group-list (nthcdr num lst) num))))) (defmacro screen-jump (screen) "A function to jump to some screen" `(lambda () (interactive) (escreen-goto-screen ,(eval screen)))) (defun mst-make-screen (key) "Make a new screen, and bind a key to select it" (interactive "kKey to bind:") (escreen-create-screen) (global-set-key key (screen-jump escreen-current-screen-number))) ;; this might explode (defun mst-configure-screen () (interactive) (let ((configuration (list (cons 0 "*scratch*") (cons gnus-screen "*Group*") (cons erc-screen (buffer-name (car (erc-buffer-list))))))) (loop (mapc (lambda (pair) (destructuring-bind (screen . buffer) pair (escreen-goto-screen screen) (force-switch-buffer buffer))) configuration) ;; check that it worked, and try again if it didn't (when (dolist (pair configuration t) (destructuring-bind (screen . buffer) pair (escreen-goto-screen screen) (unless (string= (buffer-name (current-buffer)) buffer) (return nil)))) (return t))))) (defun bind-key (key form) "Make a new screen, and bind a key to select it" (interactive "kKey to bind: xForm: ") (define-key global-map key `(lambda () (interactive) ,form))) (defun show-morse (start end) "Show the decoded version of some morse code in the minibuffer" (interactive "r") (narrow-to-region start end) (let* ((morse (buffer-string)) (text (with-temp-buffer (insert morse) (unmorse-region (point-min) (point-max)) (buffer-string)))) (widen) (message text))) (defun visible-buffers () (let ((buffers '())) (walk-windows (lambda (w) (push (window-buffer w) buffers))) buffers)) (defun force-switch-buffer (buffer) "Switch to a buffer (overcomes a problem with gnuserv and escreens)" (interactive "bBuffer name: ") (list-buffers) (other-window 1) (goto-char (point-min)) (search-forward buffer nil nil nil) (Buffer-menu-this-window) (delete-other-windows) (kill-buffer "*Buffer List*")) (defun group-by (list key) "Group LIST by items whose KEY values are equal" (let ((groups (make-hash-table :test 'equal))) (mapc (lambda (elt) (push elt (gethash (funcall key elt) groups))) list) (let ((acc '())) (maphash (lambda (k v) (push (cons k v) acc)) groups) acc))) (defun buffer-mode (buffer) "Return the major mode of BUFFER" (save-excursion (set-buffer buffer) major-mode)) (defun buffer-lines () "return the number of lines in the current buffer" (save-excursion (goto-char (point-min)) (loop while (progn (end-of-line) (not (eobp))) count t do (next-line 1)))) (defun perl-wrap-string (start finish) "Wrap a perl string by making it into a bunch of concatenated strings" (interactive "r") (require 'perl-mode) (goto-char start) (loop do (forward-char) while (not (looking-at "\""))) (forward-char) (loop with last-space = nil with last-char = nil do (cond ((> (current-column) (- fill-column 5)) (goto-char last-space) (insert "\" .\"") (backward-char 1) (newline) (perl-indent-command)) ((looking-at "\n") (delete-char 1)) ((looking-at " ") (setq last-space (point))) (t nil)) (forward-char) while (or (not (looking-at "\"")) (string= last-char "\\")))) (defun perl-unwrap-string (start finish) "Wrap a perl string by making it into a bunch of concatenated strings" (interactive "r") (let ((string-start start) (string-finish finish)) (goto-char string-start) (while (not (looking-at "\"")) (incf string-start) (forward-char)) (goto-char string-finish) (while (not (looking-at "\"")) (decf string-finish) (backward-char)) (replace-regexp "\\(\" \\.\\|^ *\"\\|\n\\)" "" nil string-start string-finish))) ;; more fun but overflows sometimes. ;; (defun do-once (hook fn) ;; (let ((hook-fn (list nil))) ;; (setcar hook-fn 'lambda) ;; (setcdr hook-fn `((&rest args) ;; (apply ',fn args) ;; (remove-hook ',hook ,hook-fn))) ;; (add-hook hook hook-fn))) (defun do-once (hook fn) "Add FN to hook and set it to be removed" (let ((hook-fn (gensym))) (setf (symbol-function hook-fn) `(lambda (&rest args) (unwind-protect (apply ,fn args) (remove-hook ',hook ',hook-fn)))) (add-hook hook hook-fn))) (defun noweb-view () (interactive) (shell-command-to-string (format "noweave -delay -x %s > %s.tex" (buffer-file-name) (file-name-sans-extension (buffer-file-name)))) (shell-command-to-string (format "latex %s.tex" (file-name-sans-extension (buffer-file-name)))) (shell-command-to-string (format "latex %s.tex" (file-name-sans-extension (buffer-file-name)))) (start-process "xdvi" nil "xdvi" (format "%s.dvi" (file-name-sans-extension (buffer-file-name))))) ;; for (java-class-lookup) (defvar java-api-base nil "The base directory of the javadoc API") (defvar java-api-index nil "Path to a file containing a bunch of javadoc HTML files relative to java-api-base") (defvar *java-index* nil) (defun java-class-read-index (&optional force) (when (or (not *java-index*) force) (setq *java-index* nil) (with-temp-buffer (insert-file java-api-index) (goto-char (point-min)) (while (not (eobp)) (let ((path (buffer-substring (line-beginning-position) (line-end-position)))) (push (cons (replace-regexp-in-string "/" "." (file-name-sans-extension path)) path) *java-index*)) (forward-line 1)))) *java-index*) (defun completing-read-isearch (table callback) (with-current-buffer (get-buffer-create " *isearch completions*") (erase-buffer) (dolist (elt table) (insert (propertize (concat (car elt) "\n") 'dest (cdr elt)))) (goto-char (point-min)) (let ((map (make-sparse-keymap))) (define-key map (kbd "RET") `(lambda () (interactive) (let ((target (get-text-property (point) 'dest))) (delete-window) (funcall ,callback target)))) (define-key map (kbd "q") 'bury-buffer) (use-local-map map))) (pop-to-buffer (get-buffer-create " *isearch completions*"))) (defun java-class-lookup () (interactive) (completing-read-isearch (java-class-read-index) (lambda (doc) (w3m-with-saved-window-configuration (format "file://%s/%s" (expand-file-name java-api-base) doc) nil)))) (defun my-string-to-number (s) "Convert a string to a number. Returns NIL if this is not possible." (let ((n (condition-case () (destructuring-bind (r . i) (read-from-string s) (if (and r (= (length s) i)) r nil)) (invalid-read-syntax () nil)))) (if (numberp n) n nil))) (defmacro with-working-directory (dir &rest body) (let ((old (gensym))) `(let ((,old default-directory)) (cd ,dir) (prog1 (progn ,@body) (cd ,old))))) (put 'with-working-directory 'lisp-indent-function 1) (defvar my-lisps '(("cmu" . "*cmulisp*") ("clisp" . "*clisp-hs*") ("shell" . "*clisp-shell*"))) (defun lispshell () (interactive) (ignore-errors (kill-buffer "*ilisp-send*")) (clisp-hs "clisp-shell" "/usr/bin/clisp -M /home/mst/.bin/shell.mem -q -ansi")) (defun set-lisp () "A quick hack to make it easier to jump between different lisps" (interactive) (when (eq major-mode 'lisp-mode) (setq ilisp-buffer (cdr (assoc (completing-read "Use dialect: " my-lisps) my-lisps))))) (defun number-lines-region (start end &optional fmt) "Prepend a line number to each line in the current region. If a prefix arg is used, number blank lines too." (interactive "r\nsFormat string (default \"%%d.\"): ") (let* ((fmt (if (string= fmt "") "%d." fmt )) (lines (count-lines start end)) (width (length (format fmt lines)))) (save-excursion (goto-char start) (let ((ctr 0)) (dotimes (i lines) (beginning-of-line) (when (or current-prefix-arg (not (looking-at "^$"))) (insert (format (concat "%-" (number-to-string width) "s ") (format fmt (incf ctr))))) (next-line 1)))))) (defun reselect-last-region () (interactive) (let ((start (mark t)) (end (point))) (goto-char start) (call-interactively' set-mark-command) (goto-char end))) (defun maybe-with-region (cmd) "Return a lambda that calls region command CMD on the current region, or on the last region if the mark is not active" `(lambda () (interactive) (if mark-active (call-interactively ',cmd) (funcall ',cmd (min (mark t) (point)) (max (mark t) (point)))))) (flet ((eql (&rest args) (apply 'string= args))) (eql "hi" "hi")) (defmacro string-case (form &rest clauses) `(flet ((eql (&rest args) (apply 'string= args))) (case ,form ,@clauses))) (put 'string-case 'lisp-indent-function 1) (defun eval-file () "Do whatever is necessary to run the code in the current file" (interactive) (string-case (file-name-extension (buffer-file-name)) ("c" (let ((tmp (make-temp-file "c"))) (shell-command (format "gcc -o %s %s" tmp (buffer-file-name)) "compile" "compile") (shell-command (format "%s; rm -f %s" tmp tmp)))) ("pl" (shell-command (format "chmod u+x %s" (buffer-file-name))) (shell-command (buffer-file-name))) ("hs" (shell-command (format "hugs %s" (buffer-file-name)))))) (defun eshell-with-command (command) (interactive "sCommand? ") (let ((eshell-buffer (eshell))) (with-current-buffer eshell-buffer (insert command) (eshell-send-input)) eshell-buffer)) ;; Hugs running stuff (defvar *hugs-buffer* nil) (defun hugs-run () (interactive) (split-window-vertically) (setq *hugs-buffer* (eshell-with-command "hugs"))) (defun hugs-load (&optional file) "Load FILE (or the current buffer-file) in the currently running hugs" (interactive) (let ((loadfile (or file (buffer-file-name)))) (with-current-buffer *hugs-buffer* (insert (format ":load %s" loadfile)) (eshell-send-input)))) (defun slime-lisp (cmdline) (interactive "sLisp command line?: ") (let ((inferior-lisp-program cmdline)) (call-interactively 'slime))) (defun remove-properties-from-string (s) (let ((s (copy-sequence s))) (set-text-properties 0 (length s) nil s) s)) (defun current-function-name () (save-excursion (backward-up-list) (forward-char 1) (remove-properties-from-string (thing-at-point 'symbol)))) ;; Just messing around.. (defmacro keyword-defun (&rest spec) (flet ((plist-to-let (plist) (cond ((null plist) nil) ((null (cdr plist)) (error "Invalid plist")) (t (cons (list (intern (subseq (symbol-name (car plist)) 1)) (cadr plist)) (plist-to-let (cddr plist))))))) (destructuring-bind (name args . body) spec (destructuring-bind (args keywords) (if (position '&key args) (list (subseq args 0 (position '&key args)) (subseq args (1+ (position '&key args)))) (list args '())) `(defun ,name (&rest spec1) (destructuring-bind ,args (subseq spec1 0 ,(length args)) (let ,keywords (map nil #'(lambda (pair) (set (car pair) (cadr pair))) (plist-to-let (subseq spec1 ,(length args)))) ,@body))))))) (defun trim-region (start end) (interactive "r") (replace-regexp " +$" "" nil start end) (replace-regexp "^ +" "" nil start end)) (defun diff-buffer-if-modified (&optional buffer) (when (and (buffer-file-name buffer) (buffer-modified-p buffer)) (set-buffer (or buffer (current-buffer))) (let ((tmp (make-temp-file "buffer-contents"))) (unwind-protect (progn (write-region (point-min) (point-max) tmp) (shell-command (format "diff -c %s %s" (buffer-file-name) tmp) "*Changes*")) (delete-file tmp))) (view-buffer-other-window "*Changes*") (other-window 1))) (defun dired-cwd-other-window () (interactive) (let ((dired-listing-switches "-laR")) (dired-other-window default-directory))) (defun view-file-other-temp-frame (&optional file) "Same as VIEW-FILE-OTHER-FRAME, but destroy the frame when it is exited" (interactive "fIn other frame view file: ") (let ((b (find-file-noselect file))) (with-current-buffer b (setq view-exit-action (lambda (buffer) (kill-buffer buffer) (delete-frame))) (view-mode)) (switch-to-buffer-other-frame b))) ;; An ugly hack. It works and that's all I'll say in its defence. (defun bison--type-action-block () (interactive) (indent-to-column bison-rule-semantic-action-column) (lexical-let* ((orig-buf (current-buffer)) (orig-pt nil) (temp-file (make-temp-file "action")) (offset (+ (current-column) c-basic-offset))) (insert "{\n") (setq orig-pt (point-marker)) (find-file-other-window temp-file) (c-mode) (setq fill-column (- fill-column offset)) (setq mode-line-format "Press C-c C-c when finished") (let ((map (copy-keymap (current-local-map)))) (define-key map (kbd "C-c C-c") (lambda () (interactive) (save-buffer) (let ((contents (mapcar #'(lambda (line) (if (string= line "") "\n" (concat (make-string offset 32) line "\n"))) (split-string (buffer-string) "\n")))) (kill-buffer-and-window) (switch-to-buffer orig-buf) (goto-char (marker-position orig-pt)) (mapc 'insert contents) (delete-file temp-file) (delete-blank-lines) (indent-to-column bison-rule-semantic-action-column) (insert "}")))) (use-local-map map)))) (defun count-words-region (beg end &optional ssh) (interactive "r") (save-excursion (narrow-to-region beg end) (unwind-protect (progn (goto-char (point-min)) (let ((count 0)) (while (and (not (eobp)) (forward-word 1)) (incf count)) (unless ssh (message "Region has %d words." count)) (setq deactivate-mark t) count)) (widen)))) (defun count-words-document (&optional ssh) "Count the number of words in the document part of the current LaTeX buffer." (interactive) (save-excursion (let ((contents (if mark-active (buffer-substring (region-beginning) (region-end)) (goto-char (point-min)) (buffer-substring (progn (search-forward "\\begin{document}" nil t) (match-end 0)) (progn (search-forward "\\end{document}" nil t) (match-beginning 0)))))) (with-temp-buffer (insert contents) (goto-char (point-min)) (delete-matching-lines "^%" (point-min) (point-max)) (goto-char (point-min)) (while (search-forward-regexp "^\\\\begin{\\(quot[^}]*\\)}" nil t) (let ((p (match-beginning 0))) (search-forward-regexp (format "^\\\\end{%s}" (match-string 1))) (delete-region p (point)))) (delete-matching-lines "^\\\\begin" (point-min) (point-max)) (delete-matching-lines "^\\\\end" (point-min) (point-max)) (count-words-region (point-min) (point-max) ssh))))) (defmacro with-frame-display (&rest body) "Evaluate BODY with the DISPLAY environment variable set to the display the current frame is on." (let ((display (gensym))) `(let ((,display (getenv "DISPLAY"))) (setenv "DISPLAY" (frame-parameter (selected-frame) 'display)) (when (string= (getenv "DISPLAY") ":1") (setenv "DISPLAY" "mozart:0")) ,@body (setenv "DISPLAY" ,display)))) (defun cycle-zippy () (interactive) (set-marker (mark-marker) (point) (current-buffer)) (insert (yow)) (let ((event nil)) (while (= (setq event (read-event)) ?z) (delete-region (mark t) (point)) (set-marker (mark-marker) (point) (current-buffer)) (insert (yow)) (message "Press z again to repeat")) (setq unread-command-events (list event)))) (defun current-line-number () "Return (narrowed) buffer line number at position POS. If POS is nil, use current buffer location." (let ((opoint (point)) start) (save-excursion (goto-char (point-min)) (setq start (point)) (goto-char opoint) (forward-line 0) (1+ (count-lines start (point)))))) (defun playlist () (interactive) (with-frame-display (start-process "playlist" nil "xterm" "-e" "~/.bin/playlist"))) (defun music () (interactive) (start-process "music" nil "music")) (defun wikipedia (&optional search) (interactive "sTopic?: ") (when (featurep 'escreen) (escreen-goto-screen w3m-screen)) (w3m-goto-url-new-session (format "http://en.wikipedia.org/wiki/Special:Search?search=%s" search))) (defun google (&optional search) (interactive "sSearch for?: ") (when (featurep 'escreen) (escreen-goto-screen w3m-screen)) (w3m-goto-url-new-session (format "http://google.com/search?q=%s" search))) (defun google-groups (&optional search) (interactive "sSearch for?: ") (when (featurep 'escreen) (escreen-goto-screen w3m-screen)) (w3m-goto-url-new-session (format "http://groups.google.com/groups?q=%s" search))) (defun chmod () (interactive) (shell-command (format "chmod %s %s" (read-from-minibuffer "Mode string?: " "u+x") (buffer-file-name)))) (defun reload-library () (interactive) (let ((old (symbol-function 'defvar))) (defmacro defvar (symbol &optional initvalue docstring) `(setq ,symbol ,initvalue)) (unwind-protect (call-interactively 'load-library) (setf (symbol-function 'defvar) old)))) (defun mst-button (text callback) (let ((map (make-sparse-keymap))) (dolist (key (list (kbd "RET") [mouse-1])) (define-key map key callback)) (let ((p (point))) (insert-button text 'keymap map 'face '(:background "gray90" :box (:line-width 2 :style released-button))) (set-text-properties p (point) '(rear-nonsticky t front-sticky t read-only t))))) (defmacro with-buffer-preserved (buffer-name &rest body) "Move BUFFER-NAME out of the way while executing BODY" (let ((tmp-name (gensym))) `(if (get-buffer ,buffer-name) (let ((,tmp-name (generate-new-buffer-name ,buffer-name))) (with-current-buffer (get-buffer ,buffer-name) (rename-buffer ,tmp-name)) (unwind-protect (progn ,@body) (kill-buffer ,buffer-name) (with-current-buffer ,tmp-name (rename-buffer ,buffer-name)))) (progn ,@body)))) (put 'with-buffer-preserved 'lisp-indent-function 1) (defun kill-buffer-show-diff () "Kill the current buffer, showing a diff if it has been modified." (interactive) (if (and (buffer-modified-p) (buffer-file-name) (not (string= (buffer-file-name) "")) (file-exists-p (buffer-file-name))) (save-window-excursion (with-buffer-preserved "*Diff*" (diff-buffer-with-file) (call-interactively 'kill-buffer))) (call-interactively 'kill-buffer))) (defun tex-to-text () (interactive) (let ((tex (current-buffer)) (text (get-buffer-create (format "%s text" (buffer-name (current-buffer)))))) (switch-to-buffer text) (text-mode) (insert-buffer-substring-no-properties tex) (goto-char (point-min)) (while (not (looking-at "^\\\\begin{document}")) (delete-region (point-at-bol) (1+ (point-at-eol)))) (delete-matching-lines "^\\\\\\(begin\\|end\\|newpage\\)") (save-excursion (let ((section 1) (subsection 0) (subsubsection 0)) (while (not (eobp)) (cond ((looking-at "\\\\section{") (save-excursion (replace-regexp "^.*{\\(.*\\)} *$" "\\1" nil (point) (point-at-eol))) (insert (format "%d. " section)) (setq section (1+ section) subsection 0 subsubsection 0)) ((looking-at "\\\\subsection{") (save-excursion (replace-regexp "^.*{\\(.*\\)} *$" "\\1" nil (point) (point-at-eol))) (insert (format "%d.%d. " section subsection)) (setq subsection (1+ subsection) subsubsection 0)) ((looking-at "\\\\subsubsection{") (save-excursion (replace-regexp "^.*{\\(.*\\)} *$" "\\1" nil (point) (point-at-eol))) (insert (format "%d.%d.%d. " section subsection subsubsection)) (setq subsubsection (1+ subsubsection))) (t nil)) (forward-line 1)))) (save-excursion (dolist (replacement '(("\\item" "*") ("\\$" "$") ("\\%" "%"))) (goto-char (point-min)) (apply 'replace-string replacement))) (save-excursion (while (re-search-forward "\\\\[^ {]+{\\([^}]+\\)}" nil t) (replace-match "\\1" nil nil) (goto-char (match-beginning 0)))) (save-excursion (replace-regexp "\[^{]+{\\([^}]+\\)}" "\\1")) (save-excursion (replace-regexp "\\(``\\|''\\)" "\"")))) (defun swap-buffer-names (buffer1 buffer2) (interactive "bBuffer 1: \nbBuffer 2: ") (let ((tmp-name (generate-new-buffer-name "temp")) (buffer1-name buffer1) (buffer2-name buffer2)) (with-current-buffer buffer1 (rename-buffer tmp-name)) (with-current-buffer buffer2 (rename-buffer buffer1-name)) (with-current-buffer tmp-name (rename-buffer buffer2-name)))) (defun fix-whitespace (beg end) (interactive "r") (save-excursion (replace-regexp "[[:blank:]]+$" "" nil beg end))) (defun fix-whitespace-buffer () (interactive) (fix-whitespace (point-min) (point-max)) (save-excursion (goto-char (point-max)) (delete-blank-lines))) ;; GUD hacks (defun gud-select-source-window () (interactive) (select-window (find-if (lambda (w) (eq (window-buffer w) gud-comint-buffer)) (window-list))) (other-window 2)) (defun gud-select-current-source () (interactive) (let ((w (selected-window))) (gud-select-source-window) (when (stringp (car gud-last-last-frame)) (switch-to-buffer (gud-find-file (car gud-last-last-frame)))) (select-window w))) ;; This is probably dangerous :o) (eval-after-load "gud" '(progn (defadvice gud-display-frame (after update-src-buffer activate) (when (eq gud-minor-mode 'gdba) (gud-select-current-source))))) ;; Beanshell comint stuff (defun bsh-start () (interactive) (when (and (get-buffer "*bsh*") (y-or-n-p "Kill existing *bsh*? ")) (kill-buffer "*bsh*")) (if (get-buffer "*bsh*") (switch-to-buffer-other-window "*bsh*") (switch-to-buffer-other-window (comint-run "bsh"))) (with-current-buffer "*bsh*" (set (make-local-variable 'comint-move-point-for-output) t) (let ((proc (get-buffer-process (current-buffer)))) (comint-send-string proc "show();") (comint-send-string proc "addClassPath(\".\");")))) (defun trim-trailing (s &rest strings) "From S, trim any trailing STRINGS" (with-temp-buffer (insert s) (goto-char (point-max)) (while (some (lambda (str) (looking-back str)) strings) (delete-backward-char 1)) (buffer-string))) (defun mst-region-string (beg end) (interactive "r") (trim-trailing (buffer-substring-no-properties beg end) "\n")) (defun bsh-send-command (s) (let ((proc (get-buffer-process "*bsh*"))) (with-current-buffer (process-buffer proc) (goto-char (point-max)) (insert s) (comint-send-input)))) (defun bsh-send-defun-or-line (&optional print-result) (interactive "P") (unless (get-buffer "*bsh*") (bsh-start)) (save-excursion (let ((command (let ((limits (save-excursion (when (looking-back "^") (backward-char 1)) (when (looking-back "[;}]") (backward-char 1)) (c-declaration-limits t)))) (cond (mark-active (concat (mst-region-string (region-beginning) (region-end)) "\n")) (limits (mst-region-string (car limits) (cdr limits))) (t (mst-region-string (line-beginning-position) (line-end-position))))))) (if print-result (bsh-send-command (format "System.err.println (String.valueOf (%s));" (trim-trailing command ";"))) (bsh-send-command command))))) ;; Python comint stuff (defun python-start () (interactive) (py-shell) (let ((proc (get-buffer-process (current-buffer)))) (comint-send-string proc "import sys\n") (comint-send-string proc "sys.ps2=\"\"\n"))) (defun python-send-command (s) (let ((proc (get-buffer-process "*Python*"))) (with-current-buffer (process-buffer proc) (set (make-local-variable 'comint-move-point-for-output) t) (goto-char (point-max)) (insert s) (comint-send-input)))) (defun python-send-defun-or-line () (interactive) (let ((command (cond (mark-active (concat (mst-region-string (region-beginning) (region-end)) "\n")) ((or (ignore-errors (py-mark-def-or-class t)) (ignore-errors (py-mark-def-or-class))) (concat (mst-region-string (mark) (point)) "\n")) (t (mst-region-string (line-beginning-position) (line-end-position)))))) (python-send-command (with-temp-buffer (insert command) (delete-matching-lines "^ *$" (point-min) (point-max)) (buffer-string))))) (defun view-with-major-mode (&optional mode) "Create a clone of the current buffer in major-mode MODE." (interactive (list (intern (completing-read "Mode: " (mapcar (lambda (e) (list (symbol-name e))) (apropos-internal "-mode$" 'commandp)) nil t)))) (let ((buf (generate-new-buffer-name (buffer-name (current-buffer))))) (switch-to-buffer (make-indirect-buffer (current-buffer) buf))) (funcall mode)) (defun mst-shell-command (command) (with-temp-buffer (let ((return (call-process "sh" nil (current-buffer) nil "-c" command))) (cons (if (> (buffer-size) 0) (subseq (buffer-string) 0 -1) "") return)))) (defun cperl-reindent-defun () (interactive) (save-excursion (beginning-of-defun) (forward-list) (backward-list) (cperl-indent-exp))) ;; Run unit tests using the compile command. (defun test-with-compile (test-command) (do-once 'compilation-finish-functions `(lambda (buffer status) (with-current-buffer ,(current-buffer) (cond ((string-match "finished" status) (show-test-status 'passed) (set-window-configuration ,(current-window-configuration))) (t (show-test-status 'failed)))))) (ignore-errors (kill-buffer (funcall compilation-buffer-name-function major-mode))) (compile test-command) 'handled) (defun test-with-make () (interactive) (test-with-compile "make test")) (defun test-file-prepend (prefix file) (concat (file-name-directory file) "/" prefix (file-name-nondirectory file))) ;; The following code doesn't quite work, but it might be useful one day. (defun python-wait-for-test-results (string) (let ((status (cond ((string-match "errors=[1-9]" string) 'failed) ((string-match "failures=[1-9]" string) 'failed) ((string-match "errors=0.*failures=0" string) 'passed) (t nil)))) (when status (show-test-status status) (setq comint-preoutput-filter-functions (delq 'python-wait-for-test-results comint-preoutput-filter-functions))) string)) (defun run-python-tests () (interactive) (with-current-buffer "*Python*" (add-hook 'comint-preoutput-filter-functions 'python-wait-for-test-results nil t) (python-send-command "runner.run (suite)") 'handled)) (defun emacs-wiki->moin () "Convert the current emacs-wiki buffer to moin format." (interactive) (let* ((buffer (current-buffer)) (buffer-name (format "%s " (buffer-name (current-buffer)))) (new-buffer (get-buffer-create buffer-name))) (with-current-buffer new-buffer (erase-buffer) (insert-buffer buffer) (goto-char (point-min)) (while (search-forward-regexp "^\\(\\*+\\)" nil t) (delete-region (match-beginning 1) (match-end 1)) (beginning-of-line) (let ((length (- (match-end 1) (match-beginning 1)))) (insert (make-string length ?=)) (end-of-line) (insert (concat " " (make-string length ?=))))) (replace-regexp "\\[\\[\\([^[]+\\)\\]\\]" "[\"\\1\"]" nil (point-min) (point-max)) (replace-regexp "^\\( +\\)-" "\\1*" nil (point-min) (point-max)) ) (pop-to-buffer new-buffer))) (defvar *break-time* 10 "The number of seconds to wait during a typing break.") (defun stop-break () (setq ignore-keystrokes nil)) (defun start-break () (interactive) (setq ignore-keystrokes t) (run-with-timer *break-time* nil 'stop-break) (let ((inhibit-quit t)) (while ignore-keystrokes (message "This is a typing break. Go do something else.") (when (input-pending-p) (read-event) (message "You're meant to be resting!")) (sit-for 0.5)) (setq quit-flag nil)) (message "Break's over! Back on your head!")) (defun cperl-beginning-of-function () (interactive) (if (save-excursion (beginning-of-line) (looking-at "^sub")) (beginning-of-line) (unless (save-excursion (beginning-of-line) (looking-at "^{")) (let ((beginning-of-defun-function nil)) (beginning-of-defun))) (search-backward-regexp "^sub" nil t))) (defun cperl-end-of-function () (interactive) (cperl-beginning-of-function) (forward-list)) (defun cperl-send-function () (interactive) (let ((beg (save-excursion (cperl-beginning-of-function) (point))) (end (save-excursion (cperl-end-of-function) (point)))) (cperl-send-region beg end t) (message "Sent %d chars" (- end beg)))) (defun cperl-send-region (beg end &optional quiet) (interactive "r") (let ((region (buffer-substring-no-properties beg end))) (with-temp-buffer (insert region) (flet ((message (&rest ignored) nil)) (replace-regexp "#.*$" "" nil (point-min) (point-max)) (replace-string (string 10) " " nil (point-min) (point-max))) (cperl-send-command (buffer-string) quiet)))) (defun cperl-send-line () (interactive) (cperl-send-region (line-beginning-position) (line-end-position))) (defun cperl-send-command (s &optional quiet) (cperl-show) (let ((proc (get-buffer-process "*Perl*"))) (with-current-buffer (process-buffer proc) (set (make-local-variable 'comint-move-point-for-output) t) (if quiet (comint-send-string proc s) (goto-char (point-max)) (insert s) (comint-send-input))))) (defun cperl-show () (interactive) (cond ((get-buffer "*Perl*") (let ((old (selected-window))) (let ((buffer (pop-to-buffer "*Perl*"))) (select-window old) buffer))) (t (error "Perl isn't running")))) (defun cperl-repl () (interactive) (when (and (get-buffer "*Perl*") (y-or-n-p "Kill existing *Perl*? ")) (kill-buffer "*Perl*")) (if (get-buffer "*Perl*") (switch-to-buffer-other-window "*Perl*") (save-window-excursion (comint-run "perl-repl.pl") (rename-buffer "*Perl*"))) (with-current-buffer (cperl-show) (set (make-local-variable 'comint-move-point-for-output) t) (cperl-send-command "$^W = 0"))) (defun format-for-mode (beg end) (interactive "r") (let ((mode (intern (completing-read "Mode: " (mapcar (lambda (e) (list (symbol-name e))) (apropos-internal "-mode$" 'commandp)) nil t)))) (let ((buf (generate-new-buffer-name (buffer-name (current-buffer))))) (with-current-buffer (make-indirect-buffer (current-buffer) buf) (funcall mode) (let ((inhibit-read-only t)) (narrow-to-region beg end) (unwind-protect (indent-region (point-min) (point-max) nil) (widen))) (kill-buffer nil))))) (when (try-require 'timeclock) (defun timeclock-grok-time (time-string) (destructuring-bind (year month day hour min sec) (mapcar 'string-to-number (split-string time-string "[: /]")) (encode-time sec min hour day month year))) (defun timeclock-current-project-line () (save-excursion (beginning-of-line) (search-forward-regexp " \\([^ ]*\\)$") (match-string 1))) (defun timeclock-current-project-time () (save-excursion (beginning-of-line) (search-forward-regexp "^[io] \\(.*\\) [^ ]*$") (match-string 1))) (defun timeclock-total-project-time (project) (timeclock-reread-log) (let ((total 0)) (with-current-buffer (find-file-noselect "~/.timelog") (goto-char (point-min)) (while (search-forward-regexp "^i " nil t) (when (string= project (timeclock-current-project-line)) (let ((start-time (time-to-seconds (timeclock-grok-time (timeclock-current-project-time))))) (next-line 1) (let ((end-time (time-to-seconds (timeclock-grok-time (timeclock-current-project-time))))) (incf total (- end-time start-time))))))) (let* ((hours (truncate (truncate total 60) 60)) (minutes (- (truncate total 60) (* hours 60))) (seconds (- total (* hours 60 60) (* minutes 60)))) (format "%.2d:%.2d:%.2d" hours minutes seconds)))) (defun timeclock-project-time (project) (interactive (list (completing-read "Project: " (mapcar #'list timeclock-project-list)))) (message "Total time spent on %s: %s" project (timeclock-total-project-time project)))) (defun scale-image-to-frame (image) (let ((width (truncate (frame-pixel-width) 2)) (data (getf (cdr image) :data)) (type (getf (cdr image) :type))) (with-temp-buffer (set-buffer-multibyte nil) (insert data) (let ((coding-system-for-read 'binary) (coding-system-for-write 'binary) (buffer-file-coding-system 'binary)) (shell-command-on-region (point-min) (point-max) (format "convert -geometry %dx /dev/stdin /dev/stdout" width) nil t) `(image :type ,type :data ,(buffer-string)))))) (defun fit-this-image () (interactive) (let ((image (get-text-property (point) 'display))) (unless image (error "No image at point!")) (save-excursion (let (start end) (while (get-text-property (point) 'display) (backward-char 1)) (forward-char 1) (setq start (point)) (while (get-text-property (point) 'display) (forward-char 1)) (setq end (point)) (let ((inhibit-read-only t)) (set-text-properties start end `(display ,(scale-image-to-frame image)))))))) (defun run-all-java-tests () (let ((output (get-buffer-create "*junit*")) (inhibit-read-only t)) (with-current-buffer output (erase-buffer)) (let ((result (reduce #'+ (mapcar (lambda (class-file) (call-process "junit" nil output nil (file-name-sans-extension class-file))) (directory-files "." nil "Test.*class"))))) (if (= result 0) t (pop-to-buffer output) (compilation-mode) nil)))) (defun read-major-mode (&optional prompt) (intern (completing-read (or prompt "Major mode?:") (mapcar (lambda (e) (list (symbol-name e))) (apropos-internal "-mode$" 'commandp)) nil t))) (define-minor-mode inline-code-mode nil nil " code" nil (if inline-code-mode (let ((mode (read-major-mode "Major mode for code blocks?: "))) (mmm-mode 1) (mmm-ify :submode mode :front "" :back "")) (mmm-mode -1))) (defvar remote-buffers '()) (defun get-remote-buffer (host) (if (and (assoc host remote-buffers) (buffer-live-p (cdr (assoc host remote-buffers)))) (cdr (assoc host remote-buffers)) (let ((buffer (find-file-noselect (format "/%s:.remote" host)))) (with-current-buffer buffer (ignore-errors (kill-buffer (format " *%s remote*" host))) (rename-buffer (format " *%s remote*" host))) (push (cons host buffer) remote-buffers) buffer))) (defvar remote-shell-last-host nil) (defvar remote-shell-history '()) (defun remote-shell-do-command (host command &optional separate-errors) (let ((buffer (get-remote-buffer host))) (with-current-buffer buffer (let* ((output-buffer (get-buffer-create "*remote-out*")) (error-buffer (if separate-errors (get-buffer-create "*remote-errors*") output-buffer))) (let ((result (save-window-excursion (tramp-handle-shell-command command output-buffer error-buffer)))) (unwind-protect (list result (with-current-buffer output-buffer (buffer-string)) (if separate-errors (with-current-buffer error-buffer (buffer-string)) nil)) (kill-buffer output-buffer) (when separate-errors (kill-buffer error-buffer)))))))) (defun replace-buffer-contents (buffer contents) (let ((inhibit-read-only t)) (with-current-buffer buffer (erase-buffer) (fundamental-mode) (insert contents)))) (defun remote-shell-command (host command &optional output-buffer error-buffer) (interactive (list (read-from-minibuffer "Host: " remote-shell-last-host) (read-from-minibuffer "Command: " nil nil nil 'remote-shell-history))) (setq remote-shell-last-host host) (destructuring-bind (return-code output errors) (if (and output-buffer error-buffer (not (eq output-buffer error-buffer))) (remote-shell-do-command host command t) (remote-shell-do-command host command)) (if (or current-prefix-arg output-buffer error-buffer) (if current-prefix-arg (insert output) (when output-buffer (replace-buffer-contents output-buffer output)) (when error-buffer (replace-buffer-contents error-buffer errors))) (when (interactive-p) (if (string= output "") (when (interactive-p) (message "No output")) (let ((buffer (get-buffer-create "*Remote command output*"))) (replace-buffer-contents buffer output) (display-buffer buffer))))) (list return-code output errors))) (defun test-with-remote-compile (host command) (let ((result (remote-shell-command host command))) (if (zerop (car result)) t (let ((buffer (get-buffer-create "*Test result*"))) (with-current-buffer buffer (let ((inhibit-read-only t)) (erase-buffer) (insert (cadr result)) (compilation-mode))) (display-buffer buffer) nil)))) (defun w3m-with-saved-window-configuration (url new-window) (let ((window-configuration (current-window-configuration))) (unless (member (current-buffer) (w3m-list-buffers)) (select-window (split-window-vertically))) (w3m-browse-url url nil) (let ((hs-map (copy-keymap w3m-mode-map))) (define-key hs-map (kbd "q") `(lambda () (interactive) (kill-buffer nil) (set-window-configuration ,window-configuration))) (use-local-map hs-map)))) (defun define-project-tests () (interactive) (let ((dir default-directory) (command (or unit-test-command (lambda () (test-with-compile "make test")))) (file-fn (or unit-test-file-fn (lambda (filename) (if (string-match "/test_" filename) (unprefix-file-name filename "tests/test_") (prefix-file-name filename "tests/test_")))))) (let ((buffer (get-buffer-create "*new-project*"))) (with-current-buffer buffer (erase-buffer) (insert (format "%S" `(define-project ,(intern (read-from-minibuffer "Project name (symbol)? ")) (,(expand-file-name (read-directory-name "Project root directory? " nil nil t (expand-file-name dir)))) (setq unit-test-file-fn ,file-fn) (setq unit-test-command ,command))))) (pop-to-buffer buffer)))) (defun tags-create (&optional directory) (interactive) (let* ((directory (or directory (concat (read-directory-name "Directory? " nil nil t default-directory) "/"))) (default-directory directory)) (shell-command "ctags-exuberant -R -e --extra=+fq") (setq tags-file-name (concat directory "TAGS")))) (defun tags-update () (interactive) (let ((default-directory (file-name-directory tags-file-name))) (shell-command "ctags-exuberant -a -R -e --extra=+fq"))) (defvar document-file-dir "~/docs/filing") (defun file-document-path (number) (format "%s/%d" (expand-file-name document-file-dir) number)) (defun file-document () (interactive) (make-directory (expand-file-name document-file-dir) t) (let ((title (read-string "Document title: ")) (notes (read-string "Notes: ")) (tax-p (y-or-n-p "Required for tax purposes? "))) (when (string= title "") (error "Title can't be blank")) (let ((next-number (loop for i from 0 unless (file-exists-p (file-document-path i)) return i))) (with-current-buffer (find-file-noselect (file-document-path next-number)) (insert (format "Date: %s\n" (time-stamp-string "%:Y-%:m-%:d-%:H:%:M:%:S"))) (insert (format "Title: %s\n" title)) (insert (format "Notes: %s\n" notes)) (insert (format "Required for tax: %s\n" tax-p)) (save-buffer nil) (kill-buffer nil)) (message "Document saved as #%d" next-number)))) (defun mst-insert-at (pos string) (save-excursion (goto-char pos) (insert string))) (defun wrap-region-with-chars (region-start-str region-end-str) `(lambda () (interactive) (if mark-active (let ((point (point)) (start (region-beginning)) (end (region-end))) (mst-insert-at end ,region-end-str) (mst-insert-at start ,region-start-str) (goto-char point) (if (= point end) (goto-char (+ end (length ,region-start-str) (length ,region-end-str))) (goto-char start))) (call-interactively 'self-insert-command)))) (define-key global-map (kbd "(") (wrap-region-with-chars "(" ")")) (define-key global-map (kbd "\"") (wrap-region-with-chars "\"" "\"")) (define-key global-map (kbd "'") (wrap-region-with-chars "'" "'")) (define-key global-map (kbd "{") (wrap-region-with-chars "{" "}")) (define-key global-map (kbd "[") (wrap-region-with-chars "[" "]")) (define-key global-map (kbd "*") (wrap-region-with-chars "*" "*")) (define-key global-map (kbd "<") (wrap-region-with-chars "<" ">")) (define-key global-map (kbd "`") (wrap-region-with-chars "`" "`")) ;; Most often when a buffer contains characters that I can't be saved with the ;; current coding system, it's because I've pasted from some stupid ;; Microsoft-originating source. I almost always want to replace these ;; characters with something else, so let's offer to do that by default. (defadvice select-safe-coding-system-interactively (around s-s-c-s-i-mst activate) (cond ((y-or-n-p "Funny characters found in this buffer. Replace them now? ") (let ((unsafe (mapcan #'(lambda (coding) (if (stringp from) (mapcar #'(lambda (pos) (aref from pos)) (unencodable-char-position 0 (length from) coding 11 from)) (mapcar #'(lambda (pos) (char-after pos)) (unencodable-char-position from to coding 11)))) unsafe))) (dolist (char (remove-duplicates unsafe)) (let ((char (string char))) (query-replace char (read-string (format "Replace %s with: " char)) nil (if mark-active (region-beginning)) (if mark-active (region-end))))))) (t ad-do-it))) (defun sloppy-mode () (interactive) (setq show-trailing-whitespace nil) (highlight-long-lines-mode -1)) (require 'clj-imports) (defun clj-run-tests () (slime-eval-with-transcript `(swank:interactive-eval ,(format "(let [test-results (atom [])] (binding [report (fn [e] (swap! test-results conj e))] (run-all-tests)) (if (and (empty? (:fail (clojure.contrib.seq-utils/group-by :type @test-results))) (empty? (:error (clojure.contrib.seq-utils/group-by :type @test-results)))) 'passed 'failed))")) nil t `(lambda (s) (show-test-status (first (read-from-string s))))) 'handled) (defun journal-entry () (interactive) (with-current-buffer (find-file "~/.journal.muse") (let ((header (time-stamp-string "* %:y%02m%02d"))) (goto-char (point-min)) (unless (prog1 (search-forward-regexp (concat header "$") nil t) (goto-char (point-max))) (insert "\n" header )) (insert "\n\n\n") (delete-blank-lines) (insert "\n" (time-stamp-hhmm) ": ")))) (provide 'emacs-homebrew)