├── README.creole ├── fakir-tests.el └── fakir.el /README.creole: -------------------------------------------------------------------------------- 1 | = Fakir = 2 | 3 | This is a bunch of functions to mock core Emacs Lisp objects for 4 | testing purposes. 5 | 6 | These are the two things most difficult to mock in Emacs currently. 7 | 8 | We use the variations on the {{{noflet}}} macro to override a lot of 9 | Emacs API functions to understand mocked data types. 10 | 11 | == API == 12 | 13 | Here's the API currently. 14 | 15 | === fakir-fake-file faked-file &rest body === 16 | 17 | Fake //faked-file// and evaluate //body//. 18 | 19 | //faked-file// must be a [[fakir-file]] object or a list of 20 | [[fakir-file]] objects. 21 | 22 | 23 | === fakir-file &rest args === 24 | 25 | Make a fakir-file, a struct. 26 | 27 | :FILENAME is the basename of the file 28 | 29 | :DIRECTORY is the dirname of the file 30 | 31 | :CONTENT is a string of content for the file 32 | 33 | :MTIME is the modified time, with a default around the time fakir 34 | was written. 35 | 36 | 37 | === fakir-file-path fakir-file === 38 | 39 | Make the path for //fakir-file//. 40 | 41 | 42 | === fakir-mock-proc-properties process-obj &rest body === 43 | 44 | Mock process property list functions. 45 | 46 | Within //body// the functions [[process-get]], [[process-put]] and 47 | [[process-plist]] are all mocked to use a hashtable if the process 48 | passed to them is [[eq]] to //process-obj//. 49 | 50 | Also provides an additional function [[process-setplist]] to set 51 | the plist of the specified //process-obj//. If this function is 52 | called on anything but //process-obj// it will error. 53 | 54 | //This is the beginning of a noflet alternative to 55 | `fakir-mock-process'// 56 | 57 | 58 | === fakir-mock-process process-symbol process-bindings &rest body === 59 | 60 | Allow easier testing by mocking the process functions. 61 | 62 | For example: 63 | 64 | {{{ 65 | (fakir-mock-process :fake 66 | (:elnode-http-params 67 | (:elnode-http-method "GET") 68 | (:elnode-http-query "a=10")) 69 | (should (equal 10 (elnode-http-param :fake "a")))) 70 | }}} 71 | 72 | Causes: 73 | 74 | {{{ 75 | (process-get :fake :elnode-http-method) 76 | }}} 77 | 78 | to always return "GET". 79 | 80 | [[process-put]] is also remapped, to set any setting. 81 | 82 | [[process-buffer]] is also remapped, to deliver the value of the 83 | key [[:buffer]] if present and a dummy buffer otherwise. 84 | 85 | [[delete-process]] is also remapped, to throw 86 | [[:mock-process-finished]] to the catch called 87 | [[:mock-process-finished]]. You can implement your own catch to do 88 | something with the [[delete-process]] event. 89 | 90 | [[process-send-string]] is also remapped to send to a fake output 91 | buffer. The fake buffer can be returned with 92 | [[fakir-get-output-buffer]]. 93 | 94 | In normal circumstances, we return what the //body// returned. 95 | 96 | 97 | === fakir-test-mock-process === 98 | 99 | A very quick function to test mocking process macro. 100 | 101 | 102 | === fakir-time-encode time-str === 103 | 104 | Encode the //time-str// as an EmacsLisp time. 105 | 106 | 107 | 108 | 109 | 110 | == TODO == 111 | 112 | * currenly the process functions do not use {{{noflet}}}, they need to be re-written 113 | ** {{{flet-overrides}}} could be thrown away then 114 | * share the implementation of the faked file functions better 115 | ** this would also have the benefit that they are more instrumentable 116 | ** something like: 117 | 118 | {{{ 119 | (override 120 | (expand-file-name fakir/expand-file-name) 121 | (find-file-noselect fakir/find-file-no-select) 122 | ...) 123 | }}} 124 | 125 | ** where the 2nd symbol is the implementation function 126 | *** it should be expected to take the original function as 1st argument 127 | *** and all other arguments as the original 128 | * we need multiple file support 129 | ** just added this - //Sun May 12 23:59:50 BST 2013// 130 | -------------------------------------------------------------------------------- /fakir-tests.el: -------------------------------------------------------------------------------- 1 | ;;; Tests for fakir 2 | 3 | (require 'fakir) 4 | 5 | (ert-deftest fakir/make-hash-table () 6 | "Test hash table construction." 7 | (let ((h (fakir/make-hash-table '((a 10) 8 | (b 20) 9 | (fakir-alist-value "is a string") 10 | fakir-single-value 11 | :self-evaling-symbol-as-well)))) 12 | (should (equal 10 (gethash 'a h))) 13 | (should (equal 20 (gethash 'b h))) 14 | (should (equal nil (gethash 'fakir-single-value h))) 15 | (should (equal nil (gethash ':self-evaling-symbol-as-well h))))) 16 | 17 | 18 | (ert-deftest fakir-mock-proc-properties () 19 | "A very quick function to test mocking process macro." 20 | (let ((somevalue 30)) 21 | (fakir-mock-proc-properties :fakeproc 22 | (process-put :fakeproc :somevar 10) 23 | (process-put :fakeproc :othervar 20) 24 | (should (equal 10 (process-get :fakeproc :somevar))) 25 | (should (equal 20 (process-get :fakeproc :othervar))) 26 | (set-process-plist :fakeproc (list :one 1 :two 2)) 27 | (should-not (process-get :fakeproc :somevar)) 28 | (should (equal 1 (process-get :fakeproc :one))) 29 | (should (equal 2 (plist-get (process-plist :fakeproc) :two)))))) 30 | 31 | (ert-deftest fakir-make-unix-socket () 32 | "Test that we can make unix sockets." 33 | (let ((pair (fakir-make-unix-socket "nictest1"))) 34 | (unwind-protect 35 | (progn 36 | (should (processp (cadr pair))) 37 | (should (file-exists-p (car pair)))) 38 | ;; Clean up 39 | (delete-process (cadr pair)) 40 | (delete-file (car pair)))) 41 | (let ((pair (fakir-make-unix-socket))) 42 | (unwind-protect 43 | (progn 44 | (should (processp (cadr pair))) 45 | (should (file-exists-p (car pair)))) 46 | ;; Clean up 47 | (delete-process (cadr pair)) 48 | (delete-file (car pair))))) 49 | 50 | (ert-deftest fakir-mock-process () 51 | "Test that the mock process stuff works. 52 | 53 | Includes a test with a real process so that we can establish the 54 | bypass for real processes actually works. The real process test 55 | requires `make-network-process' with `:family' set to `local' to 56 | work. That seems better than trying to use a binary." 57 | (should 58 | (equal 59 | (let ((somevalue 10)) 60 | (fakir-mock-process :fakeproc 61 | ((a 20) 62 | (:somevar 15) 63 | (:othervar somevalue)) 64 | (list 65 | (processp :fakeproc) 66 | (process-get :fakeproc :somevar) 67 | (process-get :fakeproc :othervar) 68 | ;; testing equality of plists sucks 69 | ;; (process-plist :fakeproc) 70 | ))) 71 | '(t 15 10))) 72 | ;; And now with a real process in the mix - NOTE the name `myproc', 73 | ;; since the mock-process macro uses the word proc it might be 74 | ;; dangerous to use proc as a name. FIXME. Yeah. Right. 75 | (should 76 | (equal 77 | (fakir-with-unix-socket (myproc "ert-fakir-mock-process") 78 | (let ((somevalue 10)) 79 | (unwind-protect 80 | (append 81 | (list (processp myproc)) ; the real process outside the mock 82 | (fakir-mock-process :fakeproc 83 | ((a 20) 84 | (:somevar 15) 85 | (:othervar somevalue)) 86 | (list 87 | (processp :fakeproc) 88 | (process-get :fakeproc :somevar) 89 | (process-get :fakeproc :othervar) 90 | ;; testing equality of plists sucks 91 | ;; (process-plist :fakeproc) 92 | (processp myproc) ; the real process inside the mock 93 | ))) 94 | (when (processp myproc) 95 | (delete-process myproc))))) 96 | '(t t 15 10 t)))) 97 | 98 | (ert-deftest fakir-mock-process-delete () 99 | "Test the delete handling." 100 | :tags '(unit) 101 | ;; delete-process causes the body to return :mock-process-finished 102 | (should 103 | (fakir-mock-process 104 | :fakeproc 105 | ((a 20) 106 | (:somevar "somevar")) 107 | (let ((x "a string of text")) 108 | (delete-process :fakeproc)))) 109 | ;; How to use catch inside the BODY to handle delete-process 110 | (should 111 | (equal 112 | "the process finished" 113 | (fakir-mock-process 114 | :fakeproc 115 | ((a 20) 116 | (:somevar "somevar")) 117 | (let ((x "a string of text")) 118 | (when (eq :mock-process-finished 119 | (catch :mock-process-finished 120 | (delete-process :fakeproc))) 121 | "the process finished")))))) 122 | 123 | (ert-deftest fakir--file-fqn () 124 | "Test we can make fully qualified names for files." 125 | (let ((ef (make-fakir-file 126 | :filename "somefile" 127 | :directory "/home/dir"))) 128 | (should (equal "/home/dir/somefile" 129 | (fakir--file-fqn ef))))) 130 | 131 | (ert-deftest fakir--file-mod-time () 132 | "Test that file mtimes are encoded properly." 133 | (let ((ef (make-fakir-file 134 | :filename "somefile" 135 | :directory "/home/dir" 136 | :mtime "Mon, Feb 27 2012 22:10:21 GMT"))) 137 | (should (equal (fakir--file-mod-time ef) 138 | '(20299 65357))))) 139 | 140 | (ert-deftest fakir--file-attribs () 141 | "Test that we get back file attributes." 142 | (let ((ef (make-fakir-file 143 | :filename "somefile" 144 | :directory "/home/dir" 145 | :mtime "Mon, Feb 27 2012 22:10:21 GMT"))) 146 | (should (equal 147 | (list nil t t t t '(20299 65357)) 148 | (fakir--file-attribs ef)))) 149 | (let ((ef (make-fakir-file 150 | :filename "somedir" 151 | :directory "/home/dir" 152 | :mtime "Mon, Feb 27 2012 22:10:21 GMT" 153 | :directory-p t))) 154 | (should (equal 155 | (list t t t t t '(20299 65357)) 156 | (fakir--file-attribs ef))))) 157 | 158 | (ert-deftest fakir--file-home () 159 | "Test the home root stuff." 160 | (let ((ef (make-fakir-file 161 | :filename "somefile" 162 | :directory "/home/dir")) 163 | (ef2 (make-fakir-file 164 | :filename "somefile" 165 | :directory "/var/dir")) 166 | (ef3 (make-fakir-file 167 | :filename "somefile" 168 | :directory "/home/dir/someddir"))) 169 | (should (equal "/home/dir" (fakir--file-home ef))) 170 | (should (equal "/home/dir" (fakir--file-home ef3))) 171 | (should (equal nil (fakir--file-home ef2))))) 172 | 173 | (ert-deftest fakir--expand () 174 | (should 175 | (equal 176 | (fakir--expand "/one/../two/../three/four" t) 177 | "/one/three/four")) 178 | (should 179 | (equal 180 | (fakir--expand "/one/two/../three/../four" t) 181 | "/one/four"))) 182 | 183 | (ert-deftest fakir--expand-file-name () 184 | "Test expanding names to absolutes." 185 | (should 186 | (equal 187 | (fakir--expand-file-name "blah" "/home/emacsuser") 188 | "/home/emacsuser/blah")) 189 | (should 190 | (equal 191 | (fakir--expand-file-name 192 | "/home/emacsuser/bladh/qdqnwd/qwdqdq.1" "/home/emacsuser") 193 | "/home/emacsuser/bladh/qdqnwd/qwdqdq.1")) 194 | (should 195 | (equal 196 | (fakir--expand-file-name 197 | "/home/emacsuser/bladh/../qwdqdq.2" "/home/emacsuser") 198 | "/home/emacsuser/qwdqdq.2")) 199 | (should 200 | (equal 201 | (fakir--expand-file-name "qwdqdq.3" "/home") 202 | "/home/qwdqdq.3")) 203 | (should 204 | (equal 205 | (fakir--expand-file-name "/qwdqdq.4" "/home") 206 | "/qwdqdq.4")) 207 | (should 208 | (equal 209 | (fakir--expand-file-name 210 | "/home/emacsuser/bladh/../../../../../../qwdqdq.5" "/home") 211 | "/qwdqdq.5"))) 212 | 213 | (ert-deftest fakir/find-file () 214 | (let ((f (fakir-file :filename "README" 215 | :directory "/home/fakir" 216 | :content "This is a ReadMe file."))) 217 | (let ((buf (fakir--find-file f))) 218 | (unwind-protect 219 | (with-current-buffer buf 220 | (should 221 | (equal "This is a ReadMe file." 222 | (buffer-substring (point-min) (point-max))))) 223 | (kill-buffer buf))))) 224 | 225 | (ert-deftest fakir--write-region () 226 | "Test writing fake stuff." 227 | (let ((fl 228 | (fakir-file :filename "nic" :directory "/tmp/" 229 | :content "blah"))) 230 | ;; Overwrite the faked content 231 | (should 232 | (equal 233 | (progn 234 | (with-temp-buffer 235 | (insert "hello world!") 236 | (fakir--write-region 237 | fl (point-min) (point-max) "/tmp/nic")) 238 | (fakir-file-content fl)) 239 | "hello world!")) 240 | ;; Append the faked content 241 | (should 242 | (equal 243 | (progn 244 | (with-temp-buffer 245 | (insert " says the computer") 246 | (fakir--write-region 247 | fl (point-min) (point-max) "/tmp/nic" t)) 248 | (fakir-file-content fl)) 249 | "hello world! says the computer")))) 250 | 251 | (ert-deftest fakir-mock-file () 252 | "Test the mock file macro." 253 | (let ((fakir--home-root "/home/test")) 254 | (fakir-mock-file (fakir-file 255 | :filename "somefile" 256 | :directory "/home/test" 257 | :content "This is a file." 258 | :mtime "Mon, Feb 27 2012 22:10:21 GMT") 259 | (let ((buf (find-file "/home/test/somefile"))) 260 | (unwind-protect 261 | (with-current-buffer buf 262 | (should 263 | (equal "This is a file." 264 | (buffer-substring (point-min) (point-max))))) 265 | (kill-buffer buf))) 266 | (should (file-exists-p "/home/test/somefile")) 267 | (should-not (file-exists-p "/home/test/otherfile")) 268 | (should-not (file-exists-p "/home/dir/somefile")) 269 | (should (equal 270 | (expand-file-name "~/somefile") 271 | "/home/test/somefile")) 272 | (should (equal 273 | '(20299 65357) 274 | (elt (file-attributes "/home/test/somefile") 5)))))) 275 | 276 | (ert-deftest fakir-fake-file/creates-parent-directories () 277 | (fakir-fake-file 278 | (fakir-file 279 | :filename "somefile" 280 | :directory "/home/fakir-test" 281 | :content "somecontent") 282 | (should (equal t (file-directory-p "/"))) 283 | (should (equal t (file-directory-p "/home"))) 284 | (should (equal t (file-directory-p "/home/fakir-test"))))) 285 | 286 | (ert-deftest fakir-fake-file/insert-file-contents () 287 | (fakir-fake-file 288 | (fakir-file 289 | :filename "blah" 290 | :directory "/tmp" 291 | :content "blah!") 292 | (should 293 | (equal 294 | (with-temp-buffer 295 | (insert-file-contents "/tmp/blah") 296 | (buffer-string)) 297 | "blah!")) 298 | ;; We should do another test with a real file - this one? 299 | )) 300 | 301 | (ert-deftest fakir-fake-file/expand-file-name () 302 | (let ((fakir--home-root "/home/fakir-test")) 303 | (fakir-fake-file 304 | (fakir-file 305 | :filename "blah" 306 | :directory "/home/fakir-test" 307 | :content "blah!") 308 | (let ((real-home-dir 309 | (file-name-as-directory (getenv "HOME")))) 310 | (should 311 | (equal 312 | (expand-file-name "~/blah") 313 | "/home/fakir-test/blah")) 314 | ;; Use a real one 315 | (should 316 | (equal 317 | (expand-file-name "~/.emacs.d") 318 | (concat real-home-dir ".emacs.d"))))))) 319 | 320 | (ert-deftest fakir-fake-file/expand-file-name () 321 | (let ((fakir--home-root "/home/fakir-test")) 322 | (fakir-fake-file 323 | (list 324 | (fakir-file 325 | :filename "blah" 326 | :directory "/home/fakir-test" 327 | :content "blah!") 328 | (fakir-file 329 | :filename "blah2" 330 | :directory "/home/fakir-test" 331 | :content "blah2!") 332 | (fakir-file 333 | :filename "blah3" 334 | :directory "/home/fakir-test" 335 | :content "NO WAY!") 336 | (fakir-file 337 | :filename "blah3" 338 | :directory "/tmp" 339 | :content "totally testing!")) 340 | (let ((real-home-dir 341 | (file-name-as-directory (getenv "HOME")))) 342 | (should 343 | (equal 344 | (expand-file-name "~/blah") 345 | "/home/fakir-test/blah")) 346 | (should 347 | (equal 348 | (expand-file-name "~/blah2") 349 | "/home/fakir-test/blah2")) 350 | (should 351 | (equal 352 | (let ((ctx-dir "/tmp")) 353 | (expand-file-name "blah3" ctx-dir)) 354 | "/tmp/blah3")))))) 355 | 356 | (ert-deftest fakir-fake-file/file-regular-p () 357 | (fakir-fake-file 358 | (list 359 | (fakir-file 360 | :filename "testfile" 361 | :directory "/home/fakir-test" 362 | :content "file content") 363 | (fakir-file 364 | :filename "subdir" 365 | :directory "/home/fakir-test" 366 | :directory-p t)) 367 | (should (equal t (file-directory-p "/home/fakir-test/subdir"))) 368 | (should (equal nil (file-directory-p "/home/fakir-test/testfile"))))) 369 | 370 | (ert-deftest fakir-fake-file/file-directory-p () 371 | (fakir-fake-file 372 | (list 373 | (fakir-file 374 | :filename "testfile" 375 | :directory "/home/fakir-test" 376 | :content "file content") 377 | (fakir-file 378 | :filename "subdir" 379 | :directory "/home/fakir-test" 380 | :directory-p t)) 381 | (should (equal t (file-regular-p "/home/fakir-test/testfile"))) 382 | (should (equal nil (file-regular-p "/home/fakir-test/subdir"))))) 383 | 384 | 385 | (ert-deftest fakir-fake-file/directory-files () 386 | (fakir-fake-file 387 | (list 388 | (fakir-file 389 | :filename "somefile" 390 | :directory "/home/fakir-test" 391 | :content "blah!") 392 | (fakir-file 393 | :filename "otherfile" 394 | :directory "/home/fakir-test/subdir" 395 | :content "deep") 396 | (fakir-file 397 | :filename "otherdir" 398 | :directory "/home/fakir-test" 399 | :directory-p "")) 400 | (should (equal 401 | (directory-files "/home/fakir-test") 402 | '("." ".." "otherdir" "somefile" "subdir"))) 403 | (should (equal 404 | (directory-files "/home/fakir-test" t) 405 | '("/home/fakir-test/." "/home/fakir-test/.." "/home/fakir-test/otherdir" "/home/fakir-test/somefile" "/home/fakir-test/subdir"))) 406 | (should (equal 407 | (directory-files "/home/fakir-test" t "otherdir") 408 | '("/home/fakir-test/otherdir"))))) 409 | 410 | (ert-deftest fakir-fake-file/directory-files-and-attributes () 411 | (fakir-fake-file 412 | (list 413 | (fakir-file 414 | :filename "somefile" 415 | :directory "/home/fakir-test" 416 | :content "blah!") 417 | (fakir-file 418 | :filename "otherfile" 419 | :directory "/home/fakir-test/subdir" 420 | :content "deep") 421 | (fakir-file 422 | :filename "otherdir" 423 | :directory "/home/fakir-test" 424 | :directory-p "")) 425 | (should (equal 426 | (directory-files-and-attributes "/home/fakir-test") 427 | '(("." t t t t t (20299 65355)) 428 | (".." t t t t t (20299 65355)) 429 | ("otherdir" "" t t t t (20299 65355)) 430 | ("somefile" nil t t t t (20299 65355)) 431 | ("subdir" t t t t t (20299 65355))))) 432 | (should (equal 433 | (directory-files-and-attributes "/home/fakir-test" t) 434 | '(("/home/fakir-test/." t t t t t (20299 65355)) 435 | ("/home/fakir-test/.." t t t t t (20299 65355)) 436 | ("/home/fakir-test/otherdir" "" t t t t (20299 65355)) 437 | ("/home/fakir-test/somefile" nil t t t t (20299 65355)) 438 | ("/home/fakir-test/subdir" t t t t t (20299 65355))))))) 439 | 440 | ;;; fakir-tests.el ends here 441 | -------------------------------------------------------------------------------- /fakir.el: -------------------------------------------------------------------------------- 1 | ;;; fakir.el --- fakeing bits of Emacs -*- lexical-binding: t -*- 2 | ;; Copyright (C) 2012 Nic Ferrier 3 | 4 | ;; Author: Nic Ferrier 5 | ;; Maintainer: Nic Ferrier 6 | ;; URL: http://github.com/nicferrier/emacs-fakir 7 | ;; Created: 17th March 2012 8 | ;; Version: 0.1.9 9 | ;; Keywords: lisp, tools 10 | ;; Package-Requires: ((noflet "0.0.8")(dash "1.3.2")(kv "0.0.19")) 11 | 12 | ;; This file is NOT part of GNU Emacs. 13 | 14 | ;; This program is free software; you can redistribute it and/or modify 15 | ;; it under the terms of the GNU General Public License as published by 16 | ;; the Free Software Foundation, either version 3 of the License, or 17 | ;; (at your option) any later version. 18 | 19 | ;; This program is distributed in the hope that it will be useful, 20 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 21 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 22 | ;; GNU General Public License for more details. 23 | 24 | ;; You should have received a copy of the GNU General Public License 25 | ;; along with this program. If not, see . 26 | 27 | ;;; Source code 28 | ;; 29 | ;; fakir's code can be found here: 30 | ;; http://github.com/nicferrier/fakir 31 | 32 | ;;; Style note 33 | ;; 34 | ;; This codes uses the Emacs style of: 35 | ;; 36 | ;; fakir--private-function 37 | ;; 38 | ;; for private functions and macros. 39 | 40 | ;;; Commentary: 41 | ;; 42 | ;; This is a collection of tools to make testing Emacs core functions 43 | ;; easier. 44 | 45 | ;;; Code: 46 | 47 | (require 'ert) 48 | (require 'dash) 49 | (require 'noflet) 50 | (require 'kv) 51 | (eval-when-compile (require 'cl)) 52 | 53 | 54 | (defun fakir-make-unix-socket (&optional name) 55 | "Make a unix socket server process optionally based on NAME. 56 | 57 | Returns a list of the processes socket file and the process object." 58 | (let* ((socket-file 59 | (concat "/tmp/" (apply 'make-temp-name 60 | (list (or name "fakir-make-unix-socket"))))) 61 | (myproc (make-network-process 62 | :name socket-file 63 | :family 'local :server t 64 | :service socket-file))) 65 | (list socket-file myproc))) 66 | 67 | (defmacro* fakir-with-unix-socket ((socket-sym &optional socket-name) &rest body) 68 | "Execute BODY with a Unix socket server bound to SOCKET-SYM. 69 | 70 | Optionally the socket is created with SOCKET-NAME which means 71 | that the file used to back the socket is named after SOCKET-NAME. 72 | 73 | The socket process is closed on completion and the associated 74 | file is deleted." 75 | (declare (indent 1)) 76 | (let ((spv (make-symbol "spv")) 77 | (sockfilev (make-symbol "sockfilev"))) 78 | `(let* ((,spv (fakir-make-unix-socket ,socket-name)) 79 | (,sockfilev (car ,spv)) 80 | (,socket-sym (cadr ,spv))) 81 | (unwind-protect 82 | (progn 83 | ,@body) 84 | (delete-process ,socket-sym) 85 | (delete-file ,sockfilev))))) 86 | 87 | (defmacro fakir-with-file-buffer (buffer-var &rest body) 88 | "Make a buffer visiting a file and assign it to BUFFER-VAR. 89 | 90 | The file only exists for the scope of the macro. Both the file 91 | and the buffer visiting it are destroyed when the scope exits." 92 | (declare (indent 1)) 93 | (let ((filev (make-symbol "filev"))) 94 | `(let* ((,filev (make-temp-file "filebuf")) 95 | (,buffer-var (find-file-noselect ,filev))) 96 | (unwind-protect 97 | (progn ,@body) 98 | (with-current-buffer ,buffer-var 99 | (set-buffer-modified-p nil)) 100 | (kill-buffer ,buffer-var) 101 | (delete-file ,filev))))) 102 | 103 | ;; Mocking processes 104 | 105 | (defvar fakir-mock-process-require-specified-buffer nil 106 | "Tell `fakir-mock-process' that you require a buffer to be set. 107 | 108 | This is used, for example, to make `elnode--filter' testing work 109 | properly. Normally, tests do not need to set the process-buffer 110 | directly, they can just expect it to be there. `elnode--filter', 111 | though, needs to set the process-buffer to work properly.") 112 | 113 | 114 | (defun fakir/make-hash-table (alist) ; possible redundant now. 115 | "Make a hash table from the ALIST. 116 | 117 | The ALIST looks like a let-list." 118 | (let ((bindings (make-hash-table :test 'equal))) 119 | (loop for f in (append 120 | (list (list :fakir-mock-process t)) 121 | alist) 122 | do 123 | (cond 124 | ((and f (listp f)) 125 | (puthash (car f) (cadr f) bindings)) 126 | (t 127 | (puthash f nil bindings)))) 128 | bindings)) 129 | 130 | (defun fakir/get-or-create-buf (pvbuf pv-alist &optional specified-buf) 131 | "Special get or create to support the process mocking. 132 | 133 | PVBUF is a, possibly existing, buffer reference. If nil then we 134 | create the buffer. 135 | 136 | PV-ALIST is an alist of properties, possibly containing the 137 | `:buffer' property which specifies a string to be used as the 138 | content of the buffer. 139 | 140 | SPECIFIED-BUF is an optional buffer to use instead of a dummy 141 | created one." 142 | (if (bufferp pvbuf) 143 | pvbuf 144 | (setq pvbuf 145 | (if fakir-mock-process-require-specified-buffer 146 | (if (bufferp specified-buf) 147 | specified-buf 148 | nil) 149 | (or specified-buf 150 | (get-buffer-create 151 | (generate-new-buffer-name 152 | "* fakir mock proc buf *"))))) 153 | ;; If we've got a buffer value then insert it. 154 | (when (kva :buffer pv-alist) 155 | (with-current-buffer pvbuf 156 | (insert (kva :buffer pv-alist)))) 157 | pvbuf)) 158 | 159 | 160 | (defmacro fakir-mock-proc-properties (process-obj &rest body) 161 | "Mock process property list functions. 162 | 163 | Within BODY the functions `process-get', `process-put' and 164 | `process-plist' and `set-process-plist' are all mocked to use a 165 | hashtable if the process passed to them is `eq' to PROCESS-OBJ." 166 | (declare (indent 1) 167 | (debug (sexp &rest form))) 168 | (let ((proc-plist (make-symbol "procpropsv"))) 169 | `(let (,proc-plist) 170 | (macrolet ((or-args (form &rest args) 171 | `(if (eq proc ,,process-obj) 172 | ,form 173 | (apply this-fn ,@args)))) 174 | (noflet ((process-get (proc name) 175 | (or-args (plist-get ,proc-plist name) proc name)) 176 | (process-put (proc name value) 177 | (or-args 178 | (if ,proc-plist 179 | (plist-put ,proc-plist name value) 180 | (setq ,proc-plist (list name value))) 181 | proc name value)) 182 | (process-plist (proc) 183 | (or-args ,proc-plist proc)) 184 | (set-process-plist (proc props) 185 | (or-args (setq ,proc-plist props) proc props))) 186 | ,@body))))) 187 | 188 | (defun fakir/let-bindings->alist (bindings) 189 | "Turn let like BINDINGS into an alist. 190 | 191 | Makes sure the resulting alist has `consed' pairs rather than 192 | lists. 193 | 194 | Generally useful macro helper should be elsewhere." 195 | (loop for p in bindings 196 | collect 197 | (if (and p (listp p)) 198 | (list 'cons `(quote ,(car p)) (cadr p)) 199 | (list 'cons `,p nil)))) 200 | 201 | (defmacro fakir-mock-process (process-symbol process-bindings &rest body) 202 | "Allow easier testing by mocking the process functions. 203 | 204 | For example: 205 | 206 | (fakir-mock-process :fake 207 | (:elnode-http-params 208 | (:elnode-http-method \"GET\") 209 | (:elnode-http-query \"a=10\")) 210 | (should (equal 10 (elnode-http-param :fake \"a\")))) 211 | 212 | Causes: 213 | 214 | (process-get :fake :elnode-http-method) 215 | 216 | to always return \"GET\". 217 | 218 | `process-put' is also remapped, to set any setting. 219 | 220 | `process-buffer' is also remapped, to deliver the value of the 221 | key `:buffer' if present and a dummy buffer otherwise. 222 | 223 | `delete-process' is also remapped, to throw 224 | `:mock-process-finished' to the catch called 225 | `:mock-process-finished'. You can implement your own catch to do 226 | something with the `delete-process' event. 227 | 228 | `process-send-string' is also remapped to send to a fake output 229 | buffer. The fake buffer can be returned with 230 | `fakir-get-output-buffer'. 231 | 232 | In normal circumstances, we return what the BODY returned." 233 | (declare 234 | (debug (sexp sexp &rest form)) 235 | (indent defun)) 236 | (let ((get-or-create-buf (make-symbol "get-or-create-buf")) 237 | (fakir-kill-buffer (make-symbol "fakir-kill-buffer")) 238 | (pvvar (make-symbol "pv")) 239 | (pvoutbuf (make-symbol "pvoutbuf")) 240 | (pvbuf (make-symbol "buf")) 241 | (result (make-symbol "result"))) 242 | `(let ((,pvvar (list ,@(fakir/let-bindings->alist process-bindings))) 243 | ;; This is a buffer for the output 244 | (,pvoutbuf (get-buffer-create "*fakir-outbuf*")) 245 | ;; For assigning the result of the body 246 | ,result 247 | ;; Dummy buffer variable for the process - we fill this in 248 | ;; dynamically in 'process-buffer 249 | ,pvbuf) 250 | (fakir-mock-proc-properties ,process-symbol 251 | (flet ((fakir-get-output-buffer () ,pvoutbuf) 252 | (,get-or-create-buf (proc &optional specified-buf) 253 | (setq ,pvbuf (fakir/get-or-create-buf 254 | ,pvbuf 255 | ,pvvar 256 | specified-buf))) 257 | (,fakir-kill-buffer (buf) 258 | (when (bufferp buf) 259 | (with-current-buffer buf (set-buffer-modified-p nil)) 260 | (kill-buffer buf)))) 261 | (unwind-protect 262 | (macrolet ((or-args (form &rest args) 263 | `(if (eq proc ,,process-symbol) 264 | ,form 265 | (apply this-fn (list ,@args))))) 266 | ;; Rebind the process function interface 267 | (noflet 268 | ((processp (proc) (or-args t proc)) 269 | (process-send-eof (proc) (or-args t proc)) 270 | (process-status (proc) (or-args 'fake proc)) 271 | (process-buffer (proc) (or-args (,get-or-create-buf proc) proc)) 272 | (process-contact (proc &optional arg) ; FIXME - elnode specific 273 | (or-args (list "localhost" 8000) proc)) 274 | (process-send-string (proc str) 275 | (or-args 276 | (with-current-buffer ,pvoutbuf 277 | (save-excursion 278 | (goto-char (point-max)) 279 | (insert str))) 280 | proc)) 281 | (delete-process (proc) 282 | (or-args 283 | (throw :mock-process-finished :mock-process-finished) 284 | proc)) 285 | (set-process-buffer (proc buffer) 286 | (or-args (,get-or-create-buf proc buffer) proc))) 287 | (set-process-plist ,process-symbol (kvalist->plist ,pvvar)) 288 | (setq ,result 289 | (catch :mock-process-finished 290 | ,@body)))) 291 | ;; Now clean up 292 | (,fakir-kill-buffer ,pvbuf) 293 | (,fakir-kill-buffer ,pvoutbuf))))))) 294 | 295 | 296 | ;; Time utils 297 | 298 | (defun fakir-time-encode (time-str) 299 | "Encode the TIME-STR as an EmacsLisp time." 300 | ;; FIXME this should be part of Emacs probably; I've had to 301 | ;; implement this in Elnode as well 302 | (apply 'encode-time (parse-time-string time-str))) 303 | 304 | ;; A structure to represent a mock file 305 | 306 | (defstruct fakir-file 307 | filename 308 | directory 309 | (content "") 310 | ;; obviously there should be all the state of the file here 311 | (mtime "Mon, Feb 27 2012 22:10:19 GMT") 312 | (directory-p nil)) 313 | 314 | (defun fakir-file (&rest args) 315 | "Make a fakir-file, a struct. 316 | 317 | :FILENAME is the basename of the file 318 | 319 | :DIRECTORY is the dirname of the file 320 | 321 | :CONTENT is a string of content for the file 322 | 323 | :MTIME is the modified time, with a default around the time fakir 324 | was written. 325 | 326 | :DIRECTORY-P specifies whether this file is a directory or a file." 327 | (apply 'make-fakir-file args)) 328 | 329 | (defun fakir--file-check (file) 330 | "Implements the type check for FILE is a `fakir--file'." 331 | (if (not (fakir-file-p file)) 332 | (error "not an fakir--file"))) 333 | 334 | (defun fakir--file-fqn (file) 335 | "Return the fully qualified name of FILE, an `fakir--file'." 336 | (fakir--file-check file) 337 | (let* ((fqfn 338 | (concat 339 | (file-name-as-directory 340 | (fakir-file-directory file)) 341 | (fakir-file-filename file)))) 342 | fqfn)) 343 | 344 | (defun fakir--file-rename (src-file to-file-name) 345 | "Rename the `fakir-file' SRC-FILE." 346 | (fakir--file-check src-file) 347 | (let ((base-file-name (file-name-nondirectory to-file-name)) 348 | (file-dir (file-name-directory to-file-name))) 349 | (setf (fakir-file-directory src-file) file-dir) 350 | (setf (fakir-file-filename src-file) base-file-name))) 351 | 352 | (defun fakir--file-mod-time (file &optional raw) 353 | "Return the encoded mtime of FILE, an `fakir--file'. 354 | 355 | If RAW is t then return the raw value, a string." 356 | (fakir--file-check file) 357 | (if raw 358 | (fakir-file-mtime file) 359 | (fakir-time-encode (fakir-file-mtime file)))) 360 | 361 | (defun fakir--file-attribs (file) 362 | "Return an answer as `file-attributes' for FILE. 363 | 364 | Currently WE ONLY SUPPORT MODIFIED-TIME." 365 | (fakir--file-check file) 366 | (list (fakir-file-directory-p file) 367 | t t t t 368 | (fakir--file-mod-time file))) 369 | 370 | (defun fakir--file-home (file) 371 | "Return the home part of FILE or nil. 372 | 373 | The home part of FILE is the part that is the home directory of 374 | the user. If it's not a user FILE then it won't have a home 375 | part." 376 | (fakir--file-check file) 377 | (let* ((fqn (fakir--file-fqn file)) 378 | (home-root 379 | (save-match-data 380 | (when 381 | (string-match 382 | "^\\(/home/[A-Za-z][A-Za-z0-9-]+\\)\\(/.*\\)*" 383 | fqn) 384 | (match-string 1 fqn))))) 385 | home-root)) 386 | 387 | (defun fakir--file-path (faked-file) 388 | "Make a path name from the FAKED-FILE." 389 | (concat 390 | (file-name-as-directory 391 | (fakir-file-directory faked-file)) 392 | (fakir-file-filename faked-file))) 393 | 394 | (defvar fakir--home-root "/home/fakir" 395 | "String to use as the home-root.") 396 | 397 | (defun fakir--join (file-name &optional dir) 398 | "Join FILE-NAME to DIR or `fakir--home-root'." 399 | (concat 400 | (file-name-as-directory (or dir fakir--home-root)) 401 | file-name)) 402 | 403 | (defun fakir--expand (file-name rooted-p) 404 | "Functional file-name expand." 405 | (let ((path 406 | (mapconcat 407 | 'identity 408 | (let ((l 409 | (-reduce 410 | (lambda (a b) 411 | (if (string= b "..") 412 | (if (consp a) 413 | (reverse (cdr (reverse a))) 414 | (list a)) 415 | (if (consp a) 416 | (append a (list b)) 417 | (list a b)))) 418 | (cdr (split-string file-name "/"))))) 419 | (if (listp l) l (list l))) 420 | "/"))) 421 | (if (and rooted-p (not (equal ?\/ (elt path 0)))) 422 | (concat "/" path) 423 | path))) 424 | 425 | (defun fakir--expand-file-name (file-name dir) 426 | "Implementation of ~ and .. handling for FILE-NAME." 427 | (let* ((fqfn 428 | (if (string-match "^\\(~/\\|/\\).*" file-name) 429 | file-name 430 | ;; Else it's both 431 | (fakir--join file-name dir))) 432 | (file-path 433 | ;; Replace ~/ with the home-root 434 | (replace-regexp-in-string 435 | "^~/\\(.*\\)" 436 | (lambda (m) (fakir--join (match-string 1 m))) 437 | fqfn)) 438 | (new-path 439 | (fakir--expand 440 | file-path 441 | (equal ?\/ (elt file-path 0))))) 442 | new-path)) 443 | 444 | (defun fakir--find-file (fakir-file) 445 | "`find-file' implementation for FAKIR-FILE." 446 | (let ((buf (get-buffer (fakir-file-filename fakir-file)))) 447 | (if (bufferp buf) 448 | buf 449 | ;; Else make one and put the content in it 450 | (with-current-buffer 451 | (get-buffer-create (fakir-file-filename fakir-file)) 452 | (insert (fakir-file-content fakir-file)) 453 | (current-buffer))))) 454 | 455 | (defun fakir-file-path (fakir-file) 456 | "Make the path for FAKIR-FILE." 457 | (concat (fakir-file-directory fakir-file) 458 | (fakir-file-filename fakir-file))) 459 | 460 | 461 | (defun fakir--file-parent-directories (faked-file) 462 | "Return the parent directories for a FAKED-FILE." 463 | (let ((directory-path (fakir-file-directory faked-file)) 464 | (path "") 465 | (path-list '("/"))) 466 | (dolist (path-part (split-string directory-path "/" t)) 467 | (let ((current-path (concat path "/" path-part))) 468 | (push current-path path-list) 469 | (setq path current-path))) 470 | path-list)) 471 | 472 | (defun fakir--namespace-put (faked-file namespace) 473 | "Put given FAKED-FILE and its parent folders into the given NAMESPACE." 474 | (puthash (fakir--file-path faked-file) faked-file namespace) 475 | (dolist (parent-dir (fakir--file-parent-directories faked-file)) 476 | (puthash 477 | parent-dir 478 | (fakir-file 479 | :filename (file-name-nondirectory parent-dir) 480 | :directory (file-name-directory parent-dir) 481 | :content "" 482 | :directory-p t) 483 | namespace))) 484 | 485 | (defun fakir--namespace (faked-file &rest other-files) 486 | "Make a namespace with FAKED-FILE in it. 487 | 488 | Also adds the directory for the FAKED-FILE. 489 | 490 | If OTHER-FILES are specified they are added to." 491 | (let ((ns (make-hash-table :test 'equal))) 492 | (fakir--namespace-put faked-file ns) 493 | (dolist (other-file other-files) 494 | (fakir--namespace-put other-file ns)) 495 | ns)) 496 | 497 | (defun fakir--namespace-lookup (file-name namespace) 498 | "Lookup FILE-NAME in NAMESPACE. 499 | 500 | Looks up the FILE-NAME" 501 | (kvhash->alist namespace) 502 | (or 503 | (gethash file-name namespace) 504 | (gethash 505 | (file-name-as-directory file-name) 506 | namespace))) 507 | 508 | (defvar fakir-file-namespace nil 509 | "Namespace used by `fakir--file-cond'.") 510 | 511 | (defmacro fakir--file-cond (file-name then &rest else) 512 | "Do THEN or ELSE if FILE-NAME is a faked file. 513 | 514 | Uses the `fakir-file-namepsace' to detect that. 515 | 516 | The `fakir-file' for the FILE-NAME is locally bound in the THEN 517 | clause to `this-fakir-file'." 518 | (declare (indent 1)) 519 | (let ((file-name-v (make-symbol "file-namev")) 520 | (found-file (make-symbol "ff"))) 521 | `(let* ((,file-name-v ,file-name) 522 | (,found-file 523 | (fakir--namespace-lookup 524 | ,file-name-v fakir-file-namespace))) 525 | (if (fakir-file-p ,found-file) 526 | (let ((this-fakir-file ,found-file)) 527 | ,then) 528 | ,@else)))) 529 | 530 | (defun fakir--write-region (fakir-file start end file-name 531 | &optional append visit lockname mustbenew) 532 | "Fake `write-region' function to write to FAKIR-FILE. 533 | 534 | `fakir-fake-file' does not call this unless the FILE-NAME exists 535 | as a declared fake-file. Thus you cannot use this to save files 536 | you have not explicitly declared as fake." 537 | (let ((to-write 538 | (cond 539 | ((equal start nil) (buffer-string)) 540 | ((stringp start) start) 541 | (t (buffer-substring start end))))) 542 | (setf 543 | (fakir-file-content fakir-file) 544 | (if append 545 | (concat (fakir-file-content fakir-file) to-write) 546 | to-write)))) 547 | 548 | (defun fakir--parent-fakir-file (file) 549 | "Return the parent fakir-file for FILE from the current namespace." 550 | (fakir--file-check file) 551 | (let ((parent-file-name (directory-file-name 552 | (fakir-file-directory file)))) 553 | (fakir--namespace-lookup parent-file-name fakir-file-namespace))) 554 | 555 | (defun fakir--directory-fakir-files (directory) 556 | "Return all fakir-files that are inside the given DIRECTORY." 557 | (let ((directory (file-name-as-directory directory)) 558 | directory-fakir-files) 559 | 560 | (loop for fakir-file being the hash-value of fakir-file-namespace 561 | if (equal (file-name-as-directory 562 | (fakir-file-directory fakir-file)) 563 | directory) 564 | collect fakir-file))) 565 | 566 | (defun fakir--directory-files-and-attributes (directory &optional full match nosort id-format) 567 | "Return a list of faked files and their faked attributes in DIRECTORY. 568 | 569 | There are four optional arguments: 570 | If FULL is non-nil, return absolute file names. Otherwise return names 571 | that are relative to the specified directory. 572 | If MATCH is non-nil, mention only file names that match the regexp MATCH. 573 | If NOSORT is non-nil, the list is not sorted--its order is unpredictable. 574 | NOSORT is useful if you plan to sort the result yourself. 575 | ID-FORMAT is ignored. Instead we use the fakir format (see `fakir--file-attribs')." 576 | (let* ((directory-fakir-file 577 | (fakir--namespace-lookup 578 | directory 579 | fakir-file-namespace)) 580 | (parent-fakir-file (fakir--parent-fakir-file directory-fakir-file)) 581 | (directory-fakir-files (fakir--directory-fakir-files directory)) 582 | files-and-attributes) 583 | 584 | (if (or (not match) (string-match match ".")) 585 | (push (cons (if full 586 | (concat (file-name-as-directory directory) ".") 587 | ".") 588 | (fakir--file-attribs directory-fakir-file)) 589 | files-and-attributes)) 590 | 591 | (if (or (not match) (string-match match "..")) 592 | (push (cons (if full 593 | (concat (file-name-as-directory directory) "..") 594 | "..") 595 | (fakir--file-attribs parent-fakir-file)) 596 | files-and-attributes)) 597 | 598 | (dolist (fakir-file directory-fakir-files) 599 | (if (or (not match) (string-match match (fakir-file-filename fakir-file))) 600 | (push (cons (if full 601 | (fakir--file-fqn fakir-file) 602 | (fakir-file-filename fakir-file)) 603 | (fakir--file-attribs fakir-file)) 604 | files-and-attributes))) 605 | 606 | (if nosort 607 | files-and-attributes 608 | (sort files-and-attributes 609 | #'(lambda (s1 s2) 610 | (string-lessp (car s1) (car s2))))))) 611 | 612 | (defun fakir--directory-files (directory &optional full match nosort) 613 | "Return a list of names of faked files in DIRECTORY. 614 | 615 | There are three optional arguments: 616 | If FULL is non-nil, return absolute file names. Otherwise return names 617 | that are relative to the specified directory. 618 | If MATCH is non-nil, mention only file names that match the regexp MATCH. 619 | If NOSORT is non-nil, the list is not sorted--its order is unpredictable. 620 | Otherwise, the list returned is sorted with `string-lessp'. 621 | NOSORT is useful if you plan to sort the result yourself." 622 | (mapcar 'car (fakir--directory-files-and-attributes directory full match nosort))) 623 | 624 | (defmacro fakir-fake-file (faked-file &rest body) 625 | "Fake FAKED-FILE and evaluate BODY. 626 | 627 | FAKED-FILE must be a `fakir-file' object or a list of 628 | `fakir-file' objects." 629 | (declare (indent 1) 630 | (debug (sexp &rest form))) 631 | (let ((ffv (make-symbol "ff"))) 632 | `(let* ((,ffv ,faked-file) 633 | (fakir-file-namespace 634 | (if (fakir-file-p ,ffv) 635 | (fakir--namespace ,ffv) 636 | (apply 'fakir--namespace ,ffv)))) 637 | (noflet 638 | ((expand-file-name (file-name &optional dir) 639 | (let ((expanded 640 | (fakir--expand-file-name file-name dir))) 641 | (fakir--file-cond expanded 642 | expanded 643 | (funcall this-fn file-name dir)))) 644 | (file-attributes (file-name) 645 | (fakir--file-cond file-name 646 | (fakir--file-attribs this-fakir-file) 647 | (funcall this-fn file-name))) 648 | (file-exists-p (file-name) 649 | (fakir--file-cond file-name 650 | t 651 | (funcall this-fn file-name))) 652 | (file-directory-p (file-name) 653 | (fakir--file-cond file-name 654 | (fakir-file-directory-p this-fakir-file) 655 | (funcall this-fn file-name))) 656 | (file-regular-p (file-name) 657 | (fakir--file-cond file-name 658 | (not (fakir-file-directory-p this-fakir-file)) 659 | (funcall this-fn file-name))) 660 | (write-region (start end file-name &optional append visit lockname mustbenew) 661 | (fakir--file-cond file-name 662 | (fakir--write-region 663 | this-fakir-file ; the faked file - should match file-name 664 | start end file-name append visit mustbenew) 665 | (funcall this-fn start end file-name append visit mustbenew))) 666 | (rename-file (from to) 667 | (fakir--file-cond from 668 | (fakir--file-rename this-fakir-file to) 669 | (funcall this-fn from to))) 670 | (insert-file-contents 671 | (file-name &optional visit beg end replace) 672 | (fakir--file-cond file-name 673 | (insert (fakir-file-content this-fakir-file)) 674 | (funcall this-fn file-name))) 675 | (insert-file-contents-literally 676 | (file-name &optional visit beg end replace) 677 | (fakir--file-cond file-name 678 | (insert (fakir-file-content this-fakir-file)) 679 | (funcall this-fn file-name))) 680 | (find-file (file-name) 681 | (fakir--file-cond file-name 682 | (fakir--find-file this-fakir-file) 683 | (funcall this-fn file-name))) 684 | (find-file-noselect (file-name) 685 | (fakir--file-cond file-name 686 | (fakir--find-file this-fakir-file) 687 | (funcall this-fn file-name))) 688 | (directory-files (directory &optional full match nosort) 689 | (fakir--file-cond directory 690 | (fakir--directory-files directory full match nosort) 691 | (funcall this-fn directory full match nosort))) 692 | (directory-files-and-attributes (directory &optional full match nosort id-format) 693 | (fakir--file-cond directory 694 | (fakir--directory-files-and-attributes directory full match nosort id-format) 695 | (funcall this-fn directory full match nosort)))) 696 | ,@body)))) 697 | 698 | (defmacro fakir-mock-file (faked-file &rest body) 699 | (declare (debug (sexp &rest form)) 700 | (indent 1)) 701 | `(fakir-fake-file ,faked-file ,@body)) 702 | 703 | (provide 'fakir) 704 | 705 | ;;; fakir.el ends here 706 | --------------------------------------------------------------------------------