| 1 | ;; Copyright (C) 2007 Vesa Karvonen |
| 2 | ;; |
| 3 | ;; MLton is released under a BSD-style license. |
| 4 | ;; See the file MLton-LICENSE for details. |
| 5 | |
| 6 | (require 'cl) |
| 7 | (require 'compat) |
| 8 | |
| 9 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
| 10 | ;; Utilities |
| 11 | |
| 12 | ;; In Gnu Emacs, `buffer-file-truename' is abbreviated while in XEmacs it |
| 13 | ;; isn't. This isn't in compat.el, because we want to use our cached |
| 14 | ;; version of `file-truename', namely `def-use-file-truename'. |
| 15 | (defun def-use-buffer-file-truename (&rest buffer) |
| 16 | "Returns the true filename of the current buffer." |
| 17 | (let ((name (apply (function buffer-file-name) buffer))) |
| 18 | (when name |
| 19 | (def-use-file-truename name)))) |
| 20 | |
| 21 | (defvar def-use-file-truename-table |
| 22 | (make-hash-table :test 'equal :weakness 'key) |
| 23 | "Weak hash table private to `def-use-file-truename'.") |
| 24 | |
| 25 | (defun def-use-file-truename (file) |
| 26 | "Cached version of `file-truename' combined with `abbreviate-file-name'." |
| 27 | (def-use-gethash-or-put file |
| 28 | (function |
| 29 | (lambda () |
| 30 | (def-use-intern |
| 31 | (def-use-add-face 'font-lock-keyword-face |
| 32 | (compat-abbreviate-file-name (file-truename file)))))) |
| 33 | def-use-file-truename-table)) |
| 34 | |
| 35 | (defun def-use-find-buffer-visiting-file (file) |
| 36 | "Tries to find a buffer visiting the specified file." |
| 37 | (let ((truename (def-use-file-truename file))) |
| 38 | (loop for buffer in (buffer-list) do |
| 39 | (if (with-current-buffer buffer |
| 40 | (string= (def-use-buffer-file-truename) truename)) |
| 41 | (return buffer))))) |
| 42 | |
| 43 | (defun def-use-find-file (file &optional other-window) |
| 44 | "Roughly as `find-file' or `find-file-other-window' except that will not |
| 45 | open the file a second time if a buffer is editing a file by the same true |
| 46 | file name." |
| 47 | (let ((buffer (def-use-find-buffer-visiting-file file))) |
| 48 | (cond |
| 49 | (buffer |
| 50 | (let ((window (get-buffer-window buffer))) |
| 51 | (cond |
| 52 | (other-window |
| 53 | (switch-to-buffer-other-window buffer)) |
| 54 | (window |
| 55 | (set-frame-selected-window nil window)) |
| 56 | (t |
| 57 | (switch-to-buffer buffer))))) |
| 58 | (other-window |
| 59 | (find-file-other-window file)) |
| 60 | (t |
| 61 | (find-file file))))) |
| 62 | |
| 63 | (defun def-use-point-at-next-line () |
| 64 | "Returns point at the beginning of the next line." |
| 65 | (save-excursion |
| 66 | (end-of-line) |
| 67 | (+ 1 (point)))) |
| 68 | |
| 69 | (defun def-use-point-at-current-line () |
| 70 | "Returns point at the beginning of the current line." |
| 71 | (save-excursion |
| 72 | (beginning-of-line) |
| 73 | (point))) |
| 74 | |
| 75 | (defun def-use-current-line () |
| 76 | "Returns the current line number counting from 1." |
| 77 | (+ 1 (count-lines 1 (def-use-point-at-current-line)))) |
| 78 | |
| 79 | (defun def-use-gethash-or-put (key_ mk-value_ table_) |
| 80 | (or (gethash key_ table_) |
| 81 | (puthash key_ (funcall mk-value_) table_))) |
| 82 | |
| 83 | (defvar def-use-intern-table |
| 84 | (make-hash-table :test 'equal :weakness 'key-and-value) |
| 85 | "Weak hash table private to `def-use-intern'.") |
| 86 | |
| 87 | (defun def-use-intern (value) |
| 88 | "Hashes the given value to itself. The assumption is that the value |
| 89 | being interned is not going to be mutated." |
| 90 | (def-use-gethash-or-put value (function (lambda () value)) |
| 91 | def-use-intern-table)) |
| 92 | |
| 93 | (defun def-use-hash-table-to-assoc-list (hash-table) |
| 94 | "Returns an assoc list containing all the keys and values of the hash |
| 95 | table." |
| 96 | (let ((result nil)) |
| 97 | (maphash (function |
| 98 | (lambda (key value) |
| 99 | (push (cons key value) result))) |
| 100 | hash-table) |
| 101 | result)) |
| 102 | |
| 103 | (defun def-use-hash-table-to-key-list (hash-table) |
| 104 | "Returns a list of the keys of hash-table." |
| 105 | (mapcar (function car) |
| 106 | (def-use-hash-table-to-assoc-list hash-table))) |
| 107 | |
| 108 | (defun def-use-hash-table-to-value-list (hash-table) |
| 109 | "Returns a list of the values of the hash-table." |
| 110 | (mapcar (function cdr) |
| 111 | (def-use-hash-table-to-assoc-list hash-table))) |
| 112 | |
| 113 | (defun def-use-set-to-list (set) |
| 114 | "Returns a list of the keys of the set (identity hash-table)." |
| 115 | (def-use-hash-table-to-key-list set)) |
| 116 | |
| 117 | (defun def-use-make-hash-table () |
| 118 | "Makes a hash table with `equal' semantics." |
| 119 | (make-hash-table :test 'equal :size 1)) |
| 120 | |
| 121 | (defun def-use-kill-current-buffer () |
| 122 | "Kills the current buffer." |
| 123 | (interactive) |
| 124 | (kill-buffer (current-buffer))) |
| 125 | |
| 126 | (defun def-use-add-face (face string) |
| 127 | "Adds the face as a property to the entire string and returns the |
| 128 | string." |
| 129 | (add-text-properties 0 (length string) `(face ,face) string) |
| 130 | string) |
| 131 | |
| 132 | (defun def-use-time-to-double (time) |
| 133 | "Converts a time to a double." |
| 134 | (+ (* (car time) 65536.0) |
| 135 | (cadr time) |
| 136 | (if (cddr time) (* (caddr time) 1e-06) 0))) |
| 137 | |
| 138 | (defun def-use-attr-newer? (attr1 attr2) |
| 139 | "Returns non-nil iff the modification time of `attr1' is later than the |
| 140 | modification time of `attr2'. Note that this also returns nil when either |
| 141 | one of the modification times is nil." |
| 142 | (and attr1 attr2 |
| 143 | (> (def-use-time-to-double (nth 5 attr1)) |
| 144 | (def-use-time-to-double (nth 5 attr2))))) |
| 145 | |
| 146 | (defun def-use-attr-changed? (attr1 attr2) |
| 147 | "Returns non-nil iff the file attributes of `attr1' are different than |
| 148 | the file attributes of `attr2'. Note that this also returns nil when either |
| 149 | one of the file attributes is nil." |
| 150 | (labels ((nequal (i) (not (equal (nth i attr1) (nth i attr2))))) |
| 151 | (and attr1 attr2 |
| 152 | (or (def-use-attr-newer? attr1 attr2) |
| 153 | (nequal 7) ;; size |
| 154 | (nequal 6) ;; status change time |
| 155 | (nequal 8) ;; file modes |
| 156 | (nequal 10) ;; inode |
| 157 | )))) |
| 158 | |
| 159 | (defun def-use-goto-line (line) |
| 160 | "Goes to specified line quietly without setting mark. By default, the |
| 161 | standard `goto-line' function in latest Gnu Emacs sets the mark displaying |
| 162 | the message \"Mark set\"." |
| 163 | (save-restriction |
| 164 | (widen) |
| 165 | (goto-char 1) |
| 166 | (forward-line (1- line)))) |
| 167 | |
| 168 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
| 169 | |
| 170 | (provide 'def-use-util) |